Macro Copy rows to Another Sheet based on Heading

michrome23 · Dec 23, 2012

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

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

Example)
On Sheet ‘Raw Data’
A2 = Cache

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

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

[TABLE="width: 361"]
<tbody>[TR]
[TD] Job
[/TD]
[TD]User
[/TD]
[TD]Max RAM
[/TD]
[TD]Status
[/TD]
[/TR]
[TR]
[TD]2979857
[/TD]
[TD]Mike
[/TD]
[TD]9.5
[/TD]
[TD]complete
[/TD]
[/TR]
[TR]
[TD]2979863
[/TD]
[TD]John
[/TD]
[TD]3.3
[/TD]
[TD]complete
[/TD]
[/TR]
[TR]
[TD]2979864
[/TD]
[TD]Mike
[/TD]
[TD]16.1
[/TD]
[TD]complete
[/TD]
[/TR]
[TR]
[TD]2979866
[/TD]
[TD]Mike
[/TD]
[TD]5.2
[/TD]
[TD]complete
[/TD]
[/TR]
</tbody>[/TABLE]

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
[TABLE="width: 515"]
<tbody>[TR]
[TD]%
[/TD]
[TD]Job
[/TD]
[TD]Hours
[/TD]
[TD]Issue
[/TD]
[TD]Frames
[/TD]
[TD]Status
[/TD]
[/TR]
[TR]
[TD]11
[/TD]
[TD]2980158
[/TD]
[TD]7
[/TD]
[TD][/TD]
[TD][/TD]
[TD]running
[/TD]
[/TR]
[TR]
[TD]14
[/TD]
[TD]2980160
[/TD]
[TD]7
[/TD]
[TD][/TD]
[TD][/TD]
[TD]running
[/TD]
[/TR]
[TR]
[TD]100
[/TD]
[TD]2980411
[/TD]
[TD]1
[/TD]
[TD][/TD]
[TD][/TD]
[TD]complete
[/TD]
[/TR]
[TR]
[TD]100
[/TD]
[TD]2980420
[/TD]
[TD]1
[/TD]
[TD][/TD]
[TD][/TD]
[TD]complete
[/TD]
[/TR]
[TR]
[TD]100
[/TD]
[TD]2980422
[/TD]
[TD]1
[/TD]
[TD][/TD]
[TD][/TD]
[TD]complete
[/TD]
[/TR]
[TR]
[TD]100
[/TD]
[TD]2980423
[/TD]
[TD]1
[/TD]
[TD][/TD]
[TD][/TD]
[TD]complete
[/TD]
[/TR]
</tbody>[/TABLE]

In Sheet PRman
[TABLE="width: 318"]
<tbody>[TR]
[TD]User
[/TD]
[TD]Status
[/TD]
[TD]%
[/TD]
[TD]Job
[/TD]
[/TR]
[TR]
[TD]Bill
[/TD]
[TD]pending
[/TD]
[TD]97
[/TD]
[TD]2979389
[/TD]
[/TR]
[TR]
[TD]Jane
[/TD]
[TD]complete
[/TD]
[TD]100
[/TD]
[TD]2979828
[/TD]
[/TR]
[TR]
[TD]Jane
[/TD]
[TD]complete
[/TD]
[TD]100
[/TD]
[TD]2979905
[/TD]
[/TR]
[TR]
[TD]Jane
[/TD]
[TD]pending
[/TD]
[TD]95
[/TD]
[TD]2979945
[/TD]
[/TR]
[TR]
[TD]Jane
[/TD]
[TD]running
[/TD]
[TD]44
[/TD]
[TD]2979990
[/TD]
[/TR]
[TR]
[TD]Jane
[/TD]
[TD]complete
[/TD]
[TD]100
[/TD]
[TD]2979993
[/TD]
[/TR]
[TR]
[TD]Jane
[/TD]
[TD]complete
[/TD]
[TD]100
[/TD]
[TD]2980004
[/TD]
[/TR]
</tbody>[/TABLE]

MickG · Dec 23, 2012

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

JLGWhiz · Dec 23, 2012

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:

hiker95 · Dec 23, 2012

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

A

B

C

D

E

F

G

H

I

J

K

L

M

1

SHEET

Hours

%

Job

Status

User

Priority

Issue

Frames

Time Completed

Average Frame HH:MM

Avg RAM

Max RAM

2

Cache

19

100

2979857

complete

Mike

3000

Lighting Changes

101

Fri, Dec 21, at 06:21 PM

0:32

3.9

9.5

3

Cache

79

100

2979864

complete

Mike

100

Tex

Sat, Dec 22, at 02:09 AM

0:42

5.3

16.1

4

Cache

19

100

2979989

complete

John

100

Feather Penetrations

Most

Fri, Dec 21, at 07:47 PM

0:26

2.1

6.7

5

Cache

7

100

2980028

complete

John

3000

Shadow

All

