Excel converting columns to rows

Question

I have a large Excel sheet (approx 150 columns x 7000 rows and growing every day) but need to extract information in a better way. I don't have access to database software, only Excel. I've managed to get the result I want using normal Formulas, but the file size is almost 100mB (up from 4mB originally) and not workable - it's just too slow. I created a pivot table that only partially solves the problem. I'm new to VBA, so I tried a few examples on here to try to learn but most are too complex for me at the moment. In theory, "Convert row with columns of data into column with multiple rows in Excel" looks to partially resolve my problem, but I just can't get it to run! While I can see the code in the module, it does not appear in the macro list when I press the run button. Here is what I'm starting with-

Name1   Name2   Location    Subject1    Subject2    Subject3
Fred    Jones   England     Spanish     Maths       English
Peter   Brown   Germany     English     (empty)     Maths
Erik    Strong  Sweden      Chemistry   English     Biology

Required result -

Name1   Name2   Location    No.         Type    
Fred    Jones   England     Subject1    Spanish 
Fred    Jones   England     Subject2    Maths   
Fred    Jones   England     Subject3    English 
Peter   Brown   Germany     Subject1    English 
Peter   Brown   Germany     Subject3    Maths   
Erik    Strong  Sweden      Subject1    Chemistry   
Erik    Strong  Sweden      Subject2    English 
Erik    Strong  Sweden      Subject3    Biology 

Can anyone help please? Thank you!

Answer 1

I want to share a script I use regularly. Use it when you have multiple transactions, events, etc. on a single row when you want every transaction, event, etc. on a separate row. It takes columns that contain the same data type (ex. Subject1, Subject2, Subject3...) and need to be combined into one column (ex. Subject) across multiple rows.

In other words, your data that looks like this:

Name   Location   Subject1   Subject2   Subject3

Will look like this:

Name   Location   Subject1
Name   Location   Subject2
Name   Location   Subject3

This script assumes that your fixed column(s) are on the left and the columns to be combined (and split out into multiple rows) follow on the right. I hope this helps!

Option Explicit

Sub MatrixConverter2_2()

' Macro created 11/16/2005 by Peter T Oboyski (updated 8/24/2006)
'
' *** Substantial changes made by Chris Brackett (updated 8/3/2016) ***
'
' You are welcome to redistribute this macro, but if you make substantial
' changes to it, please indicate so in this section along with your name.
' This Macro converts matrix-type spreadsheets (eg. plot x species data) into column data
' The new (converted) spreadsheet name is "DB of 'name of active spreadsheet'"
' The conversion allows for multiple header rows and columns.

'--------------------------------------------------
' This section declares variables for use in the script

Dim book, head, cels, mtrx, dbase, v, UserReady, columnsToCombine, RowName, DefaultRowName, DefaultColName1, DefaultColName2, ColName As String
Dim defaultHeaderRows, defaultHeaderColumns, c, r, selectionCols, ro, col, newro, newcol, rotot, coltot, all, rowz, colz, tot As Long
Dim headers(100) As Variant
Dim dun As Boolean


'--------------------------------------------------
' This section sets the script defaults

defaultHeaderRows = 1
defaultHeaderColumns = 2

DefaultRowName = "Activity"

'--------------------------------------------------
' This section asks about data types, row headers, and column headers

UserReady = MsgBox("Have you selected the entire data set (not the column headers) to be converted?", vbYesNoCancel)
If UserReady = vbNo Or UserReady = vbCancel Then GoTo EndMatrixMacro

all = MsgBox("Exclude zeros and empty cells?", vbYesNoCancel)
If all = vbCancel Then GoTo EndMatrixMacro


' UN-COMMENT THIS SECTION TO ALLOW FOR MULTIPLE HEADER ROWS
rowz = 1
' rowz = InputBox("How many HEADER ROWS?" & vbNewLine & vbNewLine & "(Usually 1)", "Header Rows & Columns", defaultHeaderRows)
' If rowz = vbNullString Then GoTo EndMatrixMacro

colz = InputBox("How many HEADER COLUMNS?" & vbNewLine & vbNewLine & "(These are the columns on the left side of your data set to preserve as is.)", "Header Rows & Columns", defaultHeaderColumns)
If colz = vbNullString Then GoTo EndMatrixMacro


'--------------------------------------------------
' This section allows the user to provide field (column) names for the new spreadsheet

selectionCols = Selection.Columns.Count ' get the number of columns in the selection
For r = 1 To selectionCols
    headers(r) = Selection.Cells(1, r).Offset(rowOffset:=-1, columnOffset:=0).Value ' save the column headers to use as defaults for user provided names
Next r

colz = colz * 1
columnsToCombine = "'" & Selection.Cells(1, colz + 1).Offset(rowOffset:=-1, columnOffset:=0).Value & "' to '" & Selection.Cells(1, selectionCols).Offset(rowOffset:=-1, columnOffset:=0).Value & "'"

