Question

我有一个独特的问题集。我的目录中有多个工作簿，其中的工作表的名称与“分配”相同。我需要搜索工作表中的每一行（“分配”）以查找文本（在N列下）“进行中”或“失败”，并依次遍历相应工作表中的整个行（“分配”）文件夹中存在多个工作簿，最后将这些行粘贴到我的活动工作表（“主”）中。

每个工作表中的行总数不超过500

我是VBA的新手，下面的Web代码部分帮助了我。需要帮助或解决该问题的方法。

我尝试复制多个工作簿中的所有工作表，然后将其合并以将搜索应用于主工作表中的合并行。该代码遇到了溢出错误，并且花了很长时间才最终解决。

Sub test()

    Dim MyFile As String, MyFiles As String, FilePath As String
    Dim erow As Long
    '~~> Put additional variable declaration
    Dim wbMaster As Workbook, wbTemp As Workbook
    Dim wsMaster As Worksheet, wsTemp As Worksheet

    FilePath = "H:\Alloc\"
    MyFiles = "H:\Alloc\*.xlsm"
    MyFile = Dir(MyFiles)

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    '~~> Set your declared variables
    Set wbMaster = ThisWorkbook 'if you want to consolidate files in this workbook
    Set wsMaster = wbMaster.Sheets("ALLAllocation") 'replace Sheet1 to suit

    Do While Len(MyFile) > 0
        'Debug.Print MyFile
        If MyFile <> "Anup_Allocation - Copy.xlsm" Then
            '~~> Open the file and at the same time, set your variable
            Set wbTemp = Workbooks.Open(fileName:=FilePath & MyFile, ReadOnly:=True)
            Set wsTemp = wbTemp.Sheets("Allocation") 'I used index, you said there is only 1 sheet
            '~~> Now directly work on your object
            With wsMaster
                erow = .Range("A" & .Rows.Count).End(xlUp).Row 'get the last row
                '~~> Copy from the file you opened
                wsTemp.Range("A2:N200").copy 'you said this is fixed as well
                '~~> Paste on your master sheet
                .Range("A" & erow).Offset(1, 0).PasteSpecial xlPasteValues
            End With
            '~~> Close the opened file
            wbTemp.Close False 'set to false, because we opened it as read-only
            Set wsTemp = Nothing
            Set wbTemp = Nothing
        End If
        '~~> Load the new file
        MyFile = Dir
    Loop

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub

Answer 1

这应该比您当前的方法快，并且只会复制带有“进行中”或“失败”的行：

Option Explicit
Sub test()

    Dim MyFile As String, MyFiles As String, FilePath As String, MyCriteria As String
    Dim x As Long, i As Long, NFiles As Long, j As Long
    Dim arr As Variant, arrTemp As Variant

    '~~> Put additional variable declaration
    Dim wbMaster As Workbook, wbTemp As Workbook
    Dim wsMaster As Worksheet, wsTemp As Worksheet

    FilePath = "H:\Alloc\"
    MyFiles = "H:\Alloc\*.xlsm"
    MyFile = Dir(MyFiles)
    NFiles = 10 'this could be counted using FSO

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    '~~> Set your declared variables
    Set wbMaster = ThisWorkbook 'if you want to consolidate files in this workbook
    Set wsMaster = wbMaster.Sheets("ALLAllocation") 'replace Sheet1 to suit

    'this will dimension an array as large as 500 rows multiplied for NFiles and with many columns as the master sheet
    ReDim arr(1 To 500 * NFiles, 1 To wsMaster.UsedRange.Columns.Count)
    x = 1 'initialize the main array row counter
    Do While Len(MyFile) > 0
        'Debug.Print MyFile
        If MyFile <> "Anup_Allocation - Copy.xlsm" Then
            '~~> Open the file and at the same time, set your variable
            Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)
            'insert the whole data from the sheet inside the temporal array
            arrTemp = wbTemp.Sheets("Allocation").UsedRange.Value
            '~~> Close the opened file
            wbTemp.Close
            Set wbTemp = Nothing
            For i = 2 To UBound(arrTemp)
                MyCriteria = arrTemp(i, 14) 'this is the column N
                If MyCriteria = "In-Progress" Or MyCriteria = "Failed" Then 'if the criteria is meet
                    'loop through all the columns to add the row on your main array
                    For j = 1 To UBound(arrTemp, 2)
                        arr(x, j) = arrTemp(i, j)
                    Next j
                    x = x + 1 'add a counter to your main array row
                End If
            Next i
        End If
        '~~> Load the new file
        MyFile = Dir
    Loop

    With wsMaster
        i = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'find the next available row on the master sheet
        .Range("A" & i, .Cells(UBound(arr) + i, UBound(arr, 2))).Value = arr 'paste the array to the master sheet
        'delete the most likely extra rows inserted by the array
        i = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'find the next available row on the master sheet
        .Rows(i & ":" & .Rows.Count).Delete
    End With

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub

如果母版工作表上的列少于临时工作簿的列，或者如果您没有更改NFile上的10条并且您有10个以上的文件，则此操作可能会失败...检查如何计算使用FSO（FileSystemObject）将文件放在文件夹中。

如何从目录中的多个工作簿中复制特定工作表的所有内容并填充到activeworkbook中

1 个答案: