CODEWITHSUNDEEP
excelvba
suresh7860
suresh7860

Reputation: 91

Want to use loop instead of separate codes until last row

I am trying to find the unique names which are in column A to Column H and filter the data based on the values in column H and in column A which I am able to get, but I am unable to make it work until last row of data in Column H.

Please help me to correct the code so that it can run until last row in column H suggesting suitable modification to define the criteria range whereas I have done below separately for each cell. I am not good with Loops but trying to fix it though as yet unable to correct and make it work. I have not been able to successfully define the range properly and make it work. Would be of great help if any of the experts can take time out and look into this, correct and improve my code.

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

Upvotes: 0

Views: 76

Answers (1)

Dirk Reichel
Dirk Reichel

Reputation: 7979

Without real data, it is not possible to test it completely, but this should do what you want:

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

The runner: it is simply used in a For Each ... In .... In my code the For Each runner In rCrit.Cells simply will run the whole loop for every cell in the rCrit-range. so instead of an For i = ... To ... where i is a number, my runner will be cell. So in the first cycle runner will be the same like Range("H2"). In the second Range("H4") and so on till the last cell in rCrit.

As a time-saver, i used Application.CountIf(.Columns(1), runner) to check for the outcome without sorting. If it is positive, it still needs to be sorted.

Away from this, most parts should be like they were before.
If you got some other questions, just ask ;)

Upvotes: 1

Related Questions