Macro Copy rows to Another Sheet based on Heading

michrome23

New Member
Joined
Dec 23, 2012
Messages
2
Windows 7
Excel 2010

There are 13 columns in sheet ‘Raw Data’
Copy data from 'Raw Data' to specified sheet name in column A
But only extract those columns that Match Headings in the output sheet

So I would need a macro to

  1. Copy paste rows from sheet ‘Raw Data’
  2. If value in Column A = sheet name
  3. Only extract data with Corresponding Row Header

Example)
On Sheet ‘Raw Data’
A2 = Cache

SHEET
Hours
%
Job
Status
User
Priority
Issue
Frames
Time Completed
Average Frame HH:MM
Avg RAM
Max RAM
Cache
19
100
2979857
complete
Mike
3000
Lighting Changes
101
Fri, Dec 21, at 06:21 PM
00:32
3.9
9.5
Cache
79
100
2979864
complete
Mike
100
Tex
Sat, Dec 22, at 02:09 AM
00:42
5.3
16.1
Cache
19
100
2979989
complete
John
100
Feather Penetrations
Most
Fri, Dec 21, at 07:47 PM
00:26
2.1
6.7
Cache
7
100
2980028
complete
John
3000
Shadow
All
Fri, Dec 21, at 07:15 PM
00:16
1.2
3.5
Cache
8
100
2980203
complete
Mike
2900
Missing Geo
All
Fri, Dec 21, at 08:32 PM
00:05
1.2
4.7
Cache
7
100
2980204
complete
Mike
2900
Missing Geo
All
Fri, Dec 21, at 08:37 PM
00:05
1.2
5.0
Cache
1
100
2980205
complete
Nick
2900
Fri, Dec 21, at 08:08 PM
00:01
0.3
1.7
Mantra
25
100
2979770
complete
Jane
100
Texture
All
Fri, Dec 21, at 10:46 PM
00:39
2.9
9.6
Mantra
40
99
2979777
running
Jane
100
Sat, Dec 22, at 03:03 AM
Mantra
50
100
2979780
complete
Jane
100
Penetrations
All
Fri, Dec 21, at 07:44 PM
00:16
2.3
8.6
Mantra
54
100
2979782
complete
Jane
100
Penetrations
All
Fri, Dec 21, at 08:41 PM
00:17
2.0
8.4
Misc
100
2979572
complete
Marcy
1500
Fri, Dec 21, at 06:05 PM
00:43
12.0
14.0
Misc
58
43
2979848
Pending
John
3100
N/A
Misc
72
97
2979867
Pending
John
100
N/A
Playblast
7
11
2980158
running
Jane
3000
Sat, Dec 22, at 11:25 AM
Playblast
7
14
2980160
running
Jane
3000
Sat, Dec 22, at 10:38 AM
Playblast
1
100
2980411
complete
Nick
2900
Fri, Dec 21, at 08:09 PM
00:00
0.5
0.7
Playblast
1
100
2980420
complete
Jane
2900
Fri, Dec 21, at 08:15 PM
00:00
0.4
0.7
Playblast
1
100
2980422
complete
Jane
2900
Fri, Dec 21, at 08:15 PM
00:00
0.5
0.7
Playblast
1
100
2980423
complete
Jane
100
Fri, Dec 21, at 08:15 PM
00:00
0.4
0.7
Playblast
6
100
2980432
complete
Jane
2800
Fri, Dec 21, at 09:10 PM
00:05
1.7
2.7
PRMan
79
97
2979389
pending
Bill
1500
N/A
PRMan
31
100
2979828
complete
Jane
3000
Fri, Dec 21, at 06:46 PM
00:49
2.2
8.8
PRMan
11
100
2979905
complete
Jane
100
Fri, Dec 21, at 10:16 PM
00:45
5.8
13.7
PRMan
4
95
2979945
pending
Jane
100
N/A
PRMan
41
44
2979990
running
Jane
100
Sat, Dec 22, at 05:46 AM

<tbody>
</tbody>

