Converting multiple columns into rows with the same A column

Sort by date Sort by votes
hiker95 said:
cln014,

Here is a new macro for you to consider based on your answers to my questions.

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 ReorgDataV2()
' hiker95, 04/30/2015, ME852326
Dim w1 As Worksheet, wo As Worksheet
Dim a As Variant, o As Variant
Dim lr As Long, lc As Long
Dim i As Long, j As Long, c As Long, n As Long
Application.ScreenUpdating = False
Set w1 = Sheets("externalawards002008")   '<-- you can change the sheet name here
With w1
  .Activate
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, 1).End(xlToRight).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  ReDim o(1 To (UBound(a, 1) * ((lc - 1) / 3)), 1 To 4)
End With
j = j + 1
o(j, 1) = "CWID": o(j, 2) = "Scholarship Code"
o(j, 3) = "Scholarship Award": o(j, 4) = "Scholarship Award Amount"
For i = 2 To UBound(a, 1)
  For c = 2 To lc Step 3
    If a(i, c) = "" And a(i, c + 1) = "" And a(i, c + 2) = "" Then
      'do nothing
    Else
      j = j + 1
      o(j, 1) = a(i, 1): o(j, 2) = a(i, c)
      o(j, 3) = a(i, c + 1): o(j, 4) = a(i, c + 2)
    End If
  Next c
Next i
If Not Evaluate("ISREF(Output!A1)") Then Worksheets.Add(After:=w1).Name = "Output"
Set wo = Sheets("Output")
With wo
  .UsedRange.Clear
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
  .Activate
End With
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, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgDataV2 macro.
Click to expand...

There are three new columns that need to be pivoted. Can you help?

Here's the original file with the three new columns: https://app.box.com/s/vu0lekpdnxpvx1mr0adgbhrjdic7btmf

Those three new columns are First Name, Middle Name, and Last Name and they can be treated just as the other columns were. Thank you SO MUCH in advance!!!

Thanks!
 
Upvote 0

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
cln014,

No more Private Messages please.

Unless there is a particular reason to do so, it is best not to quote whole long replies like you did with mine. It makes the thread harder to navigate/read and just takes up unnecessary space.

1. Quote ONLY if it is needed to add clarity or context for your reply. If so, then
2. Quote ONLY the specific part of the post that is relevant - - not the entire post.

This will keep thread clutter to a minimum and make the discussion easier to follow.

And, when you respond to your helper, please use their site ID/username/handle.


3. Can you supply another workbook with the new raw data in its actual worksheet name?

4. And, can you supply worksheet Output, manually formatted by you for the new results you are looking for?
 
Upvote 0
cln014,

Here is a macro solution for you to consider, based on the new raw data structure, and, 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 ReorgDataV3()
' hiker95, 05/05/2015, ME852326
Dim w1 As Worksheet, wo As Worksheet
Dim a As Variant, o As Variant
Dim lr As Long, lc As Long
Dim i As Long, j As Long, c As Long, n As Long
Application.ScreenUpdating = False
Set w1 = Sheets("PowerFAIDS_Scholarship_Export")   '<-- you can change the sheet name here
With w1
  .Activate
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, 1).End(xlToRight).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  ReDim o(1 To (UBound(a, 1) * ((lc - 3) / 3)), 1 To 7)
End With
j = j + 1
o(j, 1) = "CWID": o(j, 2) = "Scholarship Code"
o(j, 3) = "Scholarship Award": o(j, 4) = "Scholarship Award Amount"
o(j, 5) = "First Name": o(j, 6) = "Middle Name": o(j, 7) = "": o(j, 7) = "Last Name"
For i = 2 To UBound(a, 1)
  For c = 2 To lc - 3 Step 3
    If a(i, c) = "" And a(i, c + 1) = "" And a(i, c + 2) = "" Then
      'do nothing
    Else
      j = j + 1
      o(j, 1) = a(i, 1): o(j, 2) = a(i, c)
      o(j, 3) = a(i, c + 1): o(j, 4) = a(i, c + 2)
      o(j, 5) = a(i, lc - 2): o(j, 6) = a(i, lc - 1): o(j, 7) = a(i, lc)
    End If
  Next c
Next i
If Not Evaluate("ISREF(Output!A1)") Then Worksheets.Add(After:=w1).Name = "Output"
Set wo = Sheets("Output")
With wo
  .UsedRange.Clear
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
  .Activate
End With
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, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgDataV3 macro.
 
Upvote 0
cln014,

Here is a new macro solution for you to consider, based on the new workbook in your reply #15.

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 ReorgDataV4()
' hiker95, 06/29/2015, ME852326
Dim w1 As Worksheet, wo As Worksheet
Dim a As Variant, o As Variant
Dim i As Long, j As Long
Dim lr As Long, lc As Long, n As Long, c As Long
Application.ScreenUpdating = False
Set w1 = Sheets("PowerFAIDS_Scholarship_Export")   '<-- you can change the sheet name here
With w1
  .Activate
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, 1).End(xlToRight).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  n = Application.CountA(.Range("B2:J" & lr)) / 3
  ReDim o(1 To n, 1 To 9)
End With
For i = 2 To UBound(a, 1)
  For c = 2 To 10 Step 3
    If a(i, c) = vbEmpty And a(i, c + 1) = vbEmpty And a(i, c + 2) = vbEmpty Then
      'do nothing
    Else
      j = j + 1
      o(j, 1) = a(i, 1): o(j, 2) = a(i, c): o(j, 3) = a(i, c + 1): o(j, 4) = a(i, c + 2)
      o(j, 5) = a(i, 11): o(j, 6) = a(i, 12): o(j, 7) = a(i, 13): o(j, 8) = a(i, 14): o(j, 9) = a(i, 15)
    End If
  Next c
Next i
If Not Evaluate("ISREF(Output!A1)") Then Worksheets.Add(After:=w1).Name = "Output"
Set wo = Sheets("Output")
With wo
  .UsedRange.Clear
  .Cells(1, 1).Resize(, 9).Value = Array("Social Security", "Scholarship Code", "Scholarship Award", _
      "Scholarship Award Amount", "First Name", "Middle Name", _
      "Last Name", "ADM-DT", "BDFW-DT")
  .Cells(2, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
  .Activate
End With
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, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgDataV4 macro.
 
Upvote 0
hiker95,

All the sudden when I run this macro I'm getting a "Run-time error '9': Subscript out of range". If I debug, it is having trouble at o(j, 1) = a(i, 1).

Thanks,
cln014
 
Upvote 0
cln014,

In order to continue I will have to see your actual raw data workbook/worksheet.

The following is a free site:

You can upload your workbook to (the BLUE link-->) Box Net ,

sensitive data changed

mark the workbook for sharing

and provide us with a link to your workbook.
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Solved
Evaluate each cell in a row against two other rows using VBA
Replies
5
Views
300
mumps
mumps
M
  • Solved
Looking for the longest run of zeros in a column
Replies
7
Views
247
RoryA
RoryA
W
  • Question
copy columns to other work sheet for variable number of rows
Replies
1
Views
235
Watersource
W
J
  • Question
Create multiple sheets based on Master sheet criteria
Replies
8
Views
318
mumps
mumps
G
  • Question
Macro to consolidate multiple worksheets into Master based on cell data?
Replies
1
Views
283
bobaol
B

Forum statistics

Threads
1,215,091
Messages
6,123,062
Members
449,090
Latest member
fragment

Share this page

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