VBA code to copy data matching criteria to new sheet and copy specific rows in between

[vbanewbie2011]

Hello! I am relatively new to VBA and have been searching for a few weeks for a code that will do the following:

I need to copy all data in a row from a "Master" sheet to individual sheets (in the same workbook) where the ID on the Master sheet match the individual sheet names while also copying the row titles/headings. My problem is on the Master sheet, the first 6 rows are "section titles", as are rows 17-19 and rows 96-98. Rows 7, 20, & 99 are "headers".

For example: There is one instance of ID "11" under Section 1 (cell A8), three instances under Section 2 (cells A21, A22, & A23), and one instance under Section 3 (cell A100). On the sheet named "11", I need each Section heading with the corresponding data shown below each.

For instances where an ID may not appear under all 3 sections, I would like the text "Section Not Applicable" to appear below the section title.

I have an example file that may provide a better visual- let me know how to send if you'd like the file. Any help would be GREATLY appreciated!!! Thank you!

 

[hiker95]

vbanewbie2011,

Welcome to the MrExcel forum.

What version of Excel are you using?

You will generally get much more help (and faster) in this forum if you can post your small samples (what you have and what you expect to achieve) directly in the forum.

To attach screenshots, see below in my Signature block: Post a screen shot with one of these:

If you are not able to give us screenshots, see below in my Signature block: You can upload your workbook to Box Net, and provide us with a link to your workbook.

 

[vbanewbie2011]

I apologize for not including which version I'm using... I can't believe I did that! I'm using Excel 2003. I have loaded the example file to Box Net; here is the link: http://www.box.net/shared/egkkbt42274a1jh2fna8

In the example file, the Master page is what I currently have; the other 3 pages are what I would like to be able to do with a VBA code. The example has 3 sheets for separate ID's. However, there are actually 38 unique ID's. I already have a code that will create a separate sheet for each unique ID number.

What I'm hoping someone here can help me with is a code that will copy the section titles and headers from the master to each sheet while also copying the data in each row where the ID number matches the sheet name and keeps it under the correct section title. An added bonus would be if an ID number is not present in one of the sections, the text "Section Not Applicable" would be listed below the section title.

I hope this helps clarify what I'm looking for, but if not, please let me know. Thank you so much!

 

[hiker95]

vbanewbie2011,

Thanks for the workbook.

Very interesting problem.

Working on it.

Will have some questions for you later today.

 

[hiker95]

vbanewbie2011,


The macro will work correctly as long as the spacing between the 3 groups is constant.

The macro will create the worksheets for the ID's, as they are processed from Section 1 To Section 3.


Sample raw data in worksheet Master:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
1	2011 Data
2	Report
3	1st Qtr vs. 2nd Qtr
4
5	Section 1: Major Change
6
7	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
8	11	R 24	19	1	SMITH J	1234ABC789	270000	45000	2010	11	Test 1
9	46	R 1	2	12	DOE J	1234ABC789	270000	44000	2010	8	Test 2
10	54	N 59	38	5	BLACK M	1234ABC789	270000	645000	2010	5	Test 3
11	62	R 90	38	1	TAYLOR R	1234ABC789	270000	52000	2010	12	Test 4
12	63	N 4	1	98	BROWN D	1234ABC789	270000	3500	2010	6	Test 5
13	73	N 17	4	15	WILLIAMS M	1234ABC789	270000	28500	2010	12	Test 6
14	74	R 57	1	12	HARRIS G	1234ABC789	270000	47500	2010	12	Test 7
15
16
17
18	Section 2: Minor Change
19
20	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
21	11	R 26	1	30	SMITH J	987ZYXM445	8950000	25000	2010	2	Test 8
22	11	R 27	1	40	SMITH J	987ZYXM445	8950000	69000	2010	8	Test 9
23	11	N 11	99	1	SMITH J	987ZYXM445	8950000	350000	2010	9	Test 10
24	16	N 2	1	30	SMITH J	987ZYXM445	8950000	1100000	2010	3	Test 11
25	18	R 22	1	37	SMITH J	987ZYXM445	8950000	6800	2010	1	Test 12
Master

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
89	74	R 19	2	37	BROWN D	987ZYXM445	8950000	45000	2010	2	Test 76
90	74	R 57	1	12	BROWN D	987ZYXM445	8950000	47500	2010	12	Test 77
91	74	R 79	1	16	BROWN D	987ZYXM445	8950000	94998	2010	9	Test 78
92	74	R 96	2	12	BROWN D	987ZYXM445	8950000	72400	2010	8	Test 79
93	74	R 97	1	12	BROWN D	987ZYXM445	8950000	32000	2010	2	Test 80
94
95
96
97	Section 3: Supposed to Change but Didn't
98
99	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
100	11	R 3	1	3	DOE J	632589WFTG55	453000	15000	2010	2	Test 81	Reason 1
101	16	R 2	5	5	DOE J	632589WFTG56	453001	4500000	2010	7	Test 82	Reason 2
102	18	R 21	3	3	DOE J	632589WFTG57	453002	77000	2010	4	Test 83	Reason 3
103	21	N 15	2	2	DOE J	632589WFTG58	453003	77500	2010	5	Test 84	Reason 4
Master