Find sheet named Cache
Only extract data for corresponding Headings
(Those that Match in sheet Raw Data)

Job
User
Max RAM
Status
2979857
Mike
9.5
complete
2979863
John
3.3
complete
2979864
Mike
16.1
complete
2979866
Mike
5.2
complete

<tbody>
</tbody>



The data extracted for each sheet varies and would need to be able to change on the fly

The ‘Raw Data’ is a dynamic range as well

Further Examples)

In Sheet Playblast this information would need to be extracted
%
Job
Hours
Issue
Frames
Status
11
2980158
7
running
14
2980160
7
running
100
2980411
1
complete
100
2980420
1
complete
100
2980422
1
complete
100
2980423
1
complete

<tbody>
</tbody>

In Sheet PRman
User
Status
%
Job
Bill
pending
97
2979389
Jane
complete
100
2979828
Jane
complete
100
2979905
Jane
pending
95
2979945
Jane
running
44
2979990
Jane
complete
100
2979993
Jane
complete
100
2980004

<tbody>
</tbody>
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Try this:-
Code:
[COLOR="Navy"]Sub[/COLOR] MG23Dec59
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRw
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Array(Dn(, 4), Dn(, 6), Dn(, 13), Dn(, 5))
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Dn.Value)
        [COLOR="Navy"]Set[/COLOR] Q(0) = Union(Q(0), Dn(, 4))
        [COLOR="Navy"]Set[/COLOR] Q(1) = Union(Q(1), Dn(, 6))
        [COLOR="Navy"]Set[/COLOR] Q(2) = Union(Q(2), Dn(, 13))
        [COLOR="Navy"]Set[/COLOR] Q(3) = Union(Q(3), Dn(, 5))
        .Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K
