我正在学习用VBA编写并编写了一个代码，允许用户选择一堆文件导入到具有多个工作表的主Excel工作簿中。代码根据选项卡名称将源数据与主数据匹配，并将正确的数据附加到正确的选项卡。它还为日期和位置标识符添加了列，这些列不是原始数据文件的一部分到每个选项卡。
我认为我的代码运行良好，但只需要FOREVER运行。关键是要能够加快这个过程，因为之前手动完成，但我认为它可能仍然需要相同的时间，但现在只是等待。叹。
这是我的代码 - 感谢任何帮助！
Option Explicit
Sub CopyData()
Dim erow As Long, lastrow As Long, lastcolumn As Long, WbMonthly As Workbook
Dim TargetFiles As FileDialog
Dim FileIdx As Long, DataBook As Workbook
Dim sheet As Worksheet, counter As Long
Dim coutner As Long
Dim index As Long, index2 As Long, i As Long, j As Long
Dim lastrowend As Long, lastrowmid As Long
Dim ws As Worksheet
Dim month As String
Dim year As Long
Dim day As Long
Set WbMonthly = ThisWorkbook
'Worksheets("Instructions").Active
month = Range("B5").Value
day = Range("D5").Value
year = Range("F5").Value
If IsEmpty(Sheets(1).Range("B5")) Then
MsgBox ("Please enter a month before continuing")
Exit Sub
End If
If IsEmpty(Sheets(1).Range("D5")) Then
MsgBox ("Please enter a day before continuing")
Exit Sub
End If
If IsEmpty(Sheets(1).Range("F5")) Then
MsgBox ("Please enter a year before continuing")
Exit Sub
End If
'Unhide datasheets
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
'prompt user to select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
.AllowMultiSelect = True
.Title = "Multi-select target data files:"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Show
End With
For FileIdx = 1 To TargetFiles.SelectedItems.Count
'open the file and assign the workbook/worksheet
Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
Dim Filename As String
Filename = DataBook.Name
'if it is not the first data file, copy in the data by appending to what is already in the sheet
For i = 1 To DataBook.Sheets.Count
For j = 1 To WbMonthly.Sheets.Count
If DataBook.Worksheets(i).Name = WbMonthly.Worksheets(j).Name Then
'WbMonthly.Worksheets(counter + 2).Activate
erow = WbMonthly.Sheets(j).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
DataBook.Sheets(i).Activate
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(2, 1), Cells(lastrow, lastcolumn)).Copy _
WbMonthly.Sheets(j).Cells(erow, 1)
WbMonthly.Sheets(j).Activate
lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
lastrowmid = ActiveSheet.Cells(Rows.Count, lastcolumn).End(xlUp).Row
lastrowend = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For index2 = lastrowmid + 1 To lastrowend
ActiveSheet.Cells(index2, lastcolumn - 2) = left(Filename, 6)
ActiveSheet.Cells(index2, lastcolumn - 1) = day & " " & month
ActiveSheet.Cells(index2, lastcolumn) = year
Next index2
End If
Next j
Next i
Next FileIdx
'Close all of the datafiles
For FileIdx = 1 To TargetFiles.SelectedItems.Count
Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
DataBook.Close
Next FileIdx
'Hide datasheets
For i = 3 To WbMonthly.Sheets.Count
Sheets(i).Select
ActiveSheet.Visible = xlSheetHidden
Next i
WbMonthly.Sheets("INSTRUCTIONS").Activate
MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " APP DATA files")
End Sub
答案 0 :(得分：2)
除了你从评论中得到的所有建议（主要是在代码开头关闭自动重新计算和屏幕更新，然后在最后重新开启）时，你的代码也会遭受：< / p>
不必要的循环
您正在循环浏览每个WbMonthly工作表的每个打开的工作簿工作表，并且
激活/激活编码模式
所有工作表/工作簿切换对性能的影响，更重要的是，很容易对工作簿/工作表实际上活动的控制很快失控。
所以请使用完全合格的工作簿/工作表范围参考
将所有用户选定的文件保持打开状态，直到最后将它们全部关闭
涉及内存使用和可能的额外计算工作（如果所有打开的工作簿都在每次复制/粘贴操作时重新计算）
因此您可以考虑以下重构代码：
Sub CopyData()
Dim TargetFiles As FileDialog
Dim WbMonthly As Workbook
Dim ws As Worksheet
Dim lastrow As Long, lastcolumn As Long, lastrowend As Long, lastrowmid As Long
Dim FileIdx As Long
Dim i As Long
Dim month As String
Dim year As Long
Dim day As Long
Set WbMonthly = ThisWorkbook
With WbMonthly.Sheets("Instructions")
If IsEmpty(.Range("B5")) Then
MsgBox ("Please enter a month before continuing")
Exit Sub
Else
month = .Range("B5").Value
End If
If IsEmpty(.Range("D5")) Then
MsgBox ("Please enter a day before continuing")
Exit Sub
Else
day = .Range("D5").Value
End If
If IsEmpty(.Range("F5")) Then
MsgBox ("Please enter a year before continuing")
Exit Sub
Else
year = Range("F5").Value
End If
End With
'Unhide datasheets
For Each ws In ActiveWorkbook.Worksheets
ws.Visible = xlSheetVisible
Next ws
'prompt user to select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
.AllowMultiSelect = True
.Title = "Multi-select target data files:"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Show
End With
Dim Filename As String
Dim DBsht As Worksheet, MNSht As Worksheet
For FileIdx = 1 To TargetFiles.SelectedItems.Count
With Workbooks.Open(TargetFiles.SelectedItems(FileIdx)) 'open the file and reference it as a workbook
Filename = .Name
For Each DBsht In .Worksheets 'loop through each newly opened file worksheets
If GetSheet(WbMonthly, DBsht.Name, MNSht) Then ' if current sheet name matches one of 'WbMonthly' ones
With DBsht 'reference newly opened file current sheet
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), .Cells(lastrow, lastcolumn)).Copy _
MNSht.Cells(MNSht.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
With MNSht 'reference 'WbMonthly' sheet named after current newly opened file sheet
lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastrowmid = .Cells(.Rows.Count, lastcolumn).End(xlUp).Row
lastrowend = .Cells(.Rows.Count, 1).End(xlUp).Row
If lastrowmid < lastrowend Then .Cells(lastrowmid + 1, lastcolumn - 2).Resize(lastrowend - lastrowmid, 3).Value = Array(Left(Filename, 6), day & " " & month, year)
End With
End If
Next
.Close False
End With
Next FileIdx
'Hide datasheets
With WbMonthly
For i = 3 To .Sheets.Count
.Sheets(i).Visible = xlSheetHidden
Next i
.Sheets("Instructions").Activate
End With
MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " APP DATA files")
End Sub
Function GetSheet(wb As Workbook, shtName As String, sht As Worksheet) As Boolean
Set sht = Nothing
On Error Resume Next
Set sht = wb.Worksheets(shtName)
GetSheet = Not sht Is Nothing
End Function