Macro to move row data to columns

catmom · Apr 16, 2014

Thank you in advance for any help you can give me.

I have the following information extracted from a very old program:

[TABLE="width: 469"]
<TBODY>[TR]
[TD]Bob[/TD]
[TD]Eating[/TD]
[TD]Berries Verified[/TD]
[TD="colspan: 2"]February 28, 2014 7:47:24 AM CST[/TD]
[/TR]
[TR]
[TD]Bob[/TD]
[TD]Eating[/TD]
[TD]Apples Submitted[/TD]
[TD="colspan: 2"]October 10, 2012 3:31:18 PM CDT[/TD]
[/TR]
[TR]
[TD]Bob[/TD]
[TD]Eating[/TD]
[TD]Oranges Approved[/TD]
[TD="colspan: 2"]April 5, 2013 5:48:11 PM CDT[/TD]
[/TR]
[TR]
[TD]Bob[/TD]
[TD]Eating[/TD]
[TD]Berries Deploy[/TD]
[TD="colspan: 2"]January 29, 2014 9:59:14 AM CST[/TD]
[/TR]
[TR]
[TD]Bob[/TD]
[TD]Eating[/TD]
[TD]Apples Approved[/TD]
[TD="colspan: 2"]January 9, 2013 1:37:54 PM CST[/TD]
[/TR]
[TR]
[TD]Bob[/TD]
[TD]Eating[/TD]
[TD]Oranges Review[/TD]
[TD="colspan: 2"]January 15, 2013 11:31:41 AM CST[/TD]
[/TR]
</TBODY><COLGROUP><COL span=2><COL><COL><COL></COLGROUP>[/TABLE]

I need to get the data to look like this. I have been doing it cut and paste style and it is very time consuming. Is there a macro I can use to make it easier?

[TABLE="width: 1199"]
<TBODY>[TR]
[TD]Name[/TD]
[TD]Subject[/TD]
[TD]Apples Submitted[/TD]
[TD]Apples Approved[/TD]
[TD]Oranges Review[/TD]
[TD]Oranges Approved[/TD]
[TD]Grapes Start[/TD]
[TD]Grapes Completed[/TD]
[TD]Lemons Rev[/TD]
[TD]Lemons Baseline[/TD]
[TD]Berries Deploy[/TD]
[TD]Berries Verified[/TD]
[/TR]
[TR]
[TD]Bob[/TD]
[TD]Eating[/TD]
[TD="align: right"]10-Oct-12[/TD]
[TD="align: right"]9-Jan-13[/TD]
[TD="align: right"]15-Jan-13[/TD]
[TD="align: right"]5-Apr-13[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]29-Jan-14[/TD]
[TD="align: right"]28-Feb-14[/TD]
[/TR]
</TBODY><COLGROUP><COL span=2><COL><COL><COL><COL><COL><COL><COL><COL><COL><COL></COLGROUP>[/TABLE]

MickG · Apr 16, 2014

On the basis that your data lokks something like, in sheet 1 :-

Code:

[COLOR="RoyalBlue"][B]Row No [/B][/COLOR] [COLOR="RoyalBlue"][B]Col(A) [/B][/COLOR] [COLOR="RoyalBlue"][B]Col(B)  [/B][/COLOR] [COLOR="RoyalBlue"][B]Col(C)           [/B][/COLOR] [COLOR="RoyalBlue"][B]Col(D)     [/B][/COLOR]
1.      Name    Subject  Head Name         Head Date  
2.      Bob     Eating   Berries Verified  28/02/2014 
3.      Bob     Eating   Apples Submitted  10/10/2012 
4.      Bob     Eating   Oranges Approved  05/04/2013 
5.      Bob     Eating   Berries Deploy    29/01/2014 
6.      Bob     Eating   Apples Approved   09/01/2013 
7.      Bob     Eating   Oranges Review    15/01/2013

Try this code, for results on sheet2:-

Code:

