• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Coping rows of data to new worksheet everytime value in column A changes

W

wnorrick

Member
I have a workbook that contains employee listing by property. I have values in columns A through W and every time the value in column A changes i need all the rows for the code in column A to go to a new worksheet. I will end up with 130 worksheets, one for each property. The value in column A is a numeric code for the property. I would like the rows to populate the new worksheets starting in row 11. Any help will be appreciated. Thank you.
 
wnorrick said:
I have a workbook that contains employee listing by property. I have values in columns A through W and every time the value in column A changes i need all the rows for the code in column A to go to a new worksheet. I will end up with 130 worksheets, one for each property. The value in column A is a numeric code for the property. I would like the rows to populate the new worksheets starting in row 11. Any help will be appreciated. Thank you.
Click to expand...
Hi,


Try the code below. The name of the worksheets created is the number in Col A.

Code: 
Sub Copy_Data()
 Dim r As Range, LastRow As Long, ws As Worksheet
 Dim v As Variant, s As String, LastRow1 As Long
 Dim src As Worksheet
 Set src = Sheets("Sheet1")
 LastRow = src.Cells(Cells.Rows.Count, "A").End(xlUp).Row
 For Each r In src.Range("A1:A" & LastRow)
  On Error Resume Next
  Set ws = Sheets(CStr(r.Value))
  On Error GoTo 0
  If ws Is Nothing Then
  Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(r.Value)
  LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row
  src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(WorksheetFunction.Max(11, LastRow1 + 1), 1)
  Set ws = Nothing
  Else
  LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row
  src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
  Set ws = Nothing
  End If
 Next r
 End Sub
 
I tried it however I am getting an error message:
run time error 9
subscript is out of range
it occurs at this line Set src = Sheets("Sheet1")

What am I doing wrong?
Thank you for your help.
 
wnorrick said:
I tried it however I am getting an error message:
run time error 9
subscript is out of range
it occurs at this line Set src = Sheets("Sheet1")

What am I doing wrong?
Thank you for your help.
Click to expand...
Hi,

My bad, I should have explained. Change the bit in bold in that line to the name of the worksheet that has all your data on. It must be the same as on the worksheet tab.

Set src = Sheets("Sheet1")
 
Last edited:
Mike H.. said:
Hi,

My bad, I should have explained. Change the bit in bold in that line to the name of the worksheet that has all your data on. It must be the same as on the worksheet tab.

Set src = Sheets("Sheet1")
Click to expand...

This works great. Thank you so much. I have another question that you might can help me with if you don't mind. The first 10 rows on these worksheets are basically a template that does vlookups to fill in manager name, regional, etc. There are 130 worksheets and if there was a quick way to drop in the template on each worksheet in the first 10 rows and it still have the formulas intact?

Thank you
 
wnorrick said:
This works great. Thank you so much. I have another question that you might can help me with if you don't mind. The first 10 rows on these worksheets are basically a template that does vlookups to fill in manager name, regional, etc. There are 130 worksheets and if there was a quick way to drop in the template on each worksheet in the first 10 rows and it still have the formulas intact?

Thank you
Click to expand...
Hi,

Can you attach a redacted copy of the workbook here? We don't need 130 sheets, just the template and a couple of sheets.
 
Mike H.. said:
Hi,

Can you attach a redacted copy of the workbook here? We don't need 130 sheets, just the template and a couple of sheets.
Click to expand...

i fixed a mini set with dummy data but I think it will be enough for you to see what i want to do. The data goes to the new pages and starts on row 11 like I need it to however as mentioned it would be nice if I could somehow get them to the template or if I could add the template after the fact. If I haven't included enough data just let me know. There are 130 properties so any time saving ideas are greatly appreciated. Thank you for all of your help.
 

Attachments

  • Sample workbook.xlsx
    99.2 KB · Views: 1
wnorrick said:
i fixed a mini set with dummy data but I think it will be enough for you to see what i want to do. The data goes to the new pages and starts on row 11 like I need it to however as mentioned it would be nice if I could somehow get them to the template or if I could add the template after the fact. If I haven't included enough data just let me know. There are 130 properties so any time saving ideas are greatly appreciated. Thank you for all of your help.
Click to expand...
Hi,

Try this.


Code: 
Sub Copy_Data()
  Dim r As Range, LastRow As Long, ws As Worksheet
  Dim v As Variant, s As String, LastRow1 As Long
  Dim src As Worksheet
  Set src = Sheets("Campus")
  LastRow = src.Cells(Cells.Rows.Count, "A").End(xlUp).Row
  For Each r In src.Range("A2:A" & LastRow)
  On Error Resume Next
  Set ws = Sheets(CStr(r.Value))
  On Error GoTo 0
  If ws Is Nothing Then
  Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(r.Value)
  Sheets("Template").Rows("1:10").Copy ActiveSheet.Range("A1")
  LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row
  src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(WorksheetFunction.Max(11, LastRow1 + 1), 1)
  Set ws = Nothing
  Else
  LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row
  src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
  Set ws = Nothing
  End If
  Next r
  End Sub
 
You must log in or register to reply here.
Back
Top