在大量工作表中搜索数据，如果在 VBA 中找到数据，则将整行复制到单独的工作表中

Question

您好，我对 VBA 和编程比较陌生，我的代码存在“溢出”问题

我正在尝试浏览前 31 个工作表，在 C 列中搜索术语“Power On”，当它找到匹配项时，复制整行并将其粘贴到 Sheet33 中，它只在某个时间点工作一张纸，但现在我在修改前 31 张纸后无法让它工作

任何帮助将不胜感激！

   Sub test()

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer
   Dim ws1 As Worksheet
   Dim I As Integer
   
   LCopyToRow = 1

         
    For I = 1 To 31
       Set ws1 = ActiveSheet
   
   LSearchRow = 1


   While Len(Range("A" & CStr(LSearchRow)).Value) > 0

      'If value in column C = "Power On", copy entire row to Sheet33
      If Range("C" & CStr(LSearchRow)).Value = "Power On" Then

         'Select row in ws1 to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy

         'Paste row into Sheet33 in next row
         Sheets("Sheet33").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste

         LCopyToRow = LCopyToRow + 1

         'Go back to ws1
         Sheets(ws1).Select

      End If

      LSearchRow = LSearchRow + 1
      
   Wend

   Exit Sub
    
    Next I

End Sub

Answer 1

当您声明的某种数据类型的数据变量不能再容纳您放入其中的值的 SIZE 时，就会发生“溢出”错误。 根据您的代码，LSearchRow 和 LCopyToRow 被声明为 INTEGER，最多可容纳 32767（行）。要解决此问题，请将其声明为 LONG 而不是 INTEGER：

Dim LSearchRow As Long
Dim LCopyToRow As Long

这是我的答案的更新。我制作了您的代码的替代版本：

Sub GetPowerOn()
    Dim ws          As Worksheet
    Dim wsResult    As Worksheet
    Dim nrow        As Long
    Dim actvCell    As Range
    Dim actvLrow    As Long
    
    Set wsResult = ThisWorkbook.Worksheets("Sheet33")
    
    Application.ScreenUpdating = False
    
    For Each ws In ThisWorkbook.Worksheets '~Loop through the sheets of the workbook
        If Not ws.Name = "Sheet33" Then '~As long as the sheet is not Sheet33, fire the search,copy,paste function below
            actvLrow = ws.Range("A" & Rows.Count).End(xlUp).Row '~ Set the lastrow of the active sheet
            For Each actvCell In ws.Range("C1:C" & actvLrow) '~ Loop through the cells of column C
                If actvCell.Value = "Power On" Then '~Look for criteria
                    ws.Rows(actvCell.Row & ":" & actvCell.Row).Copy '~Copy the row that matches the criteria
                    nrow = wsResult.Range("A" & Rows.Count).End(xlUp).Offset(1).Row '~Get the lastrow empty row of the output sheet
                    wsResult.Range("A" & nrow).PasteSpecial xlPasteValuesAndNumberFormats '~Paste to the next empty row
                    Application.CutCopyMode = False
                End If
            Next actvCell
        End If
    Next ws
    
    Application.ScreenUpdating = True

End Sub

Answer 2

' The reason you are getting the same sheet is you are setting WS1 to ActiveSheet
' 31 times in a row -- not getting the first 31 sheets.
' ActiveSheet is whatever sheet you last happened to have in focus.  Unless you
' know you want that (almost never), you should not use it.

' You want to avoids things like copy / paste / select.  These are slow.

' You also want to avoid processing things row by row.

' Here is an example that should do what you want.