Fri, Dec 21, at 07:15 PM

0:16

1.2

3.5

6

Cache

8

100

2980203

complete

Mike

2900

Missing Geo

All

Fri, Dec 21, at 08:32 PM

0:05

1.2

4.7

7

Cache

7

100

2980204

complete

Mike

2900

Missing Geo

All

Fri, Dec 21, at 08:37 PM

0:05

1.2

5

8

Cache

1

100

2980205

complete

Nick

2900

Fri, Dec 21, at 08:08 PM

0:01

0.3

1.7

9

Mantra

25

100

2979770

complete

Jane

100

Texture

All

Fri, Dec 21, at 10:46 PM

0:39

2.9

9.6

10

Mantra

40

99

2979777

running

Jane

100

Sat, Dec 22, at 03:03 AM

11

Mantra

50

100

2979780

complete

Jane

100

Penetrations

All

Fri, Dec 21, at 07:44 PM

0:16

2.3

8.6

12

Mantra

54

100

2979782

complete

Jane

100

Penetrations

All

Fri, Dec 21, at 08:41 PM

0:17

2

8.4

13

Misc

100

2979572

complete

Marcy

1500

Fri, Dec 21, at 06:05 PM

0:43

12

14

Misc

58

43

2979848

Pending

John

3100

N/A

15

Misc

72

97

2979867

Pending

John

100

N/A

16

Playblast

7

11

2980158

running

Jane

3000

Sat, Dec 22, at 11:25 AM

17

Playblast

7

14

2980160

running

Jane

3000

Sat, Dec 22, at 10:38 AM

18

Playblast

1

100

2980411

complete

Nick

2900

Fri, Dec 21, at 08:09 PM

0:00

0.5

0.7

19

Playblast

1

100

2980420

complete

Jane

2900

Fri, Dec 21, at 08:15 PM

0:00

0.4

0.7

20

Playblast

1

100

2980422

complete

Jane

2900

Fri, Dec 21, at 08:15 PM

0:00

0.5

0.7

21

Playblast

1

100

2980423

complete

Jane

100

Fri, Dec 21, at 08:15 PM

0:00

0.4

0.7

22

Playblast

6

100

2980432

complete

Jane

2800

Fri, Dec 21, at 09:10 PM

0:05

1.7

2.7

23

PRMan

79

97

2979389

pending

Bill

1500

N/A

24

PRMan

31

100

2979828

complete

Jane

3000

Fri, Dec 21, at 06:46 PM

0:49

2.2

8.8

25

PRMan

11

100

2979905

complete

Jane

100

Fri, Dec 21, at 10:16 PM

0:45

5.8

13.7

26

PRMan

4

95

2979945

pending

Jane

100

N/A

27

PRMan

41

44

2979990

running

Jane

100

Sat, Dec 22, at 05:46 AM

28

Raw Data

After the macro:

Excel Workbook

A

B

C

D

1

Job

User

Max RAM

Status

2

2979857

Mike

9.5

complete

3

2979864

Mike

16.1

complete

4

2979989

John

6.7

complete

5

2980028

John

3.5

complete

6

2980203

Mike

4.7

complete

7

2980204

Mike

5

complete

8

2980205

Nick

1.7

complete

9

Cache

Excel Workbook

A

B

C

D

E

F

1

%

Job

Hours

Issue

Frames

Status

2

11

2980158

7

running

3

14

2980160

7

running

4

100

2980411

1

complete

5

100

2980420

1

complete

6

100

2980422

1

complete

7

100

2980423

1

complete

8

100

2980432

6

complete

9

Playblast

Excel Workbook

A

B

C

D

1

User

Status

%

Job

2

Bill

pending

97

2979389

3

Jane

complete

100

2979828

4

Jane

complete

100

2979905

5

Jane

pending

95

2979945

6

Jane

running

44

2979990

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.

Hashiru · Dec 23, 2012

Hello Mick, can you please explain your code to me. Thanks

Hashiru · Dec 23, 2012

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

michrome23 · Dec 24, 2012

This worked perfectly thanks for all your help Hiker95

Merry Christmas

MickG · Dec 24, 2012

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

hiker95 · Dec 24, 2012

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.

Hashiru · Dec 24, 2012

hiker95 said:
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.

Thanks Mick

Macro Copy rows to Another Sheet based on Heading

michrome23

New Member

Excel Facts

MickG

MrExcel MVP

JLGWhiz

Well-known Member

hiker95

Well-known Member

Hashiru

Active Member

Hashiru

Active Member

michrome23

New Member

MickG

MrExcel MVP

hiker95

Well-known Member

Hashiru

Active Member

Similar threads

Forum statistics

Share this page

Macro Copy rows to Another Sheet based on Heading

New Member

Excel Facts

MrExcel MVP

Well-known Member

Well-known Member

Active Member

Active Member

New Member

MrExcel MVP

Well-known Member

Active Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock