此宏的目标是将来自不同月份的多个excel文件中的数据合并到一个主excel文件中。我已经在主excel文件中为每个月创建了一个选项卡(请参见图片),我希望数据可以相互堆叠。
我发现了一些有用的代码,但我的代码几次修改后就可以工作了。我认为我需要解决一些问题才能使其按我的意愿工作:
此代码是使用固定的范围构建的,该范围会被复制。我正在查看的excel文件的范围是可变的。
代码在读取Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)
的行上不断中断。这可能是因为我正在不同月份的文件夹中测试具有相同名称的excel文件吗?
我遇到以下错误:“运行时错误'1004':Microsoft Excel无法访问文件'S:\ Actg \ TESTING \ September \ Loans_20180920.csv'。有几种可能的原因:-文件名或路径不存在。-该文件正在被另一个程序使用。我仔细检查并删除了我正在测试的所有其他excel文件,但“九月”文件夹中的文件除外,但仍然出现此错误。
原始代码参考:Dan Wagner(Copying worksheets from multiple workbooks into current workbook)
这是我正在使用的代码:
Sub Stack_Overflow_Example()
Dim MyFile As String, MyFiles As String, FilePath As String
Dim erow As Long
Dim wbMaster As Workbook, wbTemp As Workbook
Dim wsMaster As Worksheet, wsTemp As Worksheet
FilePath = "S:\Actg\TESTING\September\"
MyFiles = "S:\Actg\TESTING\September\*.csv"
MyFile = Dir(MyFiles)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set wbMaster = ThisWorkbook
Set wsMaster = wbMaster.Sheets("September")
Do While Len(MyFile) > 0
If MyFile <> "master.xlsm" Then
Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)
Set wsTemp = wbTemp.Sheets(1)
With wsMaster
erow = .Range("A" & .Rows.Count).End(xlUp).Row
wsTemp.Range("A2:U88").Copy
.Range("A" & erow).Offset(1, 0).PasteSpecial xlPasteValues
End With
wbTemp.Close False
Set wsTemp = Nothing
Set wbTemp = Nothing
End If
MyFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
如果您还有其他问题,请告诉我。
答案 0 :(得分:0)
我的情况听起来与您的情况有些不同,因为我从中复制数据的每个工作簿在每个工作簿以及主工作簿中都有单独的月份,但这应该使您走上正确的道路。
请注意,以下代码假定存在不应复制的标题行。如果没有,则将复制行中的第一行从2更改为1。如果需要从多个位置打开文件,则可以在文件打开代码块之前为位置数添加另一个循环,并针对该循环的每次迭代为每个位置更改MyFolder变量。
Sub RefreshMasterWorkbookData()
'Enable Error Handling
On Error GoTo Oops
'Declare variables and objects
Dim WkBk As Workbook, WkShtMaster As Worksheet, WkShtUser As Worksheet, CopyToRow As Long, PasteAtRow As Long
'Turn off screen updating and calculation to improve process speed and turn off events to keep other code (such as Worksheet_Change) from being triggered
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Open all files in a given directory
Dim MyFolder As String, MyFile As String
MyFolder = "C:\MyFolder" 'OR: "\\NetworkServer\NetworkFolder"
MyFile = Dir(MyFolder & "\*.xlsm") '& "\*.xl*")
Do While MyFile <> ""
Workbooks.Open FileName:=MyFolder & "\" & MyFile, ReadOnly:=True
MyFile = Dir
Loop
For Each WkBk In Workbooks 'Loops through each open workbook
If Not WkBk.Name = ThisWorkbook.Name Then 'If not this master workbook
For Each WkShtUser In WkBk.Worksheets 'Loops through each worksheet in the current workbook
Select Case WkShtUser.Name 'Worksheet name for Month
Case "Jan" 'Jan is the worksheet name for the monthly tab/sheet in the users individual file
Set WkShtMaster = M_01 'M_01 is the CodeName of the monthly worksheet in Master file
Case "Feb"
Set WkShtMaster = M_02
Case "Mar"
Set WkShtMaster = M_03
Case "Apr"
Set WkShtMaster = M_04
Case "May"
Set WkShtMaster = M_05
Case "Jun"
Set WkShtMaster = M_06
Case "Jul"
Set WkShtMaster = M_07
Case "Aug"
Set WkShtMaster = M_08
Case "Sep"
Set WkShtMaster = M_09
Case "Oct"
Set WkShtMaster = M_10
Case "Nov"
Set WkShtMaster = M_11
Case "Dec"
Set WkShtMaster = M_12
Case Else
GoTo NextWkSht
End Select
PasteAtRow = WkShtMaster.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row + 1 'find first empty row in master sheet for appropriate month
With WkShtUser 'Clear autofilter, if on, and copy designated columns of data from row 2 through last row
If .FilterMode = True Then .AutoFilterMode = False
CopyToRow = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
If CopyToRow = 1 Then GoTo EmptyWkSht
.Range("A2", "Z" & CopyToRow).Copy 'Where "Z" is the lst column of data you want to copy
End With
WkShtMaster.Range("A" & PasteAtRow).PasteSpecial xlPasteValues 'Paste data to empty rows in master for appropriate month
EmptyWkSht:
If Not WkShtMaster Is Nothing Then Set WkShtMaster = Nothing
CopyToRow = 0
PasteAtRow = 0
NextWkSht:
Next
WkBk.Saved = True
WkBk.Close False
End If
Next
Oops:
If Err Then
Debug.Print Err.Description
MsgBox "Refresh Error:" & vbNewLine & vbNewLine & Err.Description, vbCritical, "Error..."
Else
MsgBox "Refresh Completed Successfully", vbInformation, "Refresh Complete..."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub