Run vba for multiple selected Excel file-CodePudding

I have a code to open text files to copy included data and paste it in the excel file, but while select multiple files the code run only for one file and i want to run it for all selectet files CWB is the main file NWB is the file to copy from it

The code

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

CodePudding user response：

Move the copying code to a separate subroutine that you can call for each file.

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

CodePudding user response：

Import Text Files

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