Copy multiple columns and paste into one column, based on row criteria

**Miki1989** · 06-17-2015, 06:10 AM

Hi,
I am newbie in VBA, but know excel formulas in advance level.. So I will appreciate any help and supported provided..
I have searched the forums for what I need but nothing was matching

So,
I have an excel sheet with several rows and columns.
In each row there are City name & Dates and in each columns have sales by different Units (A1, A2, A3 etc..)

Please find below raw data:
on3ZP0W.jpg

What I want to see is :
jB8wdEN.jpg

Also you can download workbook from following link: https://app.box.com/s/kj3fixsl13cfikhgt15p7fr63ogzdnvs
There is two sheet - Raw Data & What I want to see

Thank you in advance!!!!

**GC Excel** · 06-17-2015, 06:57 AM

Hello,

Try this code:
(change the input range and output destination cell as required)

Sub FlatData()
    Dim ar, arF
    Dim i As Long, j As Long, n As Long

    ar = Sheets(1).Range("B2").CurrentRegion.Value  'Range of data
    n = UBound(ar, 2)

    ReDim arF(1 To UBound(ar, 1) * n, 1 To 3)
    n = 1
    For i = 2 To UBound(ar, 1)   '2 to skip header row
        For j = 3 To UBound(ar, 2)
            arF(n, 1) = ar(i, 1)
            arF(n, 2) = ar(i, 2)
            If ar(i, j) <> "" Then
                arF(n, 3) = ar(i, j)
                n = n + 1
            End If
        Next j
    Next i
    Sheets(2).Cells(1).Resize(n - 1, 3) = arF 'Output to different sheet (must exist)

End Sub

**Kamboj** · 06-17-2015, 07:33 AM

use can use this code with a new sheet name Data

Sub copy_mlt_2_onecol()
a = 3
n = 4
b = 3
Do Until b = 833
Do Until n = 31
Sheets("Data").Cells(a, 2).Value = Sheets("Raw Data").Cells(b, 2).Value
Sheets("Data").Cells(a, 3).Value = Sheets("Raw Data").Cells(b, 3).Value
Sheets("Data").Cells(a, 4).Value = Sheets("Raw Data").Cells(2, n).Value
Sheets("Data").Cells(a, 5).Value = Sheets("Raw Data").Cells(b, n).Value
n = n + 1
a = a + 1
Loop
n = 4
b = b + 1
Loop
End Sub