Normalize Excel data

I have data that looks like this in Excel

name      status     column1     column2      column3

I need the data to be transformed into

name    status     column1
name    status     column2
name    status     column3

The file has 75 rows and 34 columns that need to be transposed.
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

byundtMechanical EngineerCommented:
I generalized the sub so it could handle any number of fixed columns (name and status in your example) and variable columns (column1 through column 32 in your example). The macro asks the user to pick the data, header labels and destination of results.

If one of your Column1 through Column32 fields is blank, a new row for that datum will not be created.

You didn't request it, but most people asking a question like this need a fourth column that specifies which type of data is in the third column (e.g. Column1, Column2, etc.). The macro adds that column for you.
Sub Normalizer()
Dim rg As Range, rgHeaders As Range, targ As Range
Dim v As Variant, vHeaders As Variant, vv As Variant
Dim i As Long, j As Long, jj As Long, k As Long, nCols As Long, nFixedCols As Long, nRows As Long
nFixedCols = 2      'Each row  of reformatted data will have this many fixed columns. Another two columns will include the variable data & type.
On Error Resume Next
Set rg = Application.InputBox("Please select your data", Default:=Range("A1").CurrentRegion.Address, Type:=8)
If rg Is Nothing Then Exit Sub
Set rgHeaders = Application.InputBox("Please select your header labels", Default:=rg.Rows(1).Address, Type:=8)
Set targ = Application.InputBox("Where do you want results to go?", Default:=rg.Cells(1).Address, Type:=8)
If targ Is Nothing Then Exit Sub
On Error GoTo 0
Set rg = Intersect(rg.Worksheet.UsedRange, rg)
If Not rgHeaders Is Nothing Then
    Set rgHeaders = Intersect(rgHeaders, rg.EntireColumn)
    If rg.Row = rgHeaders.Row Then Set rg = rg.Offset(1, 0).Resize(rg.Rows.Count - 1)
End If
nCols = rg.Columns.Count
nRows = rg.Rows.Count
ReDim vHeaders(1 To nCols)
For j = 1 To nCols
    If rgHeaders Is Nothing Then
        vHeaders(j) = "Column " & j
        vHeaders(j) = rgHeaders.Cells(1, j).Value
    End If
v = rg.Value
ReDim vv(1 To nRows * (nCols - nFixedCols), 1 To nFixedCols + 2)
For i = 1 To nRows
    For j = nFixedCols + 1 To nCols
        If v(i, j) <> "" Then
            k = k + 1
            For jj = 1 To nFixedCols
                vv(k, jj) = v(i, jj)
            vv(k, nFixedCols + 1) = v(i, j)
            vv(k, nFixedCols + 2) = vHeaders(j)
        End If
ReDim Preserve vv(1 To k, 1 To nFixedCols + 2)
If Not Intersect(rg, targ.Resize(2)) Is Nothing Then
    If Not rgHeaders Is Nothing Then rgHeaders.ClearContents
End If
For jj = 1 To nFixedCols
    targ.Cells(1, jj).Value = vHeaders(jj)
targ.Cells(1, nFixedCols + 1).Value = "Value"       'Change label to suit
targ.Cells(1, nFixedCols + 2).Value = "Type"        'Change label to suit
targ.Cells(2, 1).Resize(k, nFixedCols + 2).Value = vv
End Sub

Open in new window


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
smolbeck367Author Commented:
byundt - this worked beautifully. I adjusted it to fit the number of columns my data had and ran it this morning. Thank you very much for the help. This has saved me a significant amount of time. I have a few more tweaks to make to my spreadsheet in order to call it complete but this got me 80 % there.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Applications

From novice to tech pro — start learning today.