想要使用循環而不是單獨的代碼，直到最后一行

Question

我試圖找到A列到H列中的唯一名稱，並根據我能夠獲得的H列和A列中的值過濾數據，但是直到它的最后一行我都無法使用H列中的數據。

請幫助我更正代碼，以便它可以運行到H列的最后一行，建議進行適當的修改以定義標准范圍，而我在下面分別為每個單元格進行了修改。 我對Loops不太滿意，但盡管無法糾正並使其正常工作，但仍試圖對其進行修復。 我無法成功地正確定義范圍並使其正常工作。 如果有任何專家可以抽出時間來研究，更正和改進我的代碼，將對您有很大的幫助。

Sub Test()
    Dim ws2 As Worksheet, sheetxxx As Worksheet
    Dim cnt As Long
    Dim rCrit1 As Range, rCrit2 As Range, rCrit3 As Range, rCrit4 As Range, rRng1 As Range, rRng2 As Range
    Dim i As Long, LastRow As Long
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row

    With Application
    .EnableEvents = False
    .ScreenUpdating = False
    End With
    'Instead of defining this range separately, is there a way to run from H2 To Last Row of data in H column
    Set rCrit1 = Range("H2")
    Set rCrit2 = Range("H3")
    Set rCrit3 = Range("H4")
    Set rCrit4 = Range("H5")

    Set rRng1 = Range("A1:C60000")

    With rRng1
    .AutoFilter field:=1, Criteria1:=rCrit1.Value
    cnt = WorksheetFunction.Subtotal(3, .Range("A:A"))

        If cnt >= 2 Then
            Worksheets.Add After:=Worksheets(Worksheets.Count)
                Set sheetxxx = ActiveWorkbook.ActiveSheet
                    sheetxxx.Name = Worksheets("Sheet3").Range("H2").Value 'instead use i for range to check for 2 to lastrow

            .Range(.Range("A1"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 5).Copy
            sheetxxx.Range("A1").PasteSpecial Paste:=xlPasteAll
            With sheetxxx
                .Range(.Range("A1"), .Cells(cnt, 5)).Borders.LineStyle = xlContinuous
                .Range("a1:z1").Font.FontStyle = "Bold Italic"
                .Columns("a:z").AutoFit
                .Range("a1").Select
            End With
        End If
    End With

    Sheets("Sheet3").Activate
    With Sheets("sheet3")

    .AutoFilterMode = False
    End With

    With rRng1
    .AutoFilter field:=1, Criteria1:=rCrit2.Value
    cnt = WorksheetFunction.Subtotal(3, .Range("A:A"))

        If cnt >= 2 Then
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            Set sheetxxx = ActiveWorkbook.ActiveSheet
            sheetxxx.Name = Worksheets("Sheet3").Range("H3").Value
            .Range(.Range("A1"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 5).Copy
            sheetxxx.Range("A1").PasteSpecial Paste:=xlPasteAll
            With sheetxxx
                .Range(.Range("A1"), .Cells(cnt, 5)).Borders.LineStyle = xlContinuous
                .Range("a1:z1").Font.FontStyle = "Bold Italic"
                .Columns("a:z").AutoFit
                .Range("a1").Select
            End With
        End If
     End With

     Sheets("Sheet3").Activate
     With Sheets("sheet3")

     .AutoFilterMode = False
     End With

     With rRng1
     .AutoFilter field:=1, Criteria1:=rCrit3.Value
     cnt = WorksheetFunction.Subtotal(3, .Range("A:A"))

        If cnt >= 2 Then
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            Set sheetxxx = ActiveWorkbook.ActiveSheet
            sheetxxx.Name = Worksheets("Sheet3").Range("H4").Value
            .Range(.Range("A1"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 5).Copy
            sheetxxx.Range("A1").PasteSpecial Paste:=xlPasteAll
            With sheetxxx
                .Range(.Range("A1"), .Cells(cnt, 5)).Borders.LineStyle = xlContinuous
                .Range("a1:z1").Font.FontStyle = "Bold Italic"
                .Columns("a:z").AutoFit
                .Range("a1").Select
            End With
        End If
     End With

     Sheets("Sheet3").Activate
     With Sheets("sheet3")

     .AutoFilterMode = False
     End With

     With rRng1
     .AutoFilter field:=1, Criteria1:=rCrit4.Value
     cnt = WorksheetFunction.Subtotal(3, .Range("A:A"))

        If cnt >= 2 Then
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            Set sheetxxx = ActiveWorkbook.ActiveSheet
            sheetxxx.Name = Worksheets("Sheet3").Range("H5").Value
            .Range(.Range("A1"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 5).Copy
            sheetxxx.Range("A1").PasteSpecial Paste:=xlPasteAll
            With sheetxxx
                .Range(.Range("A1"), .Cells(cnt, 5)).Borders.LineStyle = xlContinuous
                .Range("a1:z1").Font.FontStyle = "Bold Italic"
                .Columns("a:z").AutoFit
                .Range("a1").Select
            End With
        End If
    End With

    Sheets("Sheet3").Activate
    With Sheets("sheet3")

    .AutoFilterMode = False
    End With

    With Application
    .EnableEvents = True
    .ScreenUpdating = True
    End With
End Sub

Answer 1

沒有真實的數據，就不可能對其進行完整的測試，但這應該可以實現您想要的：

Sub Test()
  Dim sheetxxx As Worksheet, rCrit As Range, runner As Variant

  Application.EnableEvents = False
  Application.ScreenUpdating = False

  With Sheets("Sheet3")
    Set rCrit = .Range("H2", .Cells(.Rows.Count, "H").End(xlUp))

    For Each runner In rCrit.Cells

      If Application.CountIf(.Columns(1), runner) Then
        .Range("A:C").AutoFilter 1, runner
        Set sheetxxx = Worksheets.Add(, Sheets(Sheets.Count))
        sheetxxx.Name = runner.Value
        .Range(.Range("A1"), .Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 5).Copy sheetxxx.Range("A1")

        With sheetxxx
          .Range(.Range("A1"), .Cells(Application.Subtotal(3, .Columns(1)), 5)).Borders.LineStyle = xlContinuous
          .Range("A1:Z1").Font.FontStyle = "Bold Italic"
          .Range("A:Z").AutoFit
        End With

        .Activate
        .AutoFilterMode = False

      End If
    Next
  End With

  Application.EnableEvents = True
  Application.ScreenUpdating = True

End Sub

編輯

runner ：它僅用於For Each ... In ... 。 在我的代碼中， For Each runner In rCrit.Cells的For Each runner In rCrit.Cells運行器將簡單地為rCrit -range中的每個單元運行整個循環。 因此，我的runner將是單元格，而不是For i = ... To ...其中i是數字。 因此，在第一個循環中， runner將與Range("H2") 。 在第二個Range("H4") ，依此類推，直到rCrit的最后一個單元格rCrit 。

作為一個節省時間的工具，我使用Application.CountIf(.Columns(1), runner)來檢查結果而不進行排序。 如果為正，則仍需要排序。

除此之外，大多數部分都應該像以前一樣。
如果您還有其他問題，請提出;）