Transpose columns with multiple values into one column and matching the categories in row

Question

I have categories as listed in columns: Company name, 1st name, last name, number of units, unit 1, unit 2, unit 3, unit 4, family, email, etc. Each company has its on row. However some companies can have multiple units at the same time. I want to separate the companies by their units.

Picture of Sheet1.
When I start the VBA code, I want it to be copied to Sheet2 to look like the 2nd picture.

Everything on the spreadsheets are made up.

My code displaces the columns but doesn't condense the columns I want into one column.
Also, I don't know how to copy from sheet to sheet.

Sub Button2_Click()

Dim cr As Long 'current row
Dim cc As Long 'current column

For cr = 2 To 11
    For cc = 8 To 11 Step 2
        If Cells(cr, cc).Value = "R" Then
            'make column 13 (M) in current row = unit
            Cells(cr, 13).Value = Cells(1, cc).Value
        End If
    Next
Next
End Sub

Answer 1

Transform Data (Unpivot)

• Adjust (play with) the values in the constants section.

Option Explicit

Sub TransformData()

    ' 1. Define constants (the arrays obviously aren't constants).

    ' s - source (read from)
    ' sd - source data (no headers)
    ' d - destination (write to)
    ' r - row
    ' c - column
    ' u - unpivot (columns)
    ' v - value (columns)
    
    ' Source
    Const sName As String = "Sheet1"
    ' These columns will be unpivoted...
    Dim suCols() As Variant: suCols = VBA.Array(8, 9, 10, 11)
    ' ... while these columns will be just copied except for the 0 column...
    Dim svCols() As Variant: svCols = VBA.Array(12, 4, 0, 5, 6, 2, 3)
    ' which is a 'place holder' for the pivot column.
    ' The 'svCols' array 'tells' that column 12 will be written to column 1,
    ' column 4 will be written to column 2, the unpivot columns will be written
    ' to column 3, ... etc.
    
    ' Destination
    Const dName As String = "Sheet2"
    Const dFirstCellAddress As String = "A1"
    Const duTitle As String = "Unit Name"

    ' 2. Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' 3. Reference the source worksheet ('sws'), the source range ('srg')
    ' and the source data range ('sdrg'). Also, write the number of rows
    ' of each of the ranges to variables ('srCount', 'sdrCount')
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' has headers
    Dim srCount As Long: srCount = srg.Rows.Count ' incl. headers
    Dim sdrCount As Long: sdrCount = srCount - 1 ' excl. headers
    Dim sdrg As Range: Set sdrg = srg.Resize(sdrCount).Offset(1) ' no headers
    
    ' 4. The Number of Destination Rows and Columns
    
    ' Determine the number of destination rows ('drCount').
    
    Dim suUpper As Long: suUpper = UBound(suCols)
    Dim drCount As Long: drCount = 1 ' headers
    
    Dim su As Long
    
    For su = 0 To suUpper
        drCount = drCount + sdrCount _
            - Application.CountBlank(sdrg.Columns(suCols(su)))
    Next su
    
    ' Determine the number of destination columns ('dcCount').
    Dim svUpper As Long: svUpper = UBound(svCols)
    Dim dcCount As Long: dcCount = svUpper + 1
    
    ' 5. The 2D One-Based Arrays
    
    ' Write the values from the source range to an array ('sData').
    Dim sData As Variant: sData = srg.Value
    
    ' Define the destination array ('dData').
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    ' 6. Write the values from the source array to the destination array.
    
    ' Write headers.
    
    Dim sValue As Variant
    Dim sv As Long
    
    For sv = 0 To svUpper
        If svCols(sv) = 0 Then ' unpivot
            sValue = duTitle
        Else ' value
            sValue = sData(1, svCols(sv))
        End If
        dData(1, sv + 1) = sValue
    Next sv
    
    ' Write data.
    
    Dim dr As Long: dr = 1 ' headers are already written
    
    Dim sr As Long
    
    For sr = 2 To srCount
        For su = 0 To suUpper
            sValue = sData(sr, suCols(su))
            If Not IsEmpty(sValue) Then
                dr = dr + 1
                For sv = 0 To svUpper
                    If svCols(sv) = 0 Then ' unpivot
                        sValue = sData(sr, suCols(su))
                    Else ' value
                        sValue = sData(sr, svCols(sv))
                    End If
                    dData(dr, sv + 1) = sValue
                Next sv
            End If
        Next su
    Next sr
    
    ' 7. Write the results to the destination worksheet.
    
    ' Reference the destination worksheet.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    ' Clear previous data.
    dws.Cells.Clear
    
    ' Write the new values.
    With dws.Range(dFirstCellAddress).Resize(, dcCount)
        ' Write the values from the destination array
        ' to the destination worksheet.
        .Resize(drCount).Value = dData
        ' Apply simple formatting:
        ' Headers.
        .Font.Bold = True
        ' Entire Columns
        .EntireColumn.AutoFit
    End With
    
    ' Save the workbook.
    'wb.Save
    
    ' 8. Inform to not wonder if the code has run or not.
    
    MsgBox "Data transformed.", vbInformation
    
End Sub

Answer 2

VBA here is a sledgehammer to crack a nut.

It is easily done with a Pivot Table.
To get the rows with multiple units to have separate records for each unit: in M1 put Use_Unit.
In M2 =H2 and drag down.
Then in a area below the current data (say starting at row 1002):
In A1002 =A2 and drag across and down, except that in M1002 put =if(I2="","Ignore", I2) (or I1002).
Similarly for third and fourth blocks, looking ad J and K respectively.
Then do the Pivot Table, and filter out Unit_Use = Ignore