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

时间：2015-03-26 00:24:46

标签： excel vba excel-vba

因此，在我最后尝试完成我的代码时，我正在使用此

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时提取的事实。之后，在工作簿中创建其他工作表，但不再提取数据，并将四个新工作表留空。它可能与此有关，但我不确定：

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

我没想到让这项工作:(

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

1 个答案:

答案 0 :(得分：2)

的变化：

  1. 假设您要复制每个新打开的工作簿中每个工作表的值：For Each shSrc In ActiveWorkbook.Worksheets 'changed ThisWorkbook to ActiveWorkbook
  2. 添加了Application设置行（用于加速）
  3. 添加条件以检查列＆＃34; B＆＃34;为空If Not .Columns(2).Find(...) Is Nothing Then

    4. 代码：

    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. 我认为你的代码编写得很好。没有多余或不必要的东西。如果这是你的第一个宏之一，那么做得好，先生！
      我唯一想到的是使用Union合并复制的单元格，但我不认为可以应用，因为您在粘贴时将它们重新排列。
    2. 以下是有关您获得的错误的更多信息Object variable or With block variable not set (Error 91)

      3. 修改

      在For i = 1 To 5下方更改了3行，将ActiveWorkbook更改为ThisWorkbook（这与不的情况相同，与之前相同，在第1点）。我假设您有一些主工作簿，其中包含此宏，并且您希望将数据复制到此主工作簿。

      为了确保您在Workbooks.Open ("Users:uknowwho:Desktop:ProjetVBA:" & WbName(i) & ".xlsx")行中使用\作为文件夹分隔符？

      编辑2

      我们将摆脱 Active 书籍和表格，并尝试更具体的方法。

      1. 尝试添加新变量Dim newWB As Workbook
      2. 更改将“目标”工作表设置为Set shDest = ThisWorkbook.Sheets(WbName(i))
        3. 的行
      3. 将打开工作簿的行更改为Set newWB = Workbooks.Open("Users:uknowwho:Desktop:ProjetVBA:" & WbName(i) & ".xlsx")
      4. 将表格循环的行更改为For Each shSrc In newWB.Worksheets
      5. 将关闭新工作簿的行更改为newWB.Close

        6. 如果文件正确打开并且新工作表空白，则列中没有数据＆＃34; B＆＃34;在源表中。我认为没有其他可能性。检查课程表。

相关问题
最新问题