Excel VBA宏可將工作簿工作表中的特定行復制到新的摘要工作表中…幾乎可以工作

Question

我需要能夠查看工作簿的每個工作表中指定范圍的單元格，如果它們滿足條件，則將該行復制到摘要表中。 下面的代碼在大多數情況下都有效，除了在少數情況下復制不符合條件的行和在某些情況下跳過應復制的行。

有沒有一種使用調試工具的方法，以便在循環瀏覽代碼的任何時間都可以看到：什么是活動工作表？ 什么是活動細胞？ 什么是活動行？ 等等

另外，我是否應該使用-For范圍內的每個單元格而不是-While Len-來遍歷每張紙上的指定范圍？

Sub LoopThroughSheets()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim ws As Worksheet

'Start copying data to row 2 in HH (row counter variable)
LCopyToRow = 2

For Each ws In ActiveWorkbook.Worksheets

'Start search in row 7
LSearchRow = 7

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

'If value in column M > 0.8, copy entire row to HH
If ws.Range("M" & CStr(LSearchRow)).Value > 0.8 Then

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

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

    'Move counter to next row
    LCopyToRow = LCopyToRow + 1

    'Go back to active ws to continue searching
    ws.Activate

End If

LSearchRow = LSearchRow + 1

Wend


Next ws
'Position on cell A1 in sheet HH
Sheets("HH").Select

Application.CutCopyMode = False
Range("A1").Select
MsgBox "All matching data has been copied."

End Sub

Answer 1

關於調試的第一個問題，可以使用：

Debug.Print "Worksheet: " & ActiveSheet.Name

您可以隨時在代碼中將您所在的工作表打印到Visual Basic編輯器的“立即”窗口中。 這對於在所有情況下進行調試都非常有用。

其次，For Each循環是循環遍歷任何事物的最快方法，但它也有缺點。 也就是說，如果您要刪除/插入任何內容，它將返回有趣的結果（可以復制/粘貼）。 如果您對要處理多少行沒有預先確定的想法，則最好使用任何一種While循環。

就您的代碼而言，這就是我的方法（您仍然需要在while循環的上方和下方包含您的代碼）：

Dim Items As Range
Dim Item As Range

'This will set the code to loop from M7 to the last row, if you
'didn't want to go to the end there is probably a better way to do it.

Set Items = ws.Range("M7:M26")

For Each Item In Items

'If value in column M > 0.8, copy entire row to HH
If Item.Value > 0.8 Then

    'Select row in active Sheet to copy
    Item.EntireRow.Copy

    'Paste row into HH in next row
    Sheets("HH").Rows(LCopyToRow & ":" & LCopyToRow).PasteSpecial

    'Move counter to next row
    LCopyToRow = LCopyToRow + 1

End If

Next Item

Answer 2

與前面的答案非常相似，只是措辭有所不同，盡管結果相同。

Sub Button1_Click()
    Dim Rws As Long, Rng As Range, ws As Worksheet, sh As Worksheet, c As Range, x As Integer
    Set ws = Worksheets("HH")
    x = 2
    Application.ScreenUpdating = 0
    For Each sh In Sheets
        If sh.Name <> ws.Name Then
            With sh
                Rws = .Cells(Rows.Count, "M").End(xlUp).Row
                Set Rng = .Range(.Cells(7, "M"), .Cells(Rws, "M"))
                For Each c In Rng.Cells
                    If c.Value > 0.8 Then
                        c.EntireRow.Copy Destination:=ws.Cells(x, "A")
                        x = x + 1
                    End If
                Next c
            End With
        End If
    Next sh
End Sub