我有一個代碼要打開文本檔案要復制包含的資料并在Excel檔案中粘貼它，但是選擇多個檔案的代碼僅為一個檔案運行，而且我想為所有選擇檔案運行它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
uj5u.com熱心網友回復：
將復制代碼移到可以為每個檔案呼叫的單獨子例程中。
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
uj5u.com熱心網友回復：
匯入文本檔案
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/384588.html