想要使用循环而不是单独的代码，直到最后一行

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)来检查结果而不进行排序。 如果为正，则仍需要排序。

除此之外，大多数部分都应该像以前一样。
如果您还有其他问题，请提出;）