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

KP_SoCal
KP_SoCal used Ask the Experts™
on
In the attached Sample file, I have a tab called ‘DataLists’ that I need to loop through the existing “State” tabs and paste in the “State” and “County” information starting in cell B4 that is copied from ‘DataLists’.  The data pasted should only be relative to the “State” listed in column G of ‘DataLists’.

Any help would be greatly appreciated.  Thank you!

P.S. I'm using Excel 2010
Sample.xlsx
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2015
Commented:
Use this code..What it does it deletes the old worksheet on your workbook and creates new worksheets from scratch...

Sub 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

For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ws1.Name Then ws.Delete
Next ws

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

Open in new window


Enclosed is your workbook for your reference...
Sample.xlsm

Author

Commented:
Thank you for the quick response.  However, I'm not looking to recreate the existing tab.  Reason being, I have special formatting and page layouts applied to each tab of the actual document.  So I only want to copy and paste into the applicable 'State' tab.  Any ideas on how to accomplish?

Author

Commented:
Here's a link to a thread that is very close to what I'm looking for accomplish. http://stackoverflow.com/questions/29472855/excel-vba-to-search-worksheet-names-and-copy-a-range-into-active-sheet.

However the sub routine from the link referenced above is looking to copy from the tabs I'm intending to use as the actual target for my situation.
Top Expert 2015

Commented:
In that case use this code...

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

Open in new window


Saurabh...

Author

Commented:
I couldn't get the other solution to work. This one doesn't accomplish exactly what I'm looking for, but I can work with it.

Thank you,

KP

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial