Reputation: 21

VBA: Copy values from 2 or more columns into one column with a corresponding row

I am quite new to VBA and would like to do the following but not sure how:

First, I delimit data separated by commas. (this one is fine as I can do it with the record macro option as well)

The problem is that I would also like to transpose the information from each row to a column, with the rows being one under the other. However, I would also like to add the corresponding row to the data before it was delimited. Here is an example: Example

Upvotes: 2

Answers (2)

JB-007

Reputation: 2441

SOLVED!! (2 STEPS)

(A) QUICK-START GUIDE

Google-sheets (screenshots below) here (perma-link, self-same content / functions included below in any case!). Key for labels 1 & 2:

Label 1 (e.g. 'country' in original Q - font colour = blue in screenshots below)
Label 2 (e.g. 'fruit' in original Q - font colour = green in screenshots below)

(B) STEPS 1-2

(preface: may as well be entitled 'two-function' soln...)

STEP 1: FILTERXML as dynamic array applied to Label 1 in first instance (ref: 8 ways to split text by delimiter - J./ MacDougall Note: this is one of 2 methods that shall be considered for Step 1.

FilterXML screenshot

FilterXML function in the context of above screenshot:

=FILTERXML("<t><s>"&SUBSTITUTE(ARRAYTOTEXT(D6:D10),",","</s><s>")&"</s></t>","//s")

STEP 2. INDEX-ARRAY (map Label 1 values to corresponding Label 2 values after applying FILTERXML step)

Utilises new Excel 'array' feature which only requires populating first cell - array produced this way will then 'fill down' into adjacent cells as req.
Note: 'old' array functionality can still be used / adopted by typing function into first cell, then pressing 'ctrl'+'alt'+'enter'.
Doing so may restrict ability to use hash references for arrays as I've done here
Index can often be seen with match component / function. In this case, match lookup value utilises '*' wildcards (this feature makes match functions exceptionally versatile)

Index-Array screenshot

Index-Array function in the context of above screenshot:

=INDEX($C$6:$C$10,MATCH("*"&D16#&"*",$D$6:$D$10,0))[5]

(C) OTHER VIABLE TECHNIQUES

Viable in context of other priorities, budget, etc.

i) VB Code

Effectively based upon self-same formulation already provided - hence the 'sub' name'... :)

Modify/adjust as you deem fit/as req.

Sub Boring_Split_Code():
    ActiveCell.Formula2R1C1 = _
        "=FILTERXML(""<t><s>""&SUBSTITUTE(ARRAYTOTEXT(R[-12]C:R[-8]C),"","",""</s><s>"")&""</s></t>"",""//s"")"
    Range("C22").Select
    'Application.CutCopyMode = False
    ActiveCell.Formula2R1C1 = _
        "=INDEX(R10C3:R14C3,MATCH(""*""&RC[1]#&""*"",R10C4:R14C4,0))"
End Sub

ii) VB 'mechanical-unpivot' method

Ref: O. Cronquist
Imagine this is what you were after when Q first posted
However, only features after my 'boring' sub above given I strongly recommend using a more elegant solution (e.g. FilterXML / Index-Array)
Devil's advocate: this approach may still prove preferable depending on use-case / objective
Caveats abound - may require 'tweaking' or post-execution manipulation to address 'blank' cells
Recommend using 'unique() Excel formula to address if/as req.- see here for further detail re: 'unique' function

Sub Unpivot()
'
' Unpivot Macro
' Creates pivot flat file source format from table with rows and columns

Dim rng As Range
Dim Ws As Worksheet

On Error Resume Next
Set rng = Application.InputBox(Prompt:="Select a range to normalize data" _
, Title:="Select a range", Default:=ActiveCell.address, Type:=8)
On Error GoTo 0

If rng Is Nothing Then
Else
    Application.ScreenUpdating = False
    Set Ws = Sheets.Add
    i = 0
    For r = 1 To rng.Rows.Count - 1
        For c = 1 To rng.Columns.Count - 1
            Ws.Range("A1").Offset(i, 0) = rng.Offset(0, c).Value
            Ws.Range("A1").Offset(i, 1) = rng.Offset(r, 0).Value
            Ws.Range("A1").Offset(i, 2) = rng.Offset(r, c).Value
            i = i + 1
        Next c
    Next r
    Ws.Range("A:C").EntireColumn.AutoFit
    Application.ScreenUpdating = True
End If
End Sub

iii) Popular Mid / Match variants...

