Consolidate Paste Special (Values)

2019-09-03 16:02发布

How can the data copied to the consolidated sheet be pasted as values, currently works but where formulas are present these are copied over as is when in fact its the result needed from the initial sheet that needs to be taken.

An additional mod is also needed to only copy from row 2 on each entry sheet to the consolidated data tab.

Sub Consolidate_Data_From_Different_Sheets_Into_Single_Sheet()

On Error GoTo IfError

Dim Sht As Worksheet, DstSht As Worksheet
Dim LstRow As Long, LstCol As Long, DstRow As Long
Dim i As Integer, EnRange As String
Dim SrcRng As Range

With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidate_Data").Delete
Application.DisplayAlerts = True

With ActiveWorkbook
 Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
 DstSht.Name = "Consolidate_Data"
End With

For Each Sht In ActiveWorkbook.Worksheets

    If Sht.Name <> DstSht.Name Then

        DstRow = fn_LastRow(DstSht)     

        LstRow = fn_LastRow(Sht)
        LstCol = fn_LastColumn(Sht)
        EnRange = Sht.Cells(LstRow, LstCol).Address
        Set SrcRng = Sht.Range("A1:" & EnRange)

        If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then
            MsgBox "There are not enough rows to place the data in the Consolidate_Data worksheet."
            GoTo IfError
        End If

        SrcRng.Copy Destination:=DstSht.Range("A" & DstRow + 1)

    End If

Next

DstSht.Range("A1") = "X"

IfError:
    With Application
     .ScreenUpdating = True
     .EnableEvents = True
    End With

End Sub

Function fn_LastRow(Sht As Worksheet)

Dim lastRow As Long
lastRow = Sht.Cells.SpecialCells(xlLastCell).Row
lRow = Sht.Cells.SpecialCells(xlLastCell).Row
Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
    lRow = lRow - 1
Loop
fn_LastRow = lRow

End Function

Function fn_LastColumn(Sht As Worksheet)

Dim lastCol As Long
lastCol = Sht.Cells.SpecialCells(xlLastCell).Column
lCol = Sht.Cells.SpecialCells(xlLastCell).Column
Do While Application.CountA(Sht.Columns(lCol)) = 0 And lCol <> 1
    lCol = lCol - 1
Loop
fn_LastColumn = lCol

End Function

Tried adding:

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

0条回答
登录 后发表回答