Dim Arr(20) As Variant
newcol = 1
For r = 1 To rowz
    If r = 1 Then RowName = DefaultRowName
    Arr(newcol) = InputBox("Field name for the fields/columns to be combined" & vbNewLine & vbNewLine & columnsToCombine, , RowName)
    If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro
    newcol = newcol + 1
Next
For c = 1 To colz
    ColName = headers(c)
    Arr(newcol) = InputBox("Field name for column " & c, , ColName)
    If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro
    newcol = newcol + 1
Next
Arr(newcol) = "Data"
v = newcol

'--------------------------------------------------
' This section creates the new spreadsheet, names it, and color codes the new worksheet tab

mtrx = ActiveSheet.Name
Sheets.Add After:=ActiveSheet
dbase = "DB of " & mtrx

'--------------------------------------------------
' If the proposed worksheet name is longer than 28 characters, truncate it to 29 characters.
    If Len(dbase) > 28 Then dbase = Left(dbase, 28)


'--------------------------------------------------
' This section checks if the proposed worksheet name
'  already exists and appends adds a sequential number
'  to the name
    Dim sheetExists As Variant
    Dim Sheet As Worksheet
    Dim iName As Integer

    Dim dbaseOld As String
    dbaseOld = dbase    ' save the original proposed name of the new worksheet

    iName = 0

    sheetExists = False
CheckWorksheetNames:

    For Each Sheet In Worksheets    ' loop through every worksheet in the workbook
        If dbase = Sheet.Name Then
            sheetExists = True
            iName = iName + 1
            dbase = Left(dbase, Len(dbase) - 1) & " " & iName
            GoTo CheckWorksheetNames
            ' Exit For
        End If
    Next Sheet


'--------------------------------------------------
' This section notify the user if the proposed
' worksheet name is already being used and the new
' worksheet was given an alternate name

    If sheetExists = True Then
        MsgBox "The worksheet '" & dbaseOld & "' already exists.  Renaming to '" & dbase & "'."
    End If


'--------------------------------------------------
' This section creates and names a new worksheet
    On Error Resume Next    'Ignore errors
        If Sheets("" & Range(dbase) & "") Is Nothing Then   ' If the worksheet name doesn't exist
            ActiveSheet.Name = dbase    ' Rename newly created worksheet
        Else
            MsgBox "Cannot name the worksheet '" & dbase & "'.  A worksheet with that name already exists."
            GoTo EndMatrixMacro
        End If
    On Error GoTo 0         ' Resume normal error handling

    Sheets(dbase).Tab.ColorIndex = 41 ' color the worksheet tab


'--------------------------------------------------
' This section turns off screen and calculation updates so that the script
' can run faster.  Updates are turned back on at the end of the script.
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False


'--------------------------------------------------
'This section determines how many rows and columns the matrix has

dun = False
rotot = rowz + 1
Do
    If (Sheets(mtrx).Cells(rotot, 1) > 0) Then
        rotot = rotot + 1
    Else
        dun = True
    End If
Loop Until dun
rotot = rotot - 1

dun = False
coltot = colz + 1
Do
    If (Sheets(mtrx).Cells(1, coltot) > 0) Then
        coltot = coltot + 1
    Else
        dun = True
    End If
Loop Until dun
coltot = coltot - 1


'--------------------------------------------------
'This section writes the new field names to the new spreadsheet

For newcol = 1 To v
    Sheets(dbase).Cells(1, newcol) = Arr(newcol)
Next


'--------------------------------------------------
'This section actually does the conversion

tot = 0
newro = 2
For col = (colz + 1) To coltot
    For ro = (rowz + 1) To rotot 'the next line determines if data are nonzero
        If ((Sheets(mtrx).Cells(ro, col) <> 0) Or (all <> 6)) Then   'DCB modified ">0" to be "<>0" to exclude blank and zero cells
            tot = tot + 1
            newcol = 1
            For r = 1 To rowz            'the next line copies the row headers
                Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(r, col)
                newcol = newcol + 1
            Next
            For c = 1 To colz         'the next line copies the column headers
                Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, c)
                newcol = newcol + 1
            Next                                'the next line copies the data
            Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, col)
            newro = newro + 1
        End If
    Next
Next


'--------------------------------------------------
'This section displays a message box with information about the conversion

book = "Original matrix = " & ActiveWorkbook.Name & ": " & mtrx & Chr(10)
head = "Matrix with " & rowz & " row headers and " & colz & " column headers" & Chr(10)
cels = tot & " cells of " & ((rotot - rowz) * (coltot - colz)) & " with data"


'--------------------------------------------------
' This section turns screen and calculation updates back ON.
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


MsgBox (book & head & cels)


'--------------------------------------------------
' This is an end point for the macro

EndMatrixMacro:

End Sub

Answer 2

You can use the transpose function, both with and without VBA. Here's a code I just threw together:

Sub test()
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
lastColumn = ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Column
Dim rng As Range
With Sheets("Sheet2")                   ' the destination sheet
Set rng = .Range(.Cells(1, 1), .Cells(lastColumn, lastRow))
End With
rng.Value = _
Application.Transpose(ActiveSheet.Range(Cells(1, 1), Cells(lastRow, lastColumn)))
End Sub