Loop through table and cut&paste to another sheet

Question

I am a total beginner and appreciate any help I can get.

Sheet1 has a list of 30 markets. Market1 Market2 . . Market30

I have a script that loops through Sheet1 and creates a new sheet for every market.

Sheet2 has all my raw data.

Looping through Sheet2 I need to move every row to its corresponding market. Market ID is in column B.

1-by-1 I can do this with the code below, but how would I put it in a loop? I want to loop through Sheet1 and for each market ID, use that input as a variable to search Sheet2 and move the entire row to its corresponding market sheet.

Sub Market1()
Dim LR As Long, i As Long
With Sheets("Sheet2")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For i = 1 To LR
If .Range("B" & i).Value = "Market1" Then .Rows(i).Copy Destination:=Sheets("Market1").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
End With
End Sub


Sub Market2()
Dim LR As Long, i As Long
With Sheets("Sheet2")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For i = 1 To LR
If .Range("B" & i).Value = "Market2" Then .Rows(i).Copy Destination:=Sheets("Market2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
End With
End Sub

Thank you

Can you clarify? I see you have two macros, with loops. What exactly are you trying to loop? is it correct that in both subs you have With Sheets("Sheet2") ? or should the first macro use Sheet1? — BruceWayne

pgSystemTester pgSystemTester · Accepted Answer · 2018-06-22T21:51:56

I think this should do what you want. The only tricky thing is adding a sheet if you already have the sheet name. I added a second macro that checks for it and creates if not found. Based on your code (which was a nice example), I think this should work for you.

Sub MarketAny()
Dim LR As Long, i As Long
Dim ws As Worksheet, shName As String


Set ws = Sheets("Sheet2")

LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row

    For i = 1 To LR

    shName = ws.Range("B" & i).Value
    Call SheetCheck(shName) ' needed to ensure that you don't create a duplicate name

        ws.Rows(i).Copy Destination:=Sheets(shName).Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i


End Sub

Private Sub SheetCheck(nameofSheet As String)
Dim ws As Worksheet

For Each ws In ThisWorkbook.Sheets
     If ws.Name = nameofSheet Then Exit Sub

Next ws

'Creates new sheet
Set ws = Sheets.Add
ws.Name = nameofSheet

End Sub

Loop through table and cut&paste to another sheet

1 Answers