Need a repeating Macro to select rows from the spreadsheet based on changing column range.

Poor Dave

New Member
Joined
Feb 4, 2023
Messages
17
Office Version
  1. 365
Platform
  1. Windows
Need help please writing an Excel Macro from you professionals. My coding knowledge is through Word VBA but little to limited with Excel.

I have a report that is run each night that continually updates with additional data. I dump the report raw data into a spreadsheet each morning. Now I need to select and cut out all the rows out of the entire spreadsheet that contains the number ‘2’ in a column (say column ‘I’) and place in the next worksheet. Then after that is all separated out, I need the macro to go back and select all number ‘3’ rows from the same column, select the entire rows, cut from main spreadsheet, and place in the next successive worksheet. Then ‘4’, then ‘5’ then etc. I don’t have to move any data with a ‘1’. The column may have additional integer numbers added each night, so first nights data in column ‘I” may be from 1 to 8, then next night may be 1 to 22, then next night data from 1 to 15, etc.

I found code posted by another programmer to perform the selecting of all their rows that contain the letter ’G’ for their application, adapted for my first number ‘2’, but then can’t figure out how to loop it back to hunt for the next successive number ’3’, then ‘4’, then ‘5’, etc.

This is what I have so far. Works fine for the number ‘2’. Now I need the macro loop to repeat itself until no number is found. Fails on remaining selecting of rows. Can’t figure out how to bound this code into a loop for column ‘I’ with a number range of say 2 – 100.

Thanks for your help!!

Sub Test()

Dim i As Integer
For i = 2 To 100
Columns("I:I").Select
Dim a As Range
Dim rngA As Range
For Each a In Intersect(ActiveSheet.UsedRange, Columns("I"))
If a = i Then
If rngA Is Nothing Then Set rngA = a.EntireRow
Set rngA = Union(rngA, a.EntireRow)
End If
Next a
rngA.Select
Selection.Cut
Sheets.Add After:=ActiveSheet
Cells.Select
ActiveSheet.Paste
Sheets("WM200 - Work Order Material Rep").Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Next i
End Sub
Raw data looks like this with about 50 more columns.

1675532026394.png
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
Hi Poor Dave,

what about using AutoFilter:

VBA Code:
Public Sub MrE_1229043_1702317()
' https://www.mrexcel.com/board/threads/need-a-repeating-macro-to-select-rows-from-the-spreadsheet-based-on-changing-column-range.1229043/
Dim lngCounter As Long
Dim wsMatRep As Worksheet

Set wsMatRep = Sheets("WM200 - Work Order Material Rep")

With wsMatRep
  For lngCounter = 2 To WorksheetFunction.Max(.Columns("I:I"))
    If .AutoFilterMode Then .ShowAllData
    With .Range("A1").CurrentRegion
      .AutoFilter Field:=9, Criteria1:=CStr(lngCounter)
      .SpecialCells(xlCellTypeVisible).Copy
      Worksheets.Add after:=Worksheets(Worksheets.Count)
      ActiveSheet.Paste
      ActiveSheet.Name = Format(Now, "yymmdd_hhmmss_") & Format(lngCounter, "000")
    End With
    .Range("A2", .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column)). _
        SpecialCells(xlCellTypeVisible).Delete xlShiftUp
  Next lngCounter
  .AutoFilterMode = False
End With

Set wsMatRep = Nothing
End Sub

Ciao,
Holger
 
Upvote 0
Hi Poor Dave,

what about using AutoFilter:

VBA Code:
Public Sub MrE_1229043_1702317()
' https://www.mrexcel.com/board/threads/need-a-repeating-macro-to-select-rows-from-the-spreadsheet-based-on-changing-column-range.1229043/
Dim lngCounter As Long
Dim wsMatRep As Worksheet

Set wsMatRep = Sheets("WM200 - Work Order Material Rep")