Sub ThirtyOneFlavors()
Const PowerColNum = 3  ' if you are sure it will always be column 3
Dim WS1 As Worksheet, WS33 As Worksheet
Dim PowerColumn As Range, PowerCell As Range, FirstCell As Range, R As Long
  
    Set WS33 = ThisWorkbook.Sheets("Sheet33")  ' Maybe this could use a clever name
    WS33.Cells.Delete  ' only if you want this
  
    ' using ThisWorkbook avoids accidentally getting some other open workbook
    For Each WS1 In ThisWorkbook.Sheets
        ' here, put the names of any sheets you don't want to process
        If WS1.Name <> WS33.Name Then
            Set PowerColumn = WS1.UsedRange.Columns(PowerColNum)
            ' I am assuming Power On is the whole column
            Set PowerCell = PowerColumn.Find("Power On", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
            If Not PowerCell Is Nothing Then   ' if you found something
                ' we need to keep track of the first one found,
                ' otherwise Excel will keep finding the same one repeatedly
                Set FirstCell = PowerCell
            End If
            
            While Not PowerCell Is Nothing   ' if you keep finding cells
                R = R + 1  ' next row
                '.Value will hold all of the values in a range (no need to paste)
                WS33.Cells(R, 1).EntireRow.Value = PowerCell.EntireRow.Value
                ' get the next one
                Set PowerCell = PowerColumn.Find("Power On", after:=PowerCell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
                If PowerCell.Address = FirstCell.Address Then
                    ' if we found the first one again, kill the loop
                    Set PowerCell = Nothing
                End If
            Wend
        End If
    Next WS1

End Sub

Answer 3

“整合”数据

Option Explicit

Sub ConsolidateData()
    
    ' Source
    Const sfIndex As Long = 1
    Const slIndex As Long = 31
    Const sFirstCell As String = "C2"
    Const sCriteria As String = "Power On"
    ' Destination
    Const dIndex As Long = 33
    Const dFirstCell As String = "A2" ' has to be column 'A' ('EntireRow')
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Create a reference to the initial destination cell.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dIndex)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirstCell)
    Dim dCell As Range: Set dCell = RefLastCellInColumn(dfCell)
    If dCell Is Nothing Then ' no data found
        Set dCell = dfCell
    Else ' data found
        Set dCell = dCell.Offset(1)
    End If
    
    Dim sws As Worksheet
    Dim srg As Range
    Dim scrg As Range
    Dim sCell As Range
    Dim n As Long
    
    Application.ScreenUpdating = False
    
    ' Process each source worksheet...
    For n = sfIndex To slIndex
        Set sws = wb.Worksheets(n)
        Set scrg = RefColumn(sws.Range(sFirstCell))
        ' Test for data...
        If Not scrg Is Nothing Then ' data in column found
            ' Process each cell in source column range...
            For Each sCell In scrg.Cells
                ' Check current cell agains criteria. To ignore case,
                ' i.e. 'POWER ON = power on', 'vbTextCompare' is used.
                If StrComp(CStr(sCell.Value), sCriteria, vbTextCompare) = 0 Then
                    ' Combine current cell into current source range.
                    ' The combining is restricted to per worksheet ('Union').
                    Set srg = RefCombinedRange(srg, sCell)
                End If
            Next sCell
            ' Test for matches...
            If Not srg Is Nothing Then ' match found
               ' Copy. This will work only if all source cells contain values.
               ' If some of them contain formulas, the results may be mixed
               ' (some rows containing the formulas, some only values) due to
               ' the source range being non-contiguous.
               ' This is prevented by either not combining the cells or
               ' by using 'PasteSpecial'.
               srg.EntireRow.Copy dCell
               ' Create a reference to the next destination cell.
               Set dCell = dCell.Offset(srg.Cells.Count)
               ' Unreference source range (before processing next worksheet).
               Set srg = Nothing
            'Else ' no match found
            End If
        'Else ' no data in column found
        End If
    Next n
 
    ' Activate destination worksheet.
    'If Not dws Is ActiveSheet Then dws.Activate
    ' Save workbook.
    'wb.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Data consolidated.", vbInformation, "Consolidate Data"

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the bottom-most non-empty cell
'               in the one-column range from the first cell ('FirstCell')
'               through the bottom-most cell of the worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefLastCellInColumn( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set RefLastCellInColumn = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
    End With

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('FirstCell') to the bottom-most non-empty cell
'               of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
    ByVal CombinedRange As Range, _
    ByVal AddRange As Range) _