[COLOR="Navy"]Dim[/COLOR] Rw
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
 
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    Ac = 0
    Sheets(K).Range("A1").Resize(, 4) = Array("Job", "User", "Max RAM", "Status")
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Rw [COLOR="Navy"]In[/COLOR] .Item(K)
            Ac = Ac + 1
            c = 1
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] nRw [COLOR="Navy"]In[/COLOR] Rw
                c = c + 1
                Sheets(K).Cells(c, Ac) = nRw
            [COLOR="Navy"]Next[/COLOR] nRw
        [COLOR="Navy"]Next[/COLOR] Rw
 [COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
MsgBox "Run"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
I'll try anything, once, Now you can try it.

Code:
Sub lime()
Dim sh As Worksheet, dSh As Worksheet, lr As Long, rng As Range, dLr As Long, dLc As Long
Set sh = Sheets("Raw Data")
lr = sh.Cells(Rows.Count, 2).End(xlUp).Row
lc = sh.Cells(1, Columns.Count).End(xlToLeft).Column
Set rng = sh.Range("A2:A" & lr)
For Each c In rng
Set dSh = Sheets(c.Value)
dLr = dSh.Cells(Rows.Count, 1).End(xlUp).Row + 1
dLc = dSh.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To dLc
Set hdr = dSh.Cells(1, i)
MsgBox hdr.Address
For j = 2 To lc
If Trim(sh.Cells(1, j)) = Trim(hdr) Then
sh.Cells(c.Row, j).Copy dSh.Cells(dLr, i)
End If
Next j
Next i
Next c
End Sub
Code:
 
Upvote 0
michrome23,

Welcome to the MrExcel forum.


Sample raw data before and after the macro (the other three worksheets already exist and only contain their headings in row 1):


Excel Workbook
ABCDEFGHIJKLM
1SHEETHours%JobStatusUserPriorityIssueFramesTime CompletedAverage Frame HH:MMAvg RAMMax RAM
2Cache191002979857completeMike3000Lighting Changes101Fri, Dec 21, at 06:21 PM0:323.99.5
3Cache791002979864completeMike100TexSat, Dec 22, at 02:09 AM0:425.316.1
4Cache191002979989completeJohn100Feather PenetrationsMostFri, Dec 21, at 07:47 PM0:262.16.7
5Cache71002980028completeJohn3000ShadowAllFri, Dec 21, at 07:15 PM0:161.23.5
6Cache81002980203completeMike2900Missing GeoAllFri, Dec 21, at 08:32 PM0:051.24.7
7Cache71002980204completeMike2900Missing GeoAllFri, Dec 21, at 08:37 PM0:051.25
8Cache11002980205completeNick2900Fri, Dec 21, at 08:08 PM0:010.31.7
9Mantra251002979770completeJane100TextureAllFri, Dec 21, at 10:46 PM0:392.99.6
10Mantra40992979777runningJane100Sat, Dec 22, at 03:03 AM
11Mantra501002979780completeJane100PenetrationsAllFri, Dec 21, at 07:44 PM0:162.38.6
12Mantra541002979782completeJane100PenetrationsAllFri, Dec 21, at 08:41 PM0:1728.4
13Misc1002979572completeMarcy1500Fri, Dec 21, at 06:05 PM0:431214
14Misc58432979848PendingJohn3100N/A
15Misc72972979867PendingJohn100N/A
16Playblast7112980158runningJane3000Sat, Dec 22, at 11:25 AM
17Playblast7142980160runningJane3000Sat, Dec 22, at 10:38 AM
18Playblast11002980411completeNick2900Fri, Dec 21, at 08:09 PM0:000.50.7
19Playblast11002980420completeJane2900Fri, Dec 21, at 08:15 PM0:000.40.7
20Playblast11002980422completeJane2900Fri, Dec 21, at 08:15 PM0:000.50.7
21Playblast11002980423completeJane100Fri, Dec 21, at 08:15 PM0:000.40.7
22Playblast61002980432completeJane2800Fri, Dec 21, at 09:10 PM0:051.72.7
23PRMan79972979389pendingBill1500N/A
24PRMan311002979828completeJane3000Fri, Dec 21, at 06:46 PM0:492.28.8
25PRMan111002979905completeJane100Fri, Dec 21, at 10:16 PM0:455.813.7
26PRMan4952979945pendingJane100N/A
27PRMan41442979990runningJane100Sat, Dec 22, at 05:46 AM
28
Raw Data





After the macro:


Excel Workbook
ABCD
1JobUserMax RAMStatus
22979857Mike9.5complete
32979864Mike16.1complete
42979989John6.7complete
52980028John3.5complete
62980203Mike4.7complete
72980204Mike5complete
82980205Nick1.7complete
9
Cache





Excel Workbook
ABCDEF
1%JobHoursIssueFramesStatus
21129801587running
31429801607running
410029804111complete
510029804201complete
610029804221complete
710029804231complete
810029804326complete
9
Playblast





Excel Workbook
ABCD
1UserStatus%Job
2Billpending972979389
3Janecomplete1002979828
4Janecomplete1002979905
5Janepending952979945
6Janerunning442979990
7
PRman





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.


Code:
Option Explicit
Option Base 1
Sub CopyToSheets()
' hiker95, 12/23/2012
' http://www.mrexcel.com/forum/excel-questions/676074-macro-copy-rows-another-sheet-based-heading.html
Dim wR As Worksheet
Dim rd As Variant, r As Long, lr As Long, lc As Long, sr As Long, er As Long, nr As Long
Dim sa, s As Long, n As Long
Application.ScreenUpdating = False
sa = Array("Cache", "Playblast", "PRman")
Set wR = Worksheets("Raw Data")
lr = wR.Cells(Rows.Count, 1).End(xlUp).Row
lc = wR.Cells(1, Columns.Count).End(xlToLeft).Column
rd = wR.Range(wR.Cells(1, 1), wR.Cells(lr, lc))
wR.Range(wR.Cells(2, 1), wR.Cells(lr, lc)).Sort key1:=wR.Range("A2"), order1:=1, key2:=wR.Range("D2"), order2:=1
For s = LBound(sa) To UBound(sa)
  sr = Application.Match(sa(s), wR.Columns(1), 0)
  n = Application.CountIf(wR.Columns(1), sa(s))
  er = sr + n - 1
  Select Case sa(s)
    Case "Cache"
      nr = Worksheets(sa(s)).Range("A" & Rows.Count).End(xlUp).Offset(1).Row
      wR.Range(wR.Cells(sr, "D"), wR.Cells(er, "D")).Copy Worksheets(sa(s)).Range("A" & nr)
      wR.Range(wR.Cells(sr, "F"), wR.Cells(er, "F")).Copy Worksheets(sa(s)).Range("B" & nr)
      wR.Range(wR.Cells(sr, "M"), wR.Cells(er, "M")).Copy Worksheets(sa(s)).Range("C" & nr)
      wR.Range(wR.Cells(sr, "E"), wR.Cells(er, "E")).Copy Worksheets(sa(s)).Range("D" & nr)
    Case "Playblast"
      nr = Worksheets(sa(s)).Range("A" & Rows.Count).End(xlUp).Offset(1).Row
      wR.Range(wR.Cells(sr, "C"), wR.Cells(er, "C")).Copy Worksheets(sa(s)).Range("A" & nr)
      wR.Range(wR.Cells(sr, "D"), wR.Cells(er, "D")).Copy Worksheets(sa(s)).Range("B" & nr)
      wR.Range(wR.Cells(sr, "B"), wR.Cells(er, "B")).Copy Worksheets(sa(s)).Range("C" & nr)
      wR.Range(wR.Cells(sr, "H"), wR.Cells(er, "H")).Copy Worksheets(sa(s)).Range("D" & nr)
      wR.Range(wR.Cells(sr, "I"), wR.Cells(er, "I")).Copy Worksheets(sa(s)).Range("E" & nr)
      wR.Range(wR.Cells(sr, "E"), wR.Cells(er, "E")).Copy Worksheets(sa(s)).Range("F" & nr)
    Case "PRman"
      nr = Worksheets(sa(s)).Range("A" & Rows.Count).End(xlUp).Offset(1).Row
      wR.Range(wR.Cells(sr, "F"), wR.Cells(er, "F")).Copy Worksheets(sa(s)).Range("A" & nr)
      wR.Range(wR.Cells(sr, "E"), wR.Cells(er, "E")).Copy Worksheets(sa(s)).Range("B" & nr)
      wR.Range(wR.Cells(sr, "C"), wR.Cells(er, "C")).Copy Worksheets(sa(s)).Range("C" & nr)
      wR.Range(wR.Cells(sr, "D"), wR.Cells(er, "D")).Copy Worksheets(sa(s)).Range("D" & nr)
  End Select
Next s
wR.Range(wR.Cells(1, 1), wR.Cells(lr, lc)) = rd
wR.Activate
Application.ScreenUpdating = True
End Sub


Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the CopyToSheets macro.
 
Upvote 0
Hello Mick I am interest in knowing how you code works can you please explain the code or comment the code and post it again. Thanks
 
Upvote 0
Code Commented, as below:-

Code:
[COLOR=navy]Sub[/COLOR] MG24Dec43
[COLOR=navy]Dim[/COLOR] rng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] nRw
[COLOR=navy]Dim[/COLOR] Q
[COLOR=navy]Dim[/COLOR] Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]With[/COLOR] Sheets("Raw Data")
    [COLOR=navy]Set[/COLOR] rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