With wsMatRep
  For lngCounter = 2 To WorksheetFunction.Max(.Columns("I:I"))
    If .AutoFilterMode Then .ShowAllData
    With .Range("A1").CurrentRegion
      .AutoFilter Field:=9, Criteria1:=CStr(lngCounter)
      .SpecialCells(xlCellTypeVisible).Copy
      Worksheets.Add after:=Worksheets(Worksheets.Count)
      ActiveSheet.Paste
      ActiveSheet.Name = Format(Now, "yymmdd_hhmmss_") & Format(lngCounter, "000")
    End With
    .Range("A2", .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column)). _
        SpecialCells(xlCellTypeVisible).Delete xlShiftUp
  Next lngCounter
  .AutoFilterMode = False
End With

Set wsMatRep = Nothing
End Sub

Ciao,
Holger
Thanks for the quick response. Did not think to filter the column first to the specific value. This code does what I need with one exception. Each range that is pasted onto each successive sheet always contains the first row with the number 1 from my column.
 
Upvote 0
Hi Poor Dave,

with the code supplied above each number must be found otherwise the header row in the source sheet would get deleted.

Update to the code to take care of only data range to be copied if exist omitting the headers:

VBA Code:
Public Sub MrE_1229043_1702317Update()
' https://www.mrexcel.com/board/threads/need-a-repeating-macro-to-select-rows-from-the-spreadsheet-based-on-changing-column-range.1229043/
' Updated: 20230204
' Reason:  condition added: if number to search for isn't found, omitt adding an empty sheet and deleting the header row on the source sheet

Dim blnCont As Boolean
Dim lngCounter As Long
Dim wsMatRep As Worksheet

Set wsMatRep = Sheets("WM200 - Work Order Material Rep")

With wsMatRep
  For lngCounter = 2 To WorksheetFunction.Max(.Columns("I:I"))
    blnCont = False
    If .AutoFilterMode Then .ShowAllData
    With .Range("A1").CurrentRegion
      .AutoFilter Field:=9, Criteria1:=CStr(lngCounter)
      If wsMatRep.Cells(wsMatRep.Rows.Count, 1).End(xlUp).Row > 1 Then blnCont = True
      If blnCont = True Then
        wsMatRep.Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Paste
        ActiveSheet.Name = Format(Now, "yymmdd_hhmmss_") & Format(lngCounter, "000")
      End If
    End With
    If blnCont Then .Range("A2", .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, _
          .Cells(1, .Columns.Count).End(xlToLeft).Column)).SpecialCells(xlCellTypeVisible).Delete xlShiftUp
  Next lngCounter
  .AutoFilterMode = False
End With

Set wsMatRep = Nothing
End Sub

Ciao,
Holger
 
Upvote 0
Solution
Hi Poor Dave,

with the code supplied above each number must be found otherwise the header row in the source sheet would get deleted.

Update to the code to take care of only data range to be copied if exist omitting the headers:

VBA Code:
Public Sub MrE_1229043_1702317Update()
' https://www.mrexcel.com/board/threads/need-a-repeating-macro-to-select-rows-from-the-spreadsheet-based-on-changing-column-range.1229043/
' Updated: 20230204
' Reason:  condition added: if number to search for isn't found, omitt adding an empty sheet and deleting the header row on the source sheet

Dim blnCont As Boolean
Dim lngCounter As Long
Dim wsMatRep As Worksheet

Set wsMatRep = Sheets("WM200 - Work Order Material Rep")

With wsMatRep
  For lngCounter = 2 To WorksheetFunction.Max(.Columns("I:I"))
    blnCont = False
    If .AutoFilterMode Then .ShowAllData
    With .Range("A1").CurrentRegion
      .AutoFilter Field:=9, Criteria1:=CStr(lngCounter)
      If wsMatRep.Cells(wsMatRep.Rows.Count, 1).End(xlUp).Row > 1 Then blnCont = True
      If blnCont = True Then
        wsMatRep.Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Paste
        ActiveSheet.Name = Format(Now, "yymmdd_hhmmss_") & Format(lngCounter, "000")
      End If
    End With
    If blnCont Then .Range("A2", .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, _
          .Cells(1, .Columns.Count).End(xlToLeft).Column)).SpecialCells(xlCellTypeVisible).Delete xlShiftUp
  Next lngCounter
  .AutoFilterMode = False
End With

Set wsMatRep = Nothing
End Sub

Ciao,
Holger
Thank you again for the quick response. Works like a champ!
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,912
Members
452,366
Latest member
TePunaBloke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top