Less elegant alternate to 'funky' FilterXML method
(index-array method/equivalent still required)

Mid-Match (Step 1, Method 2) screenshot

Mid-Match functions

In the context of recent above screenshot:

= SUBSTITUTE(ARRAYTOTEXT(D6:D10)," ","")

Primes/prepares raw data for mid/substitute/search applications...

= MID(E23,1,SEARCH(",",E23)-1)

Initiates recursive substitute method, defined as follows (data rows 2+):

 = MID( SUBSTITUTE(E$23, CONCAT(E$24:E24 & "," ), ""  ), 1, IFERROR( SEARCH( ",", SUBSTITUTE(E$23, CONCAT( E$24:E24 & "," ),"" ) ) - 1, LEN( $E$23 ) ) )

Upvotes: 1

VBasic2008

Reputation: 54807

Unpivot 'Comma' Separated

Sample Data

Country;Fruits
France;Apple,Oranges
Germany;Oranges,Bananas
UK;Grapes,Lemons
Sweden;Mandarines,Strawberries,Bananas, Apples

Create (OP)

=IF(A1="","",A1&";"&B1)

Copy (CTRL+C) the range and paste (CTRL+V) it into NotePad.
Select All and Copy (CTRL+A, CTRL+C)
Paste here (CTRL+V).
Select the whole text and either click the code sample icon ({}) or use CTRL+K.

Use (User)

Select the text and copy (CTRL+C),
Right-click the first cell (A1) and Paste (Match Destination Formatting),
Data > TextToColumns,
Next,
Delimiter: check Semicolon
Finish

Program

Usage/Features

Caution: If you use the same worksheets and the same first cell addresses, you will be overwriting.
Note that there is no Undo.
Adjust the values of the four constants.
Open the Immediate window (CTRL+G) to see the range addresses at the various stages.
Application.Trim will cover any redundant spaces like the one in Swedish apples.

The Code

Option Explicit

Sub unpivotCommaSeparated()
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "A1"
    
    Const dName As String = "Sheet1"
    Const dFirst As String = "D1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sData As Variant
    Dim rg As Range
    Dim isDataInArray As Boolean
    
    With wb.Worksheets(sName).Range(sFirst)
        Debug.Print "Source First Cell:                " & .Address(0, 0)
        Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not rg Is Nothing Then
            Debug.Print "Source Last Cell in First Column: " & rg.Address(0, 0)
            Set rg = .Resize(rg.Row - .Row + 1, 2)
            Debug.Print "Source Range:                     " & rg.Address(0, 0)
            sData = rg.Value
            isDataInArray = True
        End If
    
    End With
    
    If isDataInArray Then
        
        Dim srCount As Long: srCount = UBound(sData, 1)
        Dim cCount As Long: cCount = UBound(sData, 2)
        ReDim Preserve sData(1 To srCount, 1 To cCount + 1)
        
        Dim drCount As Long: drCount = 1
        Dim i As Long
        
        For i = 2 To srCount
            sData(i, 2) = Split(sData(i, 2), ",")
            sData(i, 3) = UBound(sData(i, 2))
            drCount = drCount + sData(i, 3) + 1
        Next i
        
        Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
        Dim j As Long
        
        For j = 1 To cCount
            dData(1, j) = sData(1, j)
        Next j
            
        Dim k As Long: k = 1
        
        For i = 2 To srCount
            For j = 0 To sData(i, 3)
                k = k + 1
                dData(k, 1) = sData(i, 1)
                dData(k, 2) = Application.Trim(sData(i, 2)(j))
            Next j
        Next i
    
        With wb.Worksheets(dName).Range(dFirst).Resize(, cCount)
            Debug.Print "Destination First Row Range:      " & .Address(0, 0)
            Set rg = .Resize(k)
            Debug.Print "Destination Range:                " & rg.Address(0, 0)
            rg.Value = dData
            Set rg = .Resize(.Worksheet.Rows.Count - .Row - k + 1).Offset(k)
            Debug.Print "Clear Range:                      " & rg.Address(0, 0)
            rg.ClearContents
        End With
    
    End If
    
End Sub