Question

我正在尝试找到列A到列H中的唯一名称，并根据我能够获得的列H和列A中的值来过滤数据，但我无法使其工作直到列H中的最后一行数据。

请帮我纠正代码，以便它可以运行到H列的最后一行，建议进行适当的修改以定义标准范围，而我在下面分别对每个单元格进行操作。我对循环不好，但试图解决它虽然仍然无法纠正并使其工作。我无法正确定义范围并使其正常工作。如果任何专家可以抽出时间调查，纠正并改进我的代码，将会有很大的帮助。

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只会为rCrit - 范围内的每个单元格运行整个循环。因此For i = ... To ...不是i而是runner是一个数字，而runner将是一个数字。因此，在第一个周期Range("H2")将与Range("H4")相同。在第二个rCrit中依此类推，直到Application.CountIf(.Columns(1), runner)中的最后一个单元格。

为节省时间，我使用dmesg | grep kill检查结果而不进行排序。如果是积极的，它仍然需要进行分类。

远离这一点，大多数部分应该像以前一样如果您还有其他问题，请询问;）

想要在最后一行之前使用循环而不是单独的代码

1 个答案: