我有一个excel工作簿，它有一个在excel 2010和excel 2016中运行良好的宏。宏的目的是查看选定的文件夹以查找已关闭的工作簿，逐个打开每个工作簿并从每个工作簿中复制信息。其中一个工作簿并将其粘贴到单个工作簿中。这在excel 2010和excel 213上都运行良好，但它在excel 2016中不再有效。它出现了一个错误，说我的工作表受到保护，以前从未出现问题，并且在我关闭保护后它开始工作但它似乎没有把数据放在正确的区域，只是停止。我在这里缺少某种兼容性问题吗？我认为我的代码是错误的，但它在以前的excel版本中一直对我有用
vba代码如下：
Sub RunAllMacros()
CommandButton1_Click
test
End Sub
Sub CommandButton1_Click()
Dim x, fldr As FileDialog, SelFold As String, i As Long
Dim ws As Worksheet, ws1 As Worksheet
Dim Wb As Workbook, Filename As String
screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
eventsState = Application.EnableEvents
'turn off some Excel functionality for faster performance
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
'User Selects desired Folder
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
If .Show <> -1 Then GoTo Cleanup
SelFold = .SelectedItems(1)
End With
'All .xls* files in Selected FolderPath including Sub folders are put into an array
x = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & SelFold & "\*.xls"" /s/b").stdout.readall, vbCrLf)
Set ws1 = ThisWorkbook.Sheets("Labour & Material")
Set ws2 = ThisWorkbook.Sheets("Total Hours For All Units")
'Loop through that array
For i = LBound(x) To UBound(x) - 1
'Open (in background) the Workbook
With GetObject(x(i))
ThisWorkbook.Sheets(1).UsedRange
Filename = Split(x(i), "\")(UBound(Split(x(i), "\")))
Set Wb = Workbooks(Filename)
Set ws = Nothing
On Error Resume Next
'change sheet name here
Set ws = Wb.Sheets("Total Quantities")
On Error GoTo 0
If Not ws Is Nothing Then
If lngrow = 0 Then
lngrow = 5
Else
lngrow = lngrow + 1
End If
ws1.Cells(lngrow, "A").Value = ws.Range("A1").Value
ws1.Cells(lngrow, "B").Value = ws.Range("I2").Value
ws1.Cells(lngrow, "C").Value = ws.Range("C2").Value
ws1.Cells(lngrow, "E").Value = ws.Range("C3").Value
ws1.Cells(lngrow, "G").Value = ws.Range("C4").Value
ws2.Cells(lngrow, "B").Value = ws.Range("B8").Value
ws2.Cells(lngrow, "C").Value = ws.Range("B9").Value
ws2.Cells(lngrow, "D").Value = ws.Range("B10").Value
ws2.Cells(lngrow, "E").Value = ws.Range("B11").Value
ws2.Cells(lngrow, "F").Value = ws.Range("B12").Value
ws2.Cells(lngrow, "G").Value = ws.Range("B13").Value
End If
.Close
End With
Next i
Cleanup:
Set fldr = Nothing
End Sub
Sub test()
SheetNum = Array(1, 2, 5, 6)
For Each Sh In Sheets(SheetNum)
Sh.Select
Set SoRng = Sh.Range("A5", Sh.Range("A5").End(xlToRight).Address)
AdvFil SoRng
Next
Sheets(4).Select
Set SoRng = Sheets(4).Range("A5:A5")
AdvFil SoRng
Sheets(3).Select
ColNo = Array("D", "F", "H")
For Each Col In ColNo
Set SoRng = Sheets(3).Range(Col & "5:" & Col & "5")
AdvFil SoRng
Next
End Sub
Sub AdvFil(ByVal x As Range)
LrNum = Sheets(3).Cells(Rows.Count, "A").End(xlUp).Row
If InStr(1, x.Address, ":") > 0 Then
DesRng = Left(x.Address, Len(x.Address) - 1) & LrNum
Else
DesRng = x.Address & ":" & Left(x.Address, Len(x.Address) - 1) & LrNum
End If
x.AutoFill Destination:=Range(DesRng)
End Sub
对此的任何帮助将不胜感激。如果需要更多信息或者我没有充分解释自己，请告诉我，我会改述我的要求
编辑： 所以我尝试定义了Ashlee提到的一些变量。我已经重新列出了下面的新代码。
我现在有一个我无法弄清楚的错误，编译错误：For Each可能只迭代一个集合对象或一个数组。 当弹出此错误时，它会在下面的代码中突出显示ColNo。我猜这里使用了错误的命令？如果是这种情况，我应该使用什么命令？这里的代码需要循环，所以基本上在第5行D，F和H中我有一个公式，我需要复制下来重复，这取决于总共有多少工作簿，我已经从中提取了所有数据。这对我以前一直很有用，所以我不知道直到2016年才有问题
Option Explicit
Sub RunAllMacros()
CommandButton1_Click
test
End Sub
Sub CommandButton1_Click()
Dim x, fldr As FileDialog, SelFold As String, i As Long
Dim ws As Worksheet, ws1, ws2 As Worksheet
Dim Wb As Workbook, Filename As String
Dim screenUpdateState As String
Dim statusBarState As String
Dim eventsState As String
Dim lngrow As Integer
screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
eventsState = Application.EnableEvents
'turn off some Excel functionality for faster performance
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
'User Selects desired Folder
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
If .Show <> -1 Then GoTo Cleanup
SelFold = .SelectedItems(1)
End With
'All .xls* files in Selected FolderPath including Sub folders are put into an array
x = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & SelFold & "\*.xls"" /s/b").stdout.readall, vbCrLf)
Set ws1 = ThisWorkbook.Sheets("Labour & Material")
Set ws2 = ThisWorkbook.Sheets("Total Hours For All Units")
'Loop through that array
For i = LBound(x) To UBound(x) - 1
'Open (in background) the Workbook
With GetObject(x(i))
ThisWorkbook.Sheets(1).UsedRange
Filename = Split(x(i), "\")(UBound(Split(x(i), "\")))
Set Wb = Workbooks(Filename)
Set ws = Nothing
On Error Resume Next
'change sheet name here
Set ws = Wb.Sheets("Total Quantities")
On Error GoTo 0
If Not ws Is Nothing Then
If lngrow = 0 Then
lngrow = 5
Else
lngrow = lngrow + 1
End If
ws1.Cells(lngrow, "A").Value = ws.Range("A1").Value
ws1.Cells(lngrow, "B").Value = ws.Range("I2").Value
ws1.Cells(lngrow, "C").Value = ws.Range("C2").Value
ws1.Cells(lngrow, "E").Value = ws.Range("C3").Value
ws1.Cells(lngrow, "G").Value = ws.Range("C4").Value
ws2.Cells(lngrow, "B").Value = ws.Range("B8").Value
ws2.Cells(lngrow, "C").Value = ws.Range("B9").Value
ws2.Cells(lngrow, "D").Value = ws.Range("B10").Value
ws2.Cells(lngrow, "E").Value = ws.Range("B11").Value
ws2.Cells(lngrow, "F").Value = ws.Range("B12").Value
ws2.Cells(lngrow, "G").Value = ws.Range("B13").Value
End If
.Close
End With
Next i
Cleanup:
Set fldr = Nothing
End Sub
Sub test()
Dim SheetNum As Integer
Dim Sh As Range
Dim SoRng As Range
Dim ColNo As String
Dim Col As Collection
SheetNum = Array(1, 2, 5, 6)
For Each Sh In Sheets(SheetNum)
Sh.Select
Set SoRng = Sh.Range("A5", Sh.Range("A5").End(xlToRight).Address)
AdvFil SoRng
Next
Sheets(4).Select
Set SoRng = Sheets(4).Range("A5:A5")
AdvFil SoRng
Sheets(3).Select
ColNo = Array("D", "F", "H")
For Each Col In ColNo
Set SoRng = Sheets(3).Range(Col & "5:" & Col & "5")
AdvFil SoRng
Next
End Sub
Sub AdvFil(ByVal x As Range)
LrNum = Sheets(3).Cells(Rows.Count, "A").End(xlUp).Row
If InStr(1, x.Address, ":") > 0 Then
DesRng = Left(x.Address, Len(x.Address) - 1) & LrNum
Else
DesRng = x.Address & ":" & Left(x.Address, Len(x.Address) - 1) & LrNum
End If
x.AutoFill Destination:=Range(DesRng)
End Sub