Run vba for multiple selected Excel file - excel

Question

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

Answer 1

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

Answer 2

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