[COLOR="Navy"]Sub[/COLOR] MG16Apr29
[COLOR="Navy"]Dim[/COLOR] oHd         [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Dic1        [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] H           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Nam         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare


oHd = Array("Name", " Subject", "Apples Submitted", "Apples Approved", "Oranges Review", _
    "Oranges Approved", "Grapes Start", "Grapes Completed", "Lemons Rev", _
        "Lemons Baseline", "Berries Deploy", "Berries Verified")
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] H [COLOR="Navy"]In[/COLOR] oHd: n = n + 1: Dic.Item(H) = n: [COLOR="Navy"]Next[/COLOR] H
n = 1
[COLOR="Navy"]Set[/COLOR] Dic1 = CreateObject("scripting.dictionary")
Dic1.CompareMode = vbTextCompare
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    .Range("A1").Resize(, 12) = oHd
    .Range("A1").Resize(, 12).Columns.AutoFit
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        Nam = Dn & Dn.Offset(, 1)
        [COLOR="Navy"]If[/COLOR] Not Dic1.Exists(Nam) [COLOR="Navy"]Then[/COLOR]
            n = n + 1
            Dic1.Add Nam, n
            .Cells(Dic1.Item(Nam), 1) = Dn
            .Cells(Dic1.Item(Nam), 2) = Dn.Offset(, 1)
            .Cells(Dic1.Item(Nam), Dic.Item(Dn.Offset(, 2).Value)) = Format(Dn.Offset(, 3), "dd/mm/yy")
        [COLOR="Navy"]Else[/COLOR]
           .Cells(Dic1.Item(Nam), Dic.Item(Dn.Offset(, 2).Value)) = Format(Dn.Offset(, 3), "dd/mm/yy")
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

catmom · Apr 16, 2014

Thank you for your time. I receive a "Run-time error '1004'.

.Cells(Dic1.Item(Nam), Dic.Item(Dn.Offset(, 2).Value)) = Format(Dn.Offset(, 3), "dd/mm/yy")

hiker95 · Apr 16, 2014

catmom,

With your raw data in Sheet1, the results will be in a new worksheet Results.

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
2. Open your NEW 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
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code:

Sub ReorgData()
' hiker95, 04/16/2014, ME771678
Dim w1 As Worksheet, wr As Worksheet
Dim c As Range, nrng As Range, trng As Range
Set w1 = Sheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Sheets("Results")
With wr
  .UsedRange.ClearContents
  w1.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wr.Columns("A:B"), Unique:=True
  .Cells(1, 1).Resize(, 12).Value = Array("Name", "Subject", "Apples Submitted", "Apples Approved", _
    "Oranges Review", "Oranges Approved", "Grapes Start", "Grapes Completed", _
    "Lemons Rev", "Lemons Baseline", "Berries Deploy", "Berries Verified")
  .Columns.AutoFit
End With
With w1
  For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    If c <> "" Then
      Set nrng = wr.Columns(1).Find(c, LookAt:=xlWhole)
      Set trng = wr.Rows(1).Find(c.Offset(, 2), LookAt:=xlWhole)
      If (Not nrng Is Nothing) * (Not trng Is Nothing) Then
        With wr.Cells(nrng.Row, trng.Column)
          .Value = c.Offset(, 3).Value
          .NumberFormat = "d-mmm-yy"
        End With
      End If
      Set nrng = Nothing: Set trng = Nothing
    End If
  Next c
End With
With wr
  .Columns.AutoFit
  .Activate
End With
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 ReorgData macro.

catmom · Apr 17, 2014

Thank you very much hiker95. This reorganizes the data into the columns exactly how I need them, it removes the extra lines, but I do not get any dates. Originally I had to use the following formula in order to get just the date and remove the time, but was unable to format it in order to sort it.

[TABLE="width: 239"]
<TBODY>[TR]
[TD]February 28, 2014 7:47:24 AM CST[/TD]
[/TR]
[TR]
[TD]I applied this formula: =LEFT(E1,LEN(E1)-SEARCH("",E1)-14)

The date appeared as: February 28, 2014, but I was unable to format it.

Sorry if this is confusing. [/TD]
[/TR]
</TBODY>[/TABLE]

hiker95 · Apr 17, 2014

catmom,

