VBA错误91 – 从多个工作簿/工作表中提取数据

所以，在我最后的尝试完成我的代码，我正在与此

Sub MACRO2BATAR() Dim lngFirstRow As Long, lngLastRow As Long, cRow As Long, lngNextDestRow As Long, i As Integer Dim shSrc As Worksheet, shDest As Worksheet Dim Wb As Workbook Dim WbName(1 To 5) As String Dim intAppCalc As Integer 'added variable to store original calculation setting Application.ScreenUpdating = False Application.EnableEvents = False intAppCalc = Application.Calculation 'store original calculation setting Application.Calculation = xlCalculationManual WbName(1) = "CARREFOUR" WbName(2) = "EDF" WbName(3) = "SOCGEN" WbName(4) = "TOTAL" WbName(5) = "SANOFI" For i = 1 To 5 lngNextDestRow = 2 'changed the workbook references ThisWorkbook.Worksheets.Add ThisWorkbook.ActiveSheet.Name = WbName(i) Set shDest = ThisWorkbook.ActiveSheet '''Feuille de destination (sheetDestination) Workbooks.Open ("Users:uknowwho:Desktop:ProjetVBA:" & WbName(i) & ".xlsx") For Each shSrc In ActiveWorkbook.Worksheets 'changed ThisWorkbook to ActiveWorkbook With shSrc 'added condition to check if there is data in column "B" If Not .Columns(2).Find(What:="*", LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False) Is Nothing Then lngFirstRow = 2 lngLastRow = .Columns(2).Find(What:="*", LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row For cRow = lngFirstRow To lngLastRow If .Cells(cRow, 2) <> .Cells(cRow - 1, 2) Then .Range("B" & cRow).Copy Destination:=shDest.Range("A" & lngNextDestRow) .Range("D" & cRow).Copy Destination:=shDest.Range("B" & lngNextDestRow) .Range("D" & cRow + 1).Copy Destination:=shDest.Range("C" & lngNextDestRow) .Range("E" & cRow).Copy Destination:=shDest.Range("D" & lngNextDestRow) .Range("E" & cRow + 1).Copy Destination:=shDest.Range("E" & lngNextDestRow) .Range("F" & cRow).Copy Destination:=shDest.Range("F" & lngNextDestRow) .Range("F" & cRow + 1).Copy Destination:=shDest.Range("G" & lngNextDestRow) lngNextDestRow = lngNextDestRow + 1 End If Next cRow End If End With Next shSrc Workbooks(WbName(i) & ".xlsx").Close Next i Application.Calculation = intAppCalc 'restore original calculation setting Application.EnableEvents = False Application.ScreenUpdating = False End Sub 

但即时通讯运行时错误91，并突出显示的IngLastRow = .Columns(2) …行。 我不明白，因为它以前工作时，我只在一个工作簿。

编辑：我更新了我运行的代码的最后一个版本。 感谢@BranislavKollár问题不再是错误，但事实是数据只在i = 1时被提取。 之后，在工作簿中创build其他工作表，但不再提取数据，并将四个新工作表留空。 这可能与此有关，但我不知道：

 Set shDest = ThisWorkbook.ActiveSheet '''Feuille de destination (sheetDestination) 

我没有想法使这个工作:(

最后编辑：所以我所需要做的就是移动lngNextDestRow = 2刚开始之后对于每个i = 1到5循环。 它一直在工作，但由于lngNextDestRow平均每个工作簿增加了391个数据，所以数据被压低了。 非常感谢Branislav;）

Answer 1

变化：

1. 假定您想从每个新打开的工作簿中的每个工作表复制值： For Each shSrc In ActiveWorkbook.Worksheets 'changed ThisWorkbook to ActiveWorkbook
2. 增加Application设置行（加速）
3. 添加条件来检查列“B”是否为空If Not .Columns(2).Find(...) Is Nothing Then

---

码：

 Sub MACRO1BATAR() Dim lngFirstRow As Long, lngLastRow As Long, cRow As Long, lngNextDestRow As Long, i As Integer Dim shSrc As Worksheet, shDest As Worksheet Dim Wb As Workbook Dim WbName(1 To 5) As String Dim intAppCalc As Integer 'added variable to store original calculation setting Application.ScreenUpdating = False Application.EnableEvents = False intAppCalc = Application.Calculation 'store original calculation setting Application.Calculation = xlCalculationManual WbName(1) = "CARREFOUR" WbName(2) = "EDF" WbName(3) = "SOCGEN" WbName(4) = "TOTAL" WbName(5) = "SANOFI" For i = 1 To 5 lngNextDestRow = 2 'this line needs to be inside the main loop (argh!) 'changed the workbook references ThisWorkbook.Worksheets.Add ThisWorkbook.ActiveSheet.Name = WbName(i) Set shDest = ThisWorkbook.ActiveSheet '''Feuille de destination (sheetDestination) Workbooks.Open ("Users:uknowwho:Desktop:ProjetVBA:" & WbName(i) & ".xlsx") For Each shSrc In ActiveWorkbook.Worksheets 'changed ThisWorkbook to ActiveWorkbook With shSrc 'added condition to check if there is data in column "B" If Not .Columns(2).Find(What:="*", LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False) Is Nothing Then lngFirstRow = 2 lngLastRow = .Columns(2).Find(What:="*", LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row For cRow = lngFirstRow To lngLastRow If .Cells(cRow, 2) <> .Cells(cRow - 1, 2) Then .Range("B" & cRow).Copy Destination:=shDest.Range("A" & lngNextDestRow) .Range("D" & cRow).Copy Destination:=shDest.Range("B" & lngNextDestRow) .Range("D" & cRow + 1).Copy Destination:=shDest.Range("C" & lngNextDestRow) .Range("E" & cRow).Copy Destination:=shDest.Range("D" & lngNextDestRow) .Range("E" & cRow + 1).Copy Destination:=shDest.Range("E" & lngNextDestRow) .Range("F" & cRow).Copy Destination:=shDest.Range("F" & lngNextDestRow) .Range("F" & cRow + 1).Copy Destination:=shDest.Range("G" & lngNextDestRow) lngNextDestRow = lngNextDestRow + 1 End If Next cRow End If End With Next shSrc Workbooks(WbName(i) & ".xlsx").Close Next i Application.Calculation = intAppCalc 'restore original calculation setting Application.EnableEvents = False Application.ScreenUpdating = False End Sub 

---

笔记：

1. 你的代码写得很好，我想。 没有什么多余的或不必要的。 如果这是您的第一个macros， 那么做得好，先生！
   我唯一想到的是使用Union合并复制的单元格，但是我不认为这可以应用，因为在粘贴时重新排列它们。
2. 这里有一些关于你得到的错误的更多信息Object variable或With block variable not set（Error 91）

编辑

在For i = 1 To 5下方更改了3行，将ActiveWorkbook更改为ThisWorkbook （与之前的情况不同，在第1点）。 我假设你有一些主工作簿，在这个macros中，以及这个主工作簿，你要复制数据。

---

可以肯定的是，在Workbooks.Open ("Users:uknowwho:Desktop:ProjetVBA:" & WbName(i) & ".xlsx")应该使用\作为文件夹分隔符？

---

编辑2

我们将摆脱积极的书籍和床单，并尝试更具体的方法。

1. 尝试添加一个新的variablesDim newWB As Workbook
2. 更改行，您将目标工作表Set shDest = ThisWorkbook.Sheets(WbName(i))为Set shDest = ThisWorkbook.Sheets(WbName(i))
3. 将打开工作簿的行更改为Set newWB = Workbooks.Open("Users:uknowwho:Desktop:ProjetVBA:" & WbName(i) & ".xlsx")
4. 将表单循环的行更改为For Each shSrc In newWB.Worksheets
5. 将closures新工作簿的行更改为newWB.Close

---

如果文件正确打开并且新纸张空白，则源表单中的“B”列中没有数据。 我没有看到其他的可能性。 检查Sourse表单。