I have a macro that needs to open a few excel files and copy data from those files and paste them into the macro file in a sheet named "Consolidated". The macro goes to a specified path, counts the number of files in the folder and then loops through to open a file, copy the contents and then save and close the file.
我有一个宏，需要打开一些excel文件，并从这些文件中复制数据，并将它们粘贴到一个名为“Consolidated”的文件中。宏进入指定的路径，计算文件夹中的文件数，然后循环打开文件，复制内容，然后保存并关闭文件。
The macro runs perfectly on my system but not on the users systems.
宏在我的系统上运行良好，但在用户系统上没有。
The error i am receiving during the looping process is "Runtime Error '9' Subscript out of range". The line on which this error pops up is
我在循环过程中接收到的错误是“运行时错误”9“下标超出范围”。这个错误出现的线是。
Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
At first i thought that the files might be opening slower than the code execution so i added wait time of 5 seconds before and after the above line...but to no avail.
起初，我认为文件可能会比代码执行慢一些，所以我在上面一行的前后加上了5秒的等待时间……但无济于事。
The code is listed below
代码如下所示。
Sub grab_data()
Application.ScreenUpdating = False
Dim rng As Range
srow = ThisWorkbook.Sheets("Consolidated Data").Cells(65536, 11).End(xlUp).Row
'Number of filled rows in column A of control Sheet
ThisWorkbook.Sheets("Control Sheet").Activate
rawfilepth = Sheets("Control Sheet").Cells(65536, 1).End(xlUp).Row
'Loop to find the number of excel files in the path in each row of the Control Sheet
For folder_count = 2 To rawfilepth
wkbpth = Sheets("Control Sheet").Cells(folder_count, 1).Value
With Application.FileSearch
.LookIn = wkbpth
.FileType = msoFileTypeExcelWorkbooks
.Execute
filecnt = .FoundFiles.Count
'Loop to count the number of sheets in each file
For file_count = 1 To filecnt
Application.Wait (Now + TimeValue("0:00:05"))
Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
Application.Wait (Now + TimeValue("0:00:05"))
filenm = ActiveWorkbook.Name
For sheet_count = 1 To Workbooks(filenm).Sheets.Count
If Workbooks(filenm).Sheets(sheet_count).Name <> "Rejected" Then
Workbooks(filenm).Sheets(sheet_count).Activate
ActiveSheet.Columns("a:at").Select
Selection.EntireColumn.Hidden = False
shtnm = Trim(ActiveSheet.Name)
lrow = ActiveSheet.Cells(65536, 11).End(xlUp).Row
If lrow = 1 Then lrow = 2
For blank_row_count = 2 To lrow
If ActiveSheet.Cells(blank_row_count, 39).Value = "" Then
srow = ActiveSheet.Cells(blank_row_count, 39).Row
Exit For
End If
Next blank_row_count
For uid = srow To lrow
ActiveSheet.Cells(uid, 40).Value = ActiveSheet.Name & uid
Next uid
ActiveSheet.Range("a" & srow & ":at" & lrow).Copy
ThisWorkbook.Sheets("Consolidated Data").Activate
alrow = ThisWorkbook.Sheets("Consolidated Data").Cells(65536, 11).End(xlUp).Row
ThisWorkbook.Sheets("Consolidated Data").Range("a" & alrow + 1).Activate
ActiveCell.PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Consolidated Data").Range("z" & alrow + 1).Value = shtnm
ThisWorkbook.Sheets("Consolidated Data").Range("z" & alrow + 1 & ":z" & (alrow+lrow)).Select
Selection.FillDown
ThisWorkbook.Sheets("Consolidated Data").Range("ap" & alrow + 1).Value = wkbpth
ThisWorkbook.Sheets("Consolidated Data").Range("ap" & alrow + 1 & ":ap" & (alrow + lrow)).Select
Selection.FillDown
ThisWorkbook.Sheets("Consolidated Data").Range("ao" & alrow + 1).Value = filenm
ThisWorkbook.Sheets("Consolidated Data").Range("ao" & alrow + 1 & ":ao" & (alrow + lrow)).Select
Selection.FillDown
Workbooks(filenm).Sheets(sheet_count).Activate
ActiveSheet.Range("am" & srow & ":am" & lrow).Value = "Picked"
ActiveSheet.Columns("b:c").EntireColumn.Hidden = True
ActiveSheet.Columns("f:f").EntireColumn.Hidden = True
ActiveSheet.Columns("h:i").EntireColumn.Hidden = True
ActiveSheet.Columns("v:z").EntireColumn.Hidden = True
ActiveSheet.Columns("aa:ac").EntireColumn.Hidden = True
ActiveSheet.Columns("ae:ak").EntireColumn.Hidden = True
End If
Next sheet_count
Workbooks(filenm).Close True
Next file_count
End With
Next folder_count
Application.ScreenUpdating = True
End Sub
Thanks in advance for your help.
谢谢你的帮助。
3 个解决方案
#1
3
First off, make sure you have
首先，确保你有。
Option Explicit
at the top of your code so you can make sure you don't mess any of your variables up. This way, everything is dimensioned at the beginning of your procedure. Also, use variables for your workbooks, it'll clean up the code and make it more understandable, also, use indenting.
在你的代码的顶部，这样你就可以确保你不会把你的变量弄乱。这样，在你的程序开始的时候，所有的东西都被标注了尺寸。另外，使用变量为您的工作簿，它将清理代码并使它更容易理解，同样，使用缩进。
This worked for me, I found that I need to make sure the file isn't already open (assuming you aren't using an add-in) so you don't want to open the workbook with the code in it when it is already open):
这对我来说很有效，我发现我需要确保文件不是已经打开的(假设你没有使用外接程序)，所以当它已经打开时，你不想打开工作簿，里面有代码。
Sub grab_data()
Dim wb As Workbook, wbMacro As Workbook
Dim filecnt As Integer, file_count As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wbMacro = ThisWorkbook
With Application.FileSearch
.LookIn = wbMacro.Path
.FileType = msoFileTypeExcelWorkbooks
.Execute
filecnt = .FoundFiles.Count
'Loop to count the number of sheets in each file
For file_count = 1 To filecnt
If wbMacro.FullName <> .FoundFiles(file_count) Then
Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
Debug.Print wb.Name
wb.Close True
End If
Next file_count
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Hope that helps.
希望有帮助。
Try this (hope I didn't mess any of it up), basically, I'm checking to make sure the directory exists also, and I cleaned up the code quite a bit to make it more understandable (mainly for myself):
试试这个(希望我没有把它弄乱)，基本上，我正在检查，以确保目录也存在，并且我清理了一些代码，使它更容易理解(主要是为了我自己):
Sub grab_data()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim lRow As Long, lRowEnd As Long, lFolder As Long, lFilesTotal As Long, lFile As Long
Dim lUID As Long
Dim rng As Range
Dim sWkbPath As String
Dim wkb As Workbook, wkbTarget As Workbook
Dim wksConsolidated As Worksheet, wks As Worksheet
Dim v1 As Variant
Set wkb = ThisWorkbook
Set wksConsolidated = wkb.Sheets("Consolidated Data")
'Loop to find the number of excel files in the path in each row of the Control Sheet
For lFolder = 2 To wksConsolidated.Cells(65536, 1).End(xlUp).Row
sWkbPath = wksConsolidated.Cells(lFolder, 1).Value
'Check if file exists
If Not Dir(sWkbPath, vbDirectory) = vbNullString Then
With Application.FileSearch
.LookIn = sWkbPath
.FileType = msoFileTypeExcelWorkbooks
.Execute
lFilesTotal = .FoundFiles.Count
'Loop to count the number of sheets in each file
For lFile = 1 To lFilesTotal
If .FoundFiles(lFile) <> wkb.FullName Then
Set wkbTarget = Workbooks.Open(Filename:=.FoundFiles(lFile))
For Each wks In wkbTarget.Worksheets
If wks.Name <> "Rejected" Then
wks.Columns("a:at").EntireColumn.Hidden = False
lRowEnd = Application.Max(ActiveSheet.Cells(65536, 11).End(xlUp).Row, 2)
v1 = Application.Transpose(wks.Range(Cells(2, 39), Cells(lRowEnd, 39)))
For i = 1 To UBound(v1)
If Len(v1(i)) = 0 Then
lRow = i + 1
Exit For
End If
Next i
v1 = Application.Transpose(wks.Range(Cells(lRow, 40), Cells(lRowEnd, 40)))
For lUID = 1 To UBound(v1)
v1(lUID) = wks.Name & lUID
Next lUID
Application.Transpose(wks.Range(Cells(lRow, 40), Cells(lRowEnd, 40))) = v1
wks.Range("a" & lRow & ":at" & lRowEnd).Copy
i = wksConsolidated.Cells(65536, 11).End(xlUp).Row
With wksConsolidated
.Range("A" & i).PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("z" & i + 1).Value = wks.Name
.Range("z" & i + 1 & ":z" & i + lRowEnd).FillDown
.Range("ap" & i + 1) = sWkbPath
.Range("ap" & i + 1 & ":ap" & i + lRowEnd).FillDown
.Range("ao" & i + 1) = wkbTarget.FullName
.Range("ao" & i + 1 & ":ao" & (i + lRowEnd)).FillDown
End With
With wks
.Range("am" & lRow & ":am" & lRowEnd) = "Picked"
.Columns("b:c").EntireColumn.Hidden = True
.Columns("f:f").EntireColumn.Hidden = True
.Columns("h:i").EntireColumn.Hidden = True
.Columns("v:z").EntireColumn.Hidden = True
.Columns("aa:ac").EntireColumn.Hidden = True
.Columns("ae:ak").EntireColumn.Hidden = True
End With
End If
Next wks
wkbTarget.Close True
End If
Next lFile
End With
End If
Next lFolder
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
#2
1
There may be two issues here
这里可能有两个问题。
The macro runs perfectly on my system but not on the users systems
宏在我的系统上运行良好，但在用户系统上没有。
I presume you are running this in xl2003 as Application.FileSearch was deprecated in xl2007. So you are probably best advised to use a Dir approach instead to ensure your code works on all machines. Are you users all using xl2003?
我假定您在xl2003中运行这个应用程序。在xl2007中，FileSearch被弃用。因此，最好建议使用Dir方法，而不是确保代码在所有机器上都有效。您的用户都使用xl2003吗?
You will get a "Object doesn't support this action" error in xl2007/10
在xl2007/10中，您将得到一个“对象不支持此操作”的错误。
The error i am receiving during the looping process is "Runtime Error '9' Subscript out of range
我在循环过程中接收到的错误是“运行时错误”9'下标超出范围。
Is this error occuring on your machine, or on one/all of the user machines?
这个错误发生在你的机器上，还是在一个/所有的用户机器上?
#3
1
Ok guys,
好了伙计们,
I have finally been able to figure out the problem.
我终于能够解决这个问题了。
This error is occuring because some of the files in the raw data folder are corrupted and get locked automatically. So when the macro on opening the file gets an error and stops there.
这个错误是发生的，因为原始数据文件夹中的一些文件被损坏，并且被自动锁定。当打开文件的宏出现错误并停止时。
I have now made a change to the macro. It would now first check if the files are all ok to be imported. If there is a corrupt file then it would list down their names and the user will be required to manually open it and then do a "save As" and save a new version of the corrupt file and then delete it.
现在我已经对宏进行了更改。现在它首先检查文件是否都可以导入。如果有一个损坏的文件，它会列出他们的名字，用户将被要求手动打开它，然后做一个“保存为”并保存一个新版本的腐败文件，然后删除它。
Once this is done then the macro does the import of the data.
一旦完成，宏就会导入数据。
I am putting down the code below for testing the corrupt files.
我正在放下下面的代码来测试这些损坏的文件。
Sub error_tracking()
Dim srow As Long
Dim rawfilepth As Integer
Dim folder_count As Integer
Dim lrow As Long
Dim wkbpth As String
Dim alrow As Long
Dim One_File_List As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Control Sheet").Activate
rawfilepth = Sheets("Control Sheet").Cells(65536, 1).End(xlUp).Row
Sheets("Control Sheet").Range("E2:E100").Clear
'Loop to find the number of excel files in the path
'in each row of the Control Sheet
For folder_count = 2 To rawfilepth
wkbpth = Sheets("Control Sheet").Cells(folder_count, 1).Value
One_File_List = Dir$(wkbpth & "\*.xls")
Do While One_File_List <> ""
On Error GoTo err_trap
Workbooks.Open wkbpth & "\" & One_File_List
err_trap:
If err.Number = "1004" Then
lrow = Sheets("Control Sheet").Cells(65536, 5).End(xlUp).Row
Sheets("Control Sheet").Cells(lrow + 1, 5).Value = One_File_List
Else
Workbooks(One_File_List).Close savechanges = "No"
End If
One_File_List = Dir$
Loop
Next folder_count
If Sheets("Control Sheet").Cells(2, 5).Value = "" Then
Call grab_data
Else
MsgBox "Please check control sheet for corrupt file names.", vbCritical, "Corrupt Files Notification"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This may not be one of the cleanest codes around, but it gets the job done. For those who have been troubled by this problem this is one of the ways to get around this problem. For those who havae a better way of doing this please respond with your codes.
这可能不是最干净的代码，但它能完成任务。对于那些被这个问题困扰的人来说，这是解决这个问题的方法之一。对于那些有更好的方法的人，请用你的代码回应。
Thanks to all for helping me out!!!!
感谢大家的帮助!!!
#1
3
First off, make sure you have
首先，确保你有。
Option Explicit
at the top of your code so you can make sure you don't mess any of your variables up. This way, everything is dimensioned at the beginning of your procedure. Also, use variables for your workbooks, it'll clean up the code and make it more understandable, also, use indenting.
在你的代码的顶部，这样你就可以确保你不会把你的变量弄乱。这样，在你的程序开始的时候，所有的东西都被标注了尺寸。另外，使用变量为您的工作簿，它将清理代码并使它更容易理解，同样，使用缩进。
This worked for me, I found that I need to make sure the file isn't already open (assuming you aren't using an add-in) so you don't want to open the workbook with the code in it when it is already open):
这对我来说很有效，我发现我需要确保文件不是已经打开的(假设你没有使用外接程序)，所以当它已经打开时，你不想打开工作簿，里面有代码。
Sub grab_data()
Dim wb As Workbook, wbMacro As Workbook
Dim filecnt As Integer, file_count As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wbMacro = ThisWorkbook
With Application.FileSearch
.LookIn = wbMacro.Path
.FileType = msoFileTypeExcelWorkbooks
.Execute
filecnt = .FoundFiles.Count
'Loop to count the number of sheets in each file
For file_count = 1 To filecnt
If wbMacro.FullName <> .FoundFiles(file_count) Then
Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
Debug.Print wb.Name
wb.Close True
End If
Next file_count
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Hope that helps.
希望有帮助。
Try this (hope I didn't mess any of it up), basically, I'm checking to make sure the directory exists also, and I cleaned up the code quite a bit to make it more understandable (mainly for myself):
试试这个(希望我没有把它弄乱)，基本上，我正在检查，以确保目录也存在，并且我清理了一些代码，使它更容易理解(主要是为了我自己):
Sub grab_data()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim lRow As Long, lRowEnd As Long, lFolder As Long, lFilesTotal As Long, lFile As Long
Dim lUID As Long
Dim rng As Range
Dim sWkbPath As String
Dim wkb As Workbook, wkbTarget As Workbook
Dim wksConsolidated As Worksheet, wks As Worksheet
Dim v1 As Variant
Set wkb = ThisWorkbook
Set wksConsolidated = wkb.Sheets("Consolidated Data")
'Loop to find the number of excel files in the path in each row of the Control Sheet
For lFolder = 2 To wksConsolidated.Cells(65536, 1).End(xlUp).Row
sWkbPath = wksConsolidated.Cells(lFolder, 1).Value
'Check if file exists
If Not Dir(sWkbPath, vbDirectory) = vbNullString Then
With Application.FileSearch
.LookIn = sWkbPath
.FileType = msoFileTypeExcelWorkbooks
.Execute
lFilesTotal = .FoundFiles.Count
'Loop to count the number of sheets in each file
For lFile = 1 To lFilesTotal
If .FoundFiles(lFile) <> wkb.FullName Then
Set wkbTarget = Workbooks.Open(Filename:=.FoundFiles(lFile))
For Each wks In wkbTarget.Worksheets
If wks.Name <> "Rejected" Then
wks.Columns("a:at").EntireColumn.Hidden = False
lRowEnd = Application.Max(ActiveSheet.Cells(65536, 11).End(xlUp).Row, 2)
v1 = Application.Transpose(wks.Range(Cells(2, 39), Cells(lRowEnd, 39)))
For i = 1 To UBound(v1)
If Len(v1(i)) = 0 Then
lRow = i + 1
Exit For
End If
Next i
v1 = Application.Transpose(wks.Range(Cells(lRow, 40), Cells(lRowEnd, 40)))
For lUID = 1 To UBound(v1)
v1(lUID) = wks.Name & lUID
Next lUID
Application.Transpose(wks.Range(Cells(lRow, 40), Cells(lRowEnd, 40))) = v1
wks.Range("a" & lRow & ":at" & lRowEnd).Copy
i = wksConsolidated.Cells(65536, 11).End(xlUp).Row
With wksConsolidated
.Range("A" & i).PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("z" & i + 1).Value = wks.Name
.Range("z" & i + 1 & ":z" & i + lRowEnd).FillDown
.Range("ap" & i + 1) = sWkbPath
.Range("ap" & i + 1 & ":ap" & i + lRowEnd).FillDown
.Range("ao" & i + 1) = wkbTarget.FullName
.Range("ao" & i + 1 & ":ao" & (i + lRowEnd)).FillDown
End With
With wks
.Range("am" & lRow & ":am" & lRowEnd) = "Picked"
.Columns("b:c").EntireColumn.Hidden = True
.Columns("f:f").EntireColumn.Hidden = True
.Columns("h:i").EntireColumn.Hidden = True
.Columns("v:z").EntireColumn.Hidden = True
.Columns("aa:ac").EntireColumn.Hidden = True
.Columns("ae:ak").EntireColumn.Hidden = True
End With
End If
Next wks
wkbTarget.Close True
End If
Next lFile
End With
End If
Next lFolder
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
#2
1
There may be two issues here
这里可能有两个问题。
The macro runs perfectly on my system but not on the users systems
宏在我的系统上运行良好，但在用户系统上没有。
I presume you are running this in xl2003 as Application.FileSearch was deprecated in xl2007. So you are probably best advised to use a Dir approach instead to ensure your code works on all machines. Are you users all using xl2003?
我假定您在xl2003中运行这个应用程序。在xl2007中，FileSearch被弃用。因此，最好建议使用Dir方法，而不是确保代码在所有机器上都有效。您的用户都使用xl2003吗?
You will get a "Object doesn't support this action" error in xl2007/10
在xl2007/10中，您将得到一个“对象不支持此操作”的错误。
The error i am receiving during the looping process is "Runtime Error '9' Subscript out of range
我在循环过程中接收到的错误是“运行时错误”9'下标超出范围。
Is this error occuring on your machine, or on one/all of the user machines?
这个错误发生在你的机器上，还是在一个/所有的用户机器上?
#3
1
Ok guys,
好了伙计们,
I have finally been able to figure out the problem.
我终于能够解决这个问题了。
This error is occuring because some of the files in the raw data folder are corrupted and get locked automatically. So when the macro on opening the file gets an error and stops there.
这个错误是发生的，因为原始数据文件夹中的一些文件被损坏，并且被自动锁定。当打开文件的宏出现错误并停止时。
I have now made a change to the macro. It would now first check if the files are all ok to be imported. If there is a corrupt file then it would list down their names and the user will be required to manually open it and then do a "save As" and save a new version of the corrupt file and then delete it.
现在我已经对宏进行了更改。现在它首先检查文件是否都可以导入。如果有一个损坏的文件，它会列出他们的名字，用户将被要求手动打开它，然后做一个“保存为”并保存一个新版本的腐败文件，然后删除它。
Once this is done then the macro does the import of the data.
一旦完成，宏就会导入数据。
I am putting down the code below for testing the corrupt files.
我正在放下下面的代码来测试这些损坏的文件。
Sub error_tracking()
Dim srow As Long
Dim rawfilepth As Integer
Dim folder_count As Integer
Dim lrow As Long
Dim wkbpth As String
Dim alrow As Long
Dim One_File_List As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Control Sheet").Activate
rawfilepth = Sheets("Control Sheet").Cells(65536, 1).End(xlUp).Row
Sheets("Control Sheet").Range("E2:E100").Clear
'Loop to find the number of excel files in the path
'in each row of the Control Sheet
For folder_count = 2 To rawfilepth
wkbpth = Sheets("Control Sheet").Cells(folder_count, 1).Value
One_File_List = Dir$(wkbpth & "\*.xls")
Do While One_File_List <> ""
On Error GoTo err_trap
Workbooks.Open wkbpth & "\" & One_File_List
err_trap:
If err.Number = "1004" Then
lrow = Sheets("Control Sheet").Cells(65536, 5).End(xlUp).Row
Sheets("Control Sheet").Cells(lrow + 1, 5).Value = One_File_List
Else
Workbooks(One_File_List).Close savechanges = "No"
End If
One_File_List = Dir$
Loop
Next folder_count
If Sheets("Control Sheet").Cells(2, 5).Value = "" Then
Call grab_data
Else
MsgBox "Please check control sheet for corrupt file names.", vbCritical, "Corrupt Files Notification"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This may not be one of the cleanest codes around, but it gets the job done. For those who have been troubled by this problem this is one of the ways to get around this problem. For those who havae a better way of doing this please respond with your codes.
这可能不是最干净的代码，但它能完成任务。对于那些被这个问题困扰的人来说，这是解决这个问题的方法之一。对于那些有更好的方法的人，请用你的代码回应。
Thanks to all for helping me out!!!!
感谢大家的帮助!!!