So the dates in column D are actually strings?

catmom · Apr 17, 2014

They are an export out of a very old program. I am unable to format them to anything. My only recourse was to apply the formula above in an ajacent cell, then use a datevalue formula in yet another cell.

hiker95 · Apr 17, 2014

catmom,

Thanks for the update.

Is the following secrenshot an accurate representation of what your raw data looks like?

Excel Workbook

A

B

C

D

1

Name

Subject

Title C

Date

2

Bob

Eating

Berries Verified

February 28, 2014 7:47:24 AM CST

3

Bob

Eating

Apples Submitted

October 10, 2012 3:31:18 PM CDT

4

Bob

Eating

Oranges Approved

April 5, 2013 5:48:11 PM CDT

5

Bob

Eating

Berries Deploy

January 29, 2014 9:59:14 AM CST

6

Bob

Eating

Apples Approved

January 9, 2013 1:37:54 PM CST

7

Bob

Eating

Oranges Review

January 15, 2013 11:31:41 AM CST

8

Sheet1

catmom · Apr 17, 2014

Correct.

hiker95 · Apr 17, 2014

catmom,

Sample raw data:

Excel Workbook

A

B

C

D

1

Name

Subject

Title C

Date

2

Bob

Eating

Berries Verified

February 28, 2014 7:47:24 AM CST

3

Bob

Eating

Apples Submitted

October 10, 2012 3:31:18 PM CDT

4

Bob

Eating

Oranges Approved

April 5, 2013 5:48:11 PM CDT

5

Bob

Eating

Berries Deploy

January 29, 2014 9:59:14 AM CST

6

Bob

Eating

Apples Approved

January 9, 2013 1:37:54 PM CST

7

Bob

Eating

Oranges Review

January 15, 2013 11:31:41 AM CST

8

Sheet1

After the macro in a new worksheet Results:
Excel Workbook
A B C D E F G H I J K L
1 Name Subject Apples Submitted Apples Approved Oranges Review Oranges Approved Grapes Start Grapes Completed Lemons Rev Lemons Baseline Berries Deploy Berries Verified
2 Bob Eating 10-Oct-12 9-Jan-13 15-Jan-13 5-Apr-13 29-Jan-14 28-Feb-14
3
Results

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).

Code:

Sub ReorgData_V2() ' hiker95, 04/17/2014, ME771678 Dim w1 As Worksheet, wr As Worksheet Dim c As Range, nrng As Range, trng As Range Dim t As String, s Set w1 = Sheets("Sheet1") If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results" Set wr = Sheets("Results") With wr .UsedRange.ClearContents w1.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wr.Columns("A:B"), Unique:=True .Cells(1, 1).Resize(, 12).Value = Array("Name", "Subject", "Apples Submitted", "Apples Approved", _ "Oranges Review", "Oranges Approved", "Grapes Start", "Grapes Completed", _ "Lemons Rev", "Lemons Baseline", "Berries Deploy", "Berries Verified") .Columns.AutoFit End With With w1 For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp)) If c <> "" Then Set nrng = wr.Columns(1).Find(c, LookAt:=xlWhole) Set trng = wr.Rows(1).Find(c.Offset(, 2), LookAt:=xlWhole) If (Not nrng Is Nothing) * (Not trng Is Nothing) Then With wr.Cells(nrng.Row, trng.Column) s = Split(c.Offset(, 3), " ") t = s(0) & " " & s(1) & " " & s(2) .Value = t .NumberFormat = "d-mmm-yy" End With End If Set nrng = Nothing: Set trng = Nothing End If Next c End With With wr .Columns.AutoFit .Activate End With 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 ReorgData_V2 macro.

Macro to move row data to columns

catmom

New Member

Excel Facts

MickG

MrExcel MVP

catmom

New Member

hiker95

Well-known Member

catmom

New Member

hiker95

Well-known Member

catmom

New Member

hiker95

Well-known Member

catmom

New Member

hiker95

Well-known Member

Similar threads

Forum statistics

Share this page

Macro to move row data to columns

New Member

Excel Facts

MrExcel MVP

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known 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