嗨，我對 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
uj5u.com熱心網友回復：
當您宣告的某種資料型別的資料變數無法再容納您放入其中的值的 SIZE 時，就會發生“溢位”錯誤。根據您的代碼，LSearchRow 和 LCopyToRow 被宣告為 INTEGER，最多可容納 32767（行）。要解決此問題，請將其宣告為 LONG 而不是 INTEGER：
Dim LSearchRow As Long Dim LCopyToRow As Long
現在要使您的作業表回圈作業，請插入以下代碼：
Dim wsCount as Long wsCount = Thisworkbook.Worksheets.Count
然后將您的回圈修改為此。這將自動掃描該作業簿中的所有作業表
For I = 1 To wsCount 'leave as is Next I
您當前的 LOOP 不執行任何操作，它只計算 1 到 31，并且與“ws1”無關，這就是它僅適用于 1 張紙的原因。
uj5u.com熱心網友回復：
好的，請嘗試以下代碼進行許多修復和加速
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)
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
uj5u.com熱心網友回復：
' 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
uj5u.com熱心網友回復：
“整合”資料
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
uj5u.com熱心網友回復：
使用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
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/319076.html