VBA to loop through worksheet and paste data from source relative to sheet name

ub movedata()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim ws As Worksheet, ws1 As Worksheet
Dim ws2 As Worksheet
Dim lrow As Long, cell As Range, rng As Range, r As Range
Dim lr As Long
Set ws1 = Sheets("DataList")
lrow = ws1.Cells(Cells.Rows.Count, "G").End(xlUp).Row

Set rng = ws1.Range("G2:G" & lrow)

For Each cell In rng
Set r = ws1.Range("G2:G" & cell.Row)

If Application.WorksheetFunction.CountIf(r, cell.Value) = 1 Then
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = cell.Value
Set ws2 = ActiveSheet
ws1.Range("G1:H1").Copy ws2.Range("b4")
Else
Set ws2 = Sheets(cell.Value)
End If


lr = ws2.Cells(Cells.Rows.Count, "B").End(xlUp).Row + 1

ws2.Range("B" & lr) = cell.Value
ws2.Range("c" & lr) = cell.Offset(0, 1).Value


Next cell

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Select allOpen in new window