excel 通过VBA合并数据

r1wp621o  于 2023-05-08  发布在  其他
关注(0)|答案(1)|浏览(152)

我已经创建了一个VBA代码,它可以帮助我整合来自不同工作簿的数据,并粘贴到我的目标工作表中,同时粘贴数据,它正在粘贴公式,因为#REF!是来在所有的细胞,我想粘贴我的数据在PasteAsspecial。

Sub ConsolidateData()

    Dim sourcePath As String
    Dim folderName As Variant
    Dim sourceFile As String
    Dim SourceBook As Workbook
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastrow As Long
    Dim targetRow As Long
    Dim i As Long

    'Set the path to the source Directory
    sourcePath = "C:\Windows\Blackstone\Software\Box\Internal Control\L1 & L2 Review Project\Checklist"

    'Set the target sheet
    Set targetSheet = ThisWorkbook.Worksheets("Overview")

    'Copy Column headers to target sheet if it's empty
    If Application.CountA(targetSheet.Range("A1:XFD1")) = 0 Then
        targetSheet.Range("A1:XFD1").Value = Array("Tab Name", "Activity", "SOP Status", "CQ Quarter Transition", "Quarter of Transition", "Source Systems", "Exclusions/Exceptions", "Comments", "Criticality", "Time spent L1 (mins)", "Est. Time Spent L2 (mins)", "L2 Applicable")
        End If

    'Loop through each folder in the source directory
    For Each folderName In Array("Asia Business Finance", "Asia Finance I PM", "BEPIF FPA", "BPP Finance", "BREDS AM", "BREDS Loan Ops", "BREIT FP&A and PM", "BREP Finance", "Common Activities", "EMEA PM", "Europe PM", "US PM")
        'set the path to the source folder
        sourcePath = "C:\Windows\Blackstone\Software\Box\Internal Control\L1 & L2 Review Project\Checklist\Chicklist2\" & folderName & "\"

        'Loop through each file in the source folder
        sourceFile = Dir(sourcePath & "*.xlsx")
        Do While sourceFile <> ""
            'Open the sourceWorkbook
            Set SourceBook = Workbooks.Open(sourcePath & sourceFile)

            'set the source sheet
            Set sourceSheet = SourceBook.Worksheets("Overview")

            'Find the last row in the source sheet
            lastrow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row

            'loop through each row in the source sheet
            For i = 2 To lastrow
    
                'Check if the row meets the criteria for copying
                If sourceSheet.Cells(i, "A").Value <> "" Then

                    'copy the row to the target sheet
                    targetRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
                    sourceSheet.Range("A" & i & ":L" & i).Copy targetSheet.Range("B" & targetRow & ":M" & targetRow)
                    targetSheet.Cells(targetRow, "A").Value = folderName 'Add folder name to column A
                End If
            Next i

            'Close the sourceWorkbook
            SourceBook.Close

            'Get the next file in the directory
            sourceFile = Dir
        Loop
    Next folderName

    'Save the target workbook
    ThisWorkbook.Save

End Sub
guicsvcw

guicsvcw1#

快速和简单的方法来获得粘贴特殊:

sourceSheet.Range("A" & i & ":L" & i).Copy 
targetSheet.Range("B" & targetRow & ":M" & targetRow).PasteSpecial xlPasteValues

但你也可以用途:

targetSheet.Range("B" & targetRow & ":M" & targetRow).Value = sourceSheet.Range("A" & i & ":L" & i).Value

更快的方法是使用数组,这样你就不会逐行添加:

Sub ConsolidateData()
    
    Const COL_AMT = 13 'amount of col A-M
    Dim sourcePath As String
    Dim folderName As Variant
    Dim sourceFile As String
    Dim SourceBook As Workbook
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastrow As Long
    Dim lRowT As Long
    Dim i As Long, j As Long, rCount As Long
    Dim arr(), arrT()

    'Set the path to the source Directory
    sourcePath = "C:\Windows\Blackstone\Software\Box\Internal Control\L1 & L2 Review Project\Checklist"

    'Set the target sheet
    Set targetSheet = ThisWorkbook.Worksheets("Overview")

    'Copy Column headers to target sheet if it's empty
    If Application.CountA(targetSheet.Range("A1:XFD1")) = 0 Then
        targetSheet.Range("A1:XFD1").Value = Array("Tab Name", "Activity", "SOP Status", "CQ Quarter Transition", "Quarter of Transition", "Source Systems", "Exclusions/Exceptions", "Comments", "Criticality", "Time spent L1 (mins)", "Est. Time Spent L2 (mins)", "L2 Applicable")
    End If

    'Loop through each folder in the source directory
    For Each folderName In Array("Asia Business Finance", "Asia Finance I PM", "BEPIF FPA", "BPP Finance", "BREDS AM", "BREDS Loan Ops", "BREIT FP&A and PM", "BREP Finance", "Common Activities", "EMEA PM", "Europe PM", "US PM")
        'set the path to the source folder
        sourcePath = "C:\Windows\Blackstone\Software\Box\Internal Control\L1 & L2 Review Project\Checklist\Chicklist2\" & folderName & "\"

        'Loop through each file in the source folder
        sourceFile = Dir(sourcePath & "*.xlsx")
        Do While sourceFile <> ""
            'Open the sourceWorkbook
            Set SourceBook = Workbooks.Open(sourcePath & sourceFile)

            'set the source sheet
            Set sourceSheet = SourceBook.Worksheets("Overview")

            'Find the last row in the source sheet
            lastrow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
            lRowT = targetSheet.Range("A" & targetSheet.Rows.Count).End(xlUp).Row 'get the lRow of the targetSheet once per loop
            arr = sourceSheet.Range("A2:L" & lastrow).Value 'place all needed data in array
            ReDim arrT(1 To UBound(arr, 1), 1 To COL_AMT) '
            'loop through each row in the source sheet
            For i = 1 To lastrow - 1 'arr starts at 1
    
                'Check if the row meets the criteria for copying
                If arr(i, 1) <> "" Then
                    rCount = rCount + 1
                    arrT(rCount, 1) = folderName
                    For j = 2 To COL_AMT
                        arrT(rCount, j) = arr(i, j - 1)
                    Next j
                End If
            Next i
            targetSheet.Range("A" & lRowT).Offset(1).Resize(rCount, COL_AMT).Value = arrT 'get the needed rows in your targetsheet in one go
            'Close the sourceWorkbook
            SourceBook.Close

            'Get the next file in the directory
            sourceFile = Dir
        Loop
    Next folderName

    'Save the target workbook
    ThisWorkbook.Save

End Sub

(don别忘了我确实编辑/添加了一些变量)希望对你有效:)

相关问题