'[COLOR=green][B]You perhaps first need to "Google" "VBA + Scripting Dictionary"[/B][/COLOR]
'[COLOR=green][B]Assuming you now have a basic understand of the "Scrip Dic" :-[/B][/COLOR]
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] rng
   '[COLOR=green][B]Loop through column "A",[/B][/COLOR]
   '[COLOR=green][B] The following two lines of code place the first Instance of each[/B][/COLOR]
   '[COLOR=green][B]unique sheet name from column "A" into the "dictionary"[/B][/COLOR]
    '[COLOR=green][B]This is the Dictioary "Key" (.Add dn.value) being the sheet name.[/B][/COLOR]
    '[COLOR=green][B]The Dictionary "items" are also added as an array of offset columns (4,6,13,5)for that row[/B][/COLOR]
    '[COLOR=green][B]each set as range Objects[/B][/COLOR]
    [COLOR=navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=navy]Then[/COLOR]
        .Add Dn.Value, Array(Dn(, 4), Dn(, 6), Dn(, 13), Dn(, 5))
    [COLOR=navy]Else[/COLOR]
      '[COLOR=green][B]Q is set as a Variant object representing the Array of "Items"  for a particular "Key"[/B][/COLOR]
       '[COLOR=green][B]Example say the first sheet name found is "Catche" then the ".Item(Catche)" represents all the[/B][/COLOR]
       '[COLOR=green][B]previously entered offset columns ranges for that particular "key"[/B][/COLOR]
        Q = .Item(Dn.Value)
       '[COLOR=green][B]The "Else " part of this code is invoked each time a particulat "key" is found again.[/B][/COLOR]
        '[COLOR=green][B]When this happens each Range in the ".item" array is added to by the "Union" function[/B][/COLOR]
        '[COLOR=green][B]So gradually the range object for each "Item" for each Unique key is enlarged.[/B][/COLOR]
        [COLOR=navy]Set[/COLOR] Q(0) = Union(Q(0), Dn(, 4))
        [COLOR=navy]Set[/COLOR] Q(1) = Union(Q(1), Dn(, 6))
        [COLOR=navy]Set[/COLOR] Q(2) = Union(Q(2), Dn(, 13))
        [COLOR=navy]Set[/COLOR] Q(3) = Union(Q(3), Dn(, 5))
        .Item(Dn.Value) = Q
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]Dim[/COLOR] K
[COLOR=navy]Dim[/COLOR] Rw
[COLOR=navy]Dim[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
 '[COLOR=green][B]We now have a Dictionary with a set of Keys representing each sheet name take from column "A".[/B][/COLOR]
 '[COLOR=green][B]Each Unique Key has an "Item", this being  an array of the Columns (4,6,13,5) each now set as a range object[/B][/COLOR]
 '[COLOR=green][B]containing  all the column/Row information relating to each unique Sheet Name[/B][/COLOR]
 
 '[COLOR=green][B]The following Loops through all the unique sheet names, each being a "Key" within the dictionary[/B][/COLOR]
 [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
   '[COLOR=green][B]This resets the column count to 0 as each new "Key" is looped[/B][/COLOR]
    Ac = 0
    '[COLOR=green][B]Headers placed on each Sheet Name[/B][/COLOR]
    Sheets(K).Range("A1").Resize(, 4) = Array("Job", "User", "Max RAM", "Status")
        '[COLOR=green][B]Loop through each "Item for each unique "Key"[/B][/COLOR]
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Rw [COLOR=navy]In[/COLOR] .Item(K)
            Ac = Ac + 1
            c = 1
          '[COLOR=green][B]As each "Item" with the "Item" Array is a "Range" we need to loop through each cell in each of these  ranges.[/B][/COLOR]
          [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] nRw [COLOR=navy]In[/COLOR] Rw
            '[COLOR=green][B]Rows incremented by value "c"[/B][/COLOR]
            '[COLOR=green][B]Range values "nRw" from Array "Items" placed on related sheet.[/B][/COLOR]
                c = c + 1
                Sheets(K).Cells(c, Ac) = nRw
            [COLOR=navy]Next[/COLOR] nRw
        [COLOR=navy]Next[/COLOR] Rw
 [COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With
MsgBox "Run"
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
michrome23,

Thanks for the feedback.

You are very welcome. Glad I could help.

Come back anytime.

Merry Christmas, happy holidays, and a Happy New Year.
 
Upvote 0

Forum statistics

Threads
1,221,310
Messages
6,159,173
Members
451,543
Latest member
cesymcox

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top