As Range
    If CombinedRange Is Nothing Then
        Set RefCombinedRange = AddRange
    Else
        Set RefCombinedRange = Union(CombinedRange, AddRange)
    End If
End Function

Answer 4

使用Find 和`FindNext' 的替代方法

Option Explicit

Sub test()

    Const MAX_SHT = 3
    Const PASTE_SHT = 4
    Const TERM = "Power On"
    Const COL = "C"

    Dim wb As Workbook, ws As Worksheet
    Dim n As Integer, LastRow As Long, count As Long
    Dim rngFound As Range, rngTarget As Range, sFirst As String
    Set wb = ThisWorkbook

    ' check number of sheets
    If wb.Sheets.count < MAX_SHT Then
        MsgBox "Too few sheets", vbCritical
        Exit Sub
    End If

    ' copy destination
    With wb.Sheets(PASTE_SHT)
        LastRow = .Cells(Rows.count, COL).End(xlUp).Row
        Set rngTarget = .Cells(LastRow + 1, "A")
    End With

    ' first 31 sheets
    For n = 1 To MAX_SHT
        Set ws = wb.Sheets(n)
        LastRow = ws.Cells(Rows.count, COL).End(xlUp).Row
        With ws.Range("C1:C" & LastRow)
            ' search for term
            Set rngFound = .Find(TERM, lookin:=xlValues, LookAt:=xlWhole)
            If Not rngFound Is Nothing Then
                sFirst = rngFound.Address
                Do
                    ws.Rows(rngFound.Row).EntireRow.Copy rngTarget
                    Set rngTarget = rngTarget.Offset(1)
                    Set rngFound = .FindNext(rngFound)
                    count = count + 1
                Loop While rngFound.Address <> sFirst
            End If

        End With
    Next
    MsgBox count & " rows copied", vbInformation
End Sub

Answer 5

好的，试试下面的代码 进行了许多修复并加快了速度

Sub test()
       ' in a x64 environement better forget Integers and go for Longs
       Dim LSearchRow As Long
       Dim LCopyToRow As Long
       Dim ws1 As Worksheet
       Dim I As Long
       Dim vldRng As Range
       Dim maxRw As Long
       Dim maxClmn As Long
       Dim rngDest As Range
       
       '2 Lines to speed code Immensly. Don't use them while debugging
       Application.ScreenUpdating = False
       Application.Calculation = xlCalculationManual
    
       LCopyToRow = 1
       Set rngDest = ThisWorkbook.Sheets("Sheet33").Cells(1, 1)
       'Set rngDest = ThisWorkbook.Sheets(33).Range("A1")  'Alternative 01
       'Set rngDest = Sheets(33).Range("A1")               'Alternative 02
    
        For I = 1 To 31
           Set ws1 = ThisWorkbook.Sheets(I)
           Set vldRng = ws1.UsedRange       ' Get range used instead of searching entire Sheet
           
           maxRw = vldRng.Rows.Count
           maxClmn = vldRng.Columns.Count
        
           For LSearchRow = 1 To maxRw
        
              'If value in column C = "Power On", copy entire row to Sheet33
              If vldRng.Cells(LSearchRow, 3).Value = "Power On" Then
        
                 'Select row in ws1 to copy
                 vldRng.Cells(LSearchRow, 1).Resize(1, maxClmn).Copy
        
                 'Paste row into Sheet33 in next row
                 rngDest.Offset(LCopyToRow - 1, 0).PasteSpecial xlPasteValues
                 LCopyToRow = LCopyToRow + 1
        
              End If
        
           Next LSearchRow
    
        Next I
    
       Application.ScreenUpdating = True
       Application.Calculation = xlCalculationAutomatic
    
    End Sub