After the macro:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
1	2011 Data
2	Report
3	1st Qtr vs. 2nd Qtr
4
5	Section 1: Major Change
6
7	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
8	11	R 24	19	1	SMITH J	1234ABC789	270000	45000	2010	11	Test 1
9
10	Section 2: Minor Change
11
12	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
13	11	R 26	1	30	SMITH J	987ZYXM445	8950000	25000	2010	2	Test 8
14	11	R 27	1	40	SMITH J	987ZYXM445	8950000	69000	2010	8	Test 9
15	11	N 11	99	1	SMITH J	987ZYXM445	8950000	350000	2010	9	Test 10
16
17	Section 3: Supposed to Change but Didn't
18
19	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
20	11	R 3	1	3	DOE J	632589WFTG55	453000	15000	2010	2	Test 81	Reason 1
21
11

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
1	2011 Data
2	Report
3	1st Qtr vs. 2nd Qtr
4
5	Section 1: Major Change
6
7	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
8	Section Not Applicable
9
10	Section 2: Minor Change
11
12	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
13	18	R 22	1	37	SMITH J	987ZYXM445	8950000	6800	2010	1	Test 12
14	18	R 43	1	37	SMITH J	987ZYXM445	8950000	209300	2010	10	Test 13
15	18	R 49	1	37	SMITH J	987ZYXM445	8950000	345000	2010	12	Test 14
16	18	R 64	1	37	SMITH J	987ZYXM445	8950000	7500	2010	3	Test 15
17	18	R 78	1	15	SMITH J	987ZYXM445	8950000	245000	2010	9	Test 16
18	18	N 8	1	37	SMITH J	987ZYXM445	8950000	145000	2010	4	Test 17
19
20	Section 3: Supposed to Change but Didn't
21
22	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
23	18	R 21	3	3	DOE J	632589WFTG57	453002	77000	2010	4	Test 83	Reason 3
24
18

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
1	2011 Data
2	Report
3	1st Qtr vs. 2nd Qtr
4
5	Section 1: Major Change
6
7	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
8	74	R 57	1	12	HARRIS G	1234ABC789	270000	47500	2010	12	Test 7
9
10	Section 2: Minor Change
11
12	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
13	74	R 19	2	37	BROWN D	987ZYXM445	8950000	45000	2010	2	Test 76
14	74	R 57	1	12	BROWN D	987ZYXM445	8950000	47500	2010	12	Test 77
15	74	R 79	1	16	BROWN D	987ZYXM445	8950000	94998	2010	9	Test 78
16	74	R 96	2	12	BROWN D	987ZYXM445	8950000	72400	2010	8	Test 79
17	74	R 97	1	12	BROWN D	987ZYXM445	8950000	32000	2010	2	Test 80
18
19
20
21
22
23
24
25
74

Ooops.... Be back in a little while to add some code to check each worksheet for the three Sections.

 

[hiker95]

vbanewbie2011,


