嗨，我是相对较新的VBA和编程，我有一个"溢出";我的代码
的问题我正在试着浏览前31份工作表，搜索术语"打开电源";在C列中，当它找到匹配时，复制整行并将其粘贴到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
当您声明的特定数据类型的数据变量不能再保存您放入其中的值的SIZE时，会发生'Overflow'错误。根据您的代码，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
' 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
' consolidation ' Data
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
使用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
好，试试下面的代码做了许多修复和speedUps
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