为多个选定的 Excel 文件运行 vba

Posted 2023-02-19

【中文标题】为多个选定的 Excel 文件运行 vba

【英文标题】：Run vba for multiple selected Excel file

【发布时间】：2022-01-18 16:58:12

【问题描述】：

我有一个代码来打开文本文件以复制包含的数据并将其粘贴到 excel 文件中，但是在选择多个文件时，代码仅针对一个文件运行，我想为所有 selectet 文件运行它 CWB是主文件 NWB 是从中复制的文件

代码

Sub Import_Reports()
' Difine References
    Dim CWB As Excel.Workbook
    Dim NWB As Excel.Workbook
    Dim FN As String
    Dim FD As FileDialog
    
    Set CWB = ThisWorkbook
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .AllowMultiSelect = True
        .Filters.Add "Excel Files or Text or CSV", "*.xls; *.xlsx; *.xlsm; *.xlsb; *.csv; *.txt", 1
        .Show
        If .SelectedItems.Count > 0 Then
            FN = .SelectedItems(1)
            
            Workbooks.OpenText Filename:=FN, _
        Origin:=65001, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
        Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 2), _
        Array(2, 2), Array(3, 2), Array(4, 4), Array(5, 1), Array(6, 2), Array(7, 2), Array(8, 2), _
        Array(9, 4), Array(10, 1), Array(11, 1), Array(12, 4), Array(13, 2), Array(14, 2), Array(15 _
        , 1), Array(16, 1), Array(17, 4), Array(18, 4), Array(19, 1), Array(20, 1), Array(21, 1), _
        Array(22, 1)), TrailingMinusNumbers:=True
            
            Set NWB = ActiveWorkbook
    NWB.Activate
    ActiveSheet.Select
    Dim LastRow As Long
    LastRow = Range("B" & Rows.Count).End(xlUp).Row
    Range("A2:V" & LastRow).Select
    Selection.Copy
    
    CWB.Activate
    Sheets("Payroll Report").Select
    LastRow = Range("B" & Rows.Count).End(xlUp).Row + 1
    Range("A" & LastRow).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells.Select
    Selection.SpecialCells(xlCellTypeLastCell).Select
    Selection.EntireRow.Delete
    Range("A" & LastRow).Select
        
    NWB.Close SaveChanges:=False
    
    Else
    Exit Sub
    End If
    End With
End Sub

【问题讨论】：

你明白FN = .SelectedItems(1)在做什么吗？

【参考方案1】：

导入文本文件

Option Explicit

Sub Import_Reports()
    
    Dim FD As FileDialog
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    
    Dim collFilePaths As Object
    With FD
        .AllowMultiSelect = True
        .Filters.Add "Excel Files or Text or CSV", "*.xls; *.xlsx; *.xlsm; *.xlsb; *.csv; *.txt", 1
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "You canceled.", vbExclamation
            Exit Sub
        Else
            Set collFilePaths = .SelectedItems
        End If
    End With

    Dim CWB As Workbook: Set CWB = ThisWorkbook
    Dim cws As Worksheet: Set cws = CWB.Worksheets("Payroll Report")
    Dim cfrrg As Range
    Set cfrrg = cws.Range("B" & cws.Rows.Count).End(xlUp) _
        .Offset(1).EntireRow.Columns("A:V")

    Application.ScreenUpdating = False

    Dim FilePath As Variant
    Dim NWB As Workbook
    Dim nws As Worksheet
    Dim nrg As Range
    Dim nLastRow As Long
    Dim crg As Range
    
    For Each FilePath In collFilePaths
        'Set NWB = Workbooks.Open(FilePath) ' tested with this line
        On Error Resume Next
            Set NWB = Workbooks.OpenText(Filename:=CStr(FilePath), _
                Origin:=65001, StartRow:=1, DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
                Tab:=True, Semicolon:=False, Comma:=True, Space:=False, _
                Other:=False, FieldInfo:=Array(Array(1, 2), Array(2, 2), _
                Array(3, 2), Array(4, 4), Array(5, 1), Array(6, 2), _
                Array(7, 2), Array(8, 2), Array(9, 4), Array(10, 1), _
                Array(11, 1), Array(12, 4), Array(13, 2), Array(14, 2), _
                Array(15, 1), Array(16, 1), Array(17, 4), Array(18, 4), _
                Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1)), _
                TrailingMinusNumbers:=True)
        On Error GoTo 0
        If Not NWB Is Nothing Then
            Set nws = NWB.Worksheets(1)
            ' Delete last row = Don't Copy Last row - '- 1' ???
            nLastRow = nws.Range("B" & nws.Rows.Count).End(xlUp).Row - 1
            If nLastRow >= 2 Then
                Set nrg = nws.Range("A2:V" & nLastRow)
                nLastRow = nLastRow - 1
                Set crg = cfrrg.Resize(nLastRow)
                crg.Value = nrg.Value
                Set cfrrg = cfrrg.Offset(nLastRow)
            End If
            NWB.Close SaveChanges:=False
            Set NWB = Nothing
        End If
    Next FilePath
    
    cws.Activate
    cfrrg.Cells(1).Select
    'CWB.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Reports imported.", vbInformation
    
End Sub

【参考方案2】：

将复制代码移动到可以为每个文件调用的单独子例程中。

Option Explicit

Sub Import_Reports()
    ' Define References
    Dim CWB As Excel.Workbook
    Dim FD As FileDialog, n
    
    Set CWB = ThisWorkbook
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .AllowMultiSelect = True
        .Filters.Add "Excel Files or Text or CSV", "*.xls; *.xlsx; *.xlsm; *.xlsb; *.csv; *.txt", 1
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        
        For n = 1 To .SelectedItems.Count
             Call ImportTextFile(CWB, .SelectedItems(n))
        Next
    End With
    MsgBox n - 1 & " files imported", vbInformation
                    
End Sub

Sub ImportTextFile(CWB As Workbook, filename As String)

    Workbooks.OpenText filename:=filename, _
        Origin:=65001, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
        Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 2), _
        Array(2, 2), Array(3, 2), Array(4, 4), Array(5, 1), Array(6, 2), Array(7, 2), Array(8, 2), _
        Array(9, 4), Array(10, 1), Array(11, 1), Array(12, 4), Array(13, 2), Array(14, 2), Array(15 _
        , 1), Array(16, 1), Array(17, 4), Array(18, 4), Array(19, 1), Array(20, 1), Array(21, 1), _
        Array(22, 1)), TrailingMinusNumbers:=True

    Dim LastRow As Long, ar
    With ActiveWorkbook.Sheets(1)
        LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
        ' copy values to array except last row
        ar = .Range("A2:V" & LastRow - 1).Value2
    End With
    ActiveWorkbook.Close SaveChanges:=False
    
    ' copy array to CWB
    With CWB.Sheets("Payroll Report")
        LastRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & LastRow).Resize(UBound(ar), UBound(ar, 2)) = ar
    End With

End Sub