Macro to move row data to columns

catmom

New Member
Joined
Apr 16, 2014
Messages
9
Thank you in advance for any help you can give me.

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

Bob</SPAN>Eating</SPAN>Berries Verified</SPAN>February 28, 2014 7:47:24 AM CST</SPAN>
Bob</SPAN>Eating</SPAN>Apples Submitted</SPAN>October 10, 2012 3:31:18 PM CDT</SPAN>
Bob</SPAN>Eating</SPAN>Oranges Approved</SPAN>April 5, 2013 5:48:11 PM CDT</SPAN>
Bob</SPAN>Eating</SPAN>Berries Deploy</SPAN>January 29, 2014 9:59:14 AM CST</SPAN>
Bob</SPAN>Eating</SPAN>Apples Approved</SPAN>January 9, 2013 1:37:54 PM CST</SPAN>
Bob</SPAN>Eating</SPAN>Oranges Review</SPAN>January 15, 2013 11:31:41 AM CST</SPAN>

<TBODY>
</TBODY><COLGROUP><COL span=2><COL><COL><COL></COLGROUP>


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?


Name</SPAN>Subject</SPAN>Apples Submitted</SPAN>Apples Approved</SPAN>Oranges Review</SPAN>Oranges Approved</SPAN>Grapes Start</SPAN>Grapes Completed</SPAN>Lemons Rev</SPAN>Lemons Baseline</SPAN>Berries Deploy</SPAN>Berries Verified</SPAN>
Bob</SPAN>Eating</SPAN>10-Oct-12</SPAN>9-Jan-13</SPAN>15-Jan-13</SPAN>5-Apr-13</SPAN>29-Jan-14</SPAN>28-Feb-14</SPAN>

<TBODY>
</TBODY><COLGROUP><COL span=2><COL><COL><COL><COL><COL><COL><COL><COL><COL><COL></COLGROUP>
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
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
 
Upvote 0
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")
 
Upvote 0
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.
 
Upvote 0
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.

February 28, 2014 7:47:24 AM CST</SPAN>
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.

<TBODY>
</TBODY>
 
Upvote 0
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.
 
Upvote 0
catmom,

Thanks for the update.


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

Excel Workbook
ABCD
1NameSubjectTitle CDate
2BobEatingBerries VerifiedFebruary 28, 2014 7:47:24 AM CST
3BobEatingApples SubmittedOctober 10, 2012 3:31:18 PM CDT
4BobEatingOranges ApprovedApril 5, 2013 5:48:11 PM CDT
5BobEatingBerries DeployJanuary 29, 2014 9:59:14 AM CST
6BobEatingApples ApprovedJanuary 9, 2013 1:37:54 PM CST
7BobEatingOranges ReviewJanuary 15, 2013 11:31:41 AM CST
8
Sheet1
 
Upvote 0
catmom,

Sample raw data:

Excel Workbook
ABCD
1NameSubjectTitle CDate
2BobEatingBerries VerifiedFebruary 28, 2014 7:47:24 AM CST
3BobEatingApples SubmittedOctober 10, 2012 3:31:18 PM CDT
4BobEatingOranges ApprovedApril 5, 2013 5:48:11 PM CDT
5BobEatingBerries DeployJanuary 29, 2014 9:59:14 AM CST
6BobEatingApples ApprovedJanuary 9, 2013 1:37:54 PM CST
7BobEatingOranges ReviewJanuary 15, 2013 11:31:41 AM CST
8
Sheet1


After the macro in a new worksheet Results:
Excel Workbook
ABCDEFGHIJKL
1NameSubjectApples SubmittedApples ApprovedOranges ReviewOranges ApprovedGrapes StartGrapes CompletedLemons RevLemons BaselineBerries DeployBerries Verified
2BobEating10-Oct-129-Jan-1315-Jan-135-Apr-1329-Jan-1428-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.
 
Upvote 0

Forum statistics

Threads
1,213,514
Messages
6,114,078
Members
448,547
Latest member
arndtea

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