After the macro update:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
1	2011 Data
2	Report
3	1st Qtr vs. 2nd Qtr
4
5	Section 1: Major Change
6
7	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
8	74	R 57	1	12	HARRIS G	1234ABC789	270000	47500	2010	12	Test 7
9
10	Section 2: Minor Change
11
12	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
13	74	R 19	2	37	BROWN D	987ZYXM445	8950000	45000	2010	2	Test 76
14	74	R 57	1	12	BROWN D	987ZYXM445	8950000	47500	2010	12	Test 77
15	74	R 79	1	16	BROWN D	987ZYXM445	8950000	94998	2010	9	Test 78
16	74	R 96	2	12	BROWN D	987ZYXM445	8950000	72400	2010	8	Test 79
17	74	R 97	1	12	BROWN D	987ZYXM445	8950000	32000	2010	2	Test 80
18
19	Section 3: Supposed to Change but Didn't
20
21	ID	Ref	Original Code	Change Code	Name	Full #	Original Amt	Change Amt	Year	Month	Major Change Reason
22	Section Not Applicable
23
24
25
74

With your sample raw data, there were only 37 unique ID's, and there were 37 worksheets created.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub DistributeData()
' hiker95, 09/08/2011
' http://www.mrexcel.com/forum/showthread.php?t=577018
Dim wM As Worksheet, ws As Worksheet
Dim MyS1 As Long, MyS2 As Long, MyS3 As Long, LR As Long, LUR As Long
Dim MyC1 As Long, MyC2 As Long, MyC3 As Long
Dim TR As Long, FR As Long, ER As Long, a As Long, NR As Long, N As String
Application.ScreenUpdating = False
Set wM = Worksheets("Master")
MyS1 = Application.Match("Section 1: Major Change", wM.Columns(1), 0)
MyS2 = Application.Match("Section 2: Minor Change", wM.Columns(1), 0)
MyS3 = Application.Match("Section 3: Supposed to Change but Didn't", wM.Columns(1), 0)
LR = wM.Cells(Rows.Count, 1).End(xlUp).Row
'********** Section 1: Major Change **********
TR = MyS1 + 2
FR = MyS1 + 3
ER = MyS2 - 4
For a = FR To ER Step 1
  If Not Evaluate("ISREF(" & wM.Cells(a, 1) & "!A1)") Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = wM.Cells(a, 1)
  N = wM.Cells(a, 1)
  Set ws = Worksheets(N)
  MyC1 = 0
  On Error Resume Next
  MyC1 = Application.Match("Section 1: Major Change", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC1 = 0 Then
    ws.Cells.Interior.ColorIndex = 2
    wM.Range("A1:L7").Copy ws.Range("A1:L7")
    wM.Range("A1:L1").Copy
    With ws.Range("A1:L1")
      .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  Else
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  End If
Next a
'********** Section 2: Minor Change **********
TR = MyS2 + 2
FR = MyS2 + 3
ER = MyS3 - 4
For a = FR To ER Step 1
  If Not Evaluate("ISREF(" & wM.Cells(a, 1) & "!A1)") Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = wM.Cells(a, 1)
  N = wM.Cells(a, 1)
  Set ws = Worksheets(N)
  MyC1 = 0
  On Error Resume Next
  MyC1 = Application.Match("Section 1: Major Change", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC1 = 0 Then
    ws.Cells.Interior.ColorIndex = 2
    wM.Range("A1:L7").Copy ws.Range("A1:L7")
    wM.Range("A1:L1").Copy
    With ws.Range("A1:L1")
      .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    ws.Range("A" & NR) = "Section Not Applicable"
    With ws.Range("A" & NR & ":L" & NR)
      .HorizontalAlignment = xlCenter
      .MergeCells = True
      .Interior.ColorIndex = 2
    End With
  End If
  MyC2 = 0
  On Error Resume Next
  MyC2 = Application.Match("Section 2: Minor Change", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC2 = 0 Then
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(2).Row
    wM.Range("A" & MyS2 & ":L" & MyS2 + 2).Copy ws.Range("A" & NR)
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  Else
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  End If
Next a
'********** Section 3: Supposed to Change but Didn't *********
TR = MyS3 + 2
FR = MyS3 + 3
ER = LR
For a = FR To ER Step 1
  If Not Evaluate("ISREF(" & wM.Cells(a, 1) & "!A1)") Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = wM.Cells(a, 1)
  N = wM.Cells(a, 1)
  Set ws = Worksheets(N)
  MyC1 = 0
  On Error Resume Next
  MyC1 = Application.Match("Section 1: Major Change", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC1 = 0 Then
    ws.Cells.Interior.ColorIndex = 2
    wM.Range("A1:L7").Copy ws.Range("A1:L7")
    wM.Range("A1:L1").Copy
    With ws.Range("A1:L1")
      .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    ws.Range("A" & NR) = "Section Not Applicable"
    With ws.Range("A" & NR & ":L" & NR)
      .HorizontalAlignment = xlCenter
      .MergeCells = True
      .Interior.ColorIndex = 2
    End With
  End If
  MyC2 = 0
  On Error Resume Next
  MyC2 = Application.Match("Section 2: Minor Change", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC2 = 0 Then
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(2).Row
    wM.Range("A" & MyS2 & ":L" & MyS2 + 2).Copy ws.Range("A" & NR)
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    ws.Range("A" & NR) = "Section Not Applicable"
    With ws.Range("A" & NR & ":L" & NR)
      .HorizontalAlignment = xlCenter
      .MergeCells = True
      .Interior.ColorIndex = 2
    End With
  End If
  MyC3 = 0
  On Error Resume Next
  MyC3 = Application.Match("Section 3: Supposed to Change but Didn't", ws.Columns(1), 0)
  On Error GoTo 0
  If MyC3 = 0 Then
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(2).Row
    wM.Range("A" & MyS3 & ":L" & MyS3 + 2).Copy ws.Range("A" & NR)
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  Else
    NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    wM.Range("A" & a & ":M" & a).Copy ws.Range("A" & NR)
  End If
Next a
'********** Check each worksheet for "Section 3: Supposed to Change but Didn't" **********
For Each ws In ThisWorkbook.Worksheets
  If ws.Name <> "Instructions" And ws.Name <> "Master" Then
    MyC3 = 0
    On Error Resume Next
    MyC3 = Application.Match("Section 3: Supposed to Change but Didn't", ws.Columns(1), 0)
    On Error GoTo 0
    If MyC3 = 0 Then
      NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(2).Row
      wM.Range("A" & MyS3 & ":L" & MyS3 + 2).Copy ws.Range("A" & NR)
      NR = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
      ws.Range("A" & NR) = "Section Not Applicable"
      With ws.Range("A" & NR & ":L" & NR)
        .HorizontalAlignment = xlCenter
        .MergeCells = True
        .Interior.ColorIndex = 2
      End With
    End If
  End If
Next ws
wM.Activate
Application.ScreenUpdating = True
End Sub

Then run the DistributeData macro.

 

[HESH]

wow hiker it is long code

i like it

 

[hiker95]

HESH,

Thanks for the feedback.

 

[vbanewbie2011]

hiker95~

Thank you so much for your time and effort on this code! I'm going to test out now; I'll let you know how it works.

 

[vbanewbie2011]

hiker95,

You are a GENIUS!!! The code works exactly the way I'd hoped!!!

I've played around with the Master sheet, adding rows in each section with different ID numbers to see if the code would still work... it did! The only thing I noticed when adding rows was this:

3 new rows added in Section 1 with ID 13. The code created a sheet named 13 and copied everything like it was supposed to with the exception of the Section 2 title and header.

I went back and added 1 row in Section 2 with ID 13, and it worked just like the original- everything showed up. I also tried adding a single row in Section 2 (ID 14) only and a single row in Section 3 (ID 10) only, each with a different ID; the code worked perfectly on these as well. I went back and tried Section 1 again, adding a single row with ID 85 further down the list. Same problem as with ID 13 when I added the rows in Section 1 only.

Any idea what might cause the Section 2 title & header to not show when a row is added in Section 1? I've uploaded the file to Box Net: http://www.box.net/shared/qlj9z2otog4kqdsv0dt2

Again, I can't thank you enough for all your help on this!