Wollen Sie Schleife anstelle von separaten Codes bis zur letzten Zeile verwenden

Question

Ich versuche, die eindeutigen Namen, die in Spalte A bis Spalte H sind und die Daten auf der Grundlage der Werte in Spalte H und Spalte A, die ich in der Lage bin zu filtern erhalten, aber ich bin nicht in der Lage, es bis zur letzten Reihe von Daten in Spalte H arbeiten zu lassen.

Bitte helfen Sie mir, den Code zu korrigieren, damit es bis letzte Zeile in Spalte H laufen kann, die passende Änderung vorschlägt, um den Kriterienbereich zu definieren, während Ich habe unten für jede Zelle getrennt getan. Ich bin nicht gut mit Loops, aber ich versuche es zu beheben, obwohl es noch nicht in der Lage ist, es zu korrigieren und es zum Laufen zu bringen. Ich war nicht in der Lage, den Bereich erfolgreich zu definieren und es funktionieren zu lassen. Es wäre eine große Hilfe, wenn einer der Experten sich eine Auszeit nehmen und sich damit befassen, meinen Code korrigieren und verbessern könnte.

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

Ohne echte Daten ist es nicht möglich, sie vollständig zu testen, aber dies sollte das tun, was Sie wollen:

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 

EDIT

Die runner: es wird einfach verwendet in a For Each ... In .... In meinem Code wird die For Each runner In rCrit.Cells einfach die gesamte Schleife für jede Zelle im rCrit-Bereich durchlaufen. also statt For i = ... To ... wo i eine Nummer ist, wird meine runner Zelle sein. Also im ersten Zyklus wird runner das gleiche wie Range("H2") sein. In der zweiten Range("H4") und so weiter bis zur letzten Zelle in rCrit.

Als Zeitsparer habe ich Application.CountIf(.Columns(1), runner) verwendet, um das Ergebnis zu überprüfen, ohne zu sortieren. Wenn es positiv ist, muss es noch sortiert werden.

Davon abgesehen, sollten die meisten Teile wie zuvor sein.
Wenn Sie einige andere Fragen haben, fragen Sie einfach;)