Excel VBA copy and duplicate data

[Leorand]

Hello Master's.

I would like to ask a question about tittle above.
I got a mini project from my boss to change the direction of a stored excel data to another sheet using vba.

For example this is stored data that i got :

and my boss want the table look like this :

For now, I've already done to change the position of the sorted data (number1, number 2, number 3) but stuck for destination and date, and my tiny little brain cannot understand how the hell should I do with the code.

can you guys help me for this case?

It will save my day.

Gracias.

 

[myall_blues]

How much data is there and do you have to use VBA? Since you’ve already got the the number columns sorted it might be easiest to just add on a couple of columns and copy down the date and destination manually (assuming this is a one-off exercise).

 

[Leorand]

How much data is there and do you have to use VBA? Since you’ve already got the the number columns sorted it might be easiest to just add on a couple of columns and copy down the date and destination manually (assuming this is a one-off exercise).

It's approximately there is 50 data table, each table has 3 columns. And yes, there is a lot of data

 

[myall_blues]

Fair enough. Can you share the code you have already.

 

[Leorand]

Fair enough. Can you share the code you have already.

Sure. This is my code :

Sub CopyPasteData()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim sourceCells As Range
    Dim targetCells As Range
    Dim duplicateCount As Long
    Dim lastRow As Long
    Dim i As Long
    Dim e As Long

    'set the source and target worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("Data")
    Set targetSheet = ThisWorkbook.Worksheets("Outcome")
        
    sourceSheet.Range("A3:C" & sourceSheet.Cells(sourceSheet.Rows.Count, "B").End(xlUp).Row).Copy
    
    'find the last row in the target sheet
    lastRow = targetSheet.Cells(targetSheet.Rows.Count, "B").End(xlUp).Row
    
    'paste data into target sheet, starting from column b2
    targetSheet.Range("B" & lastRow + 1).PasteSpecial
    
    'loop trough each block of data (e.g B3:D, E3:G, etc)
    For i = 4 To 100 Step 3 'assuming 3 column per block
    
        'copy the next block data
        sourceSheet.Range(sourceSheet.Cells(3, i), sourceSheet.Cells(sourceSheet.Cells(sourceSheet.Rows.Count, i).End(xlUp).Row, i + 2)).Copy
        
        'find the last row in target sheet
        lastRow = targetSheet.Cells(targetSheet.Rows.Count, "B").End(xlUp).Row
        
        'paste data into target sheet, starting from the last row + 2
        targetSheet.Range("B" & lastRow + 2).PasteSpecial
    
    Next i
    
    'clean up
    Application.CutCopyMode = False
End Sub

 

[myall_blues]

Does this work for you? Test it on a copy of your data.

Sub Leorand()
    Dim i As Long, sourcelastrow As Long, lastRow As Long, j As Long, k As Long
    Dim datablocks As Variant
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    'set the source and target worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("Data")
    Set targetSheet = ThisWorkbook.Worksheets("Outcome")
    For i = 1 To 100 Step 3
        sourcelastrow = sourceSheet.Cells(Rows.Count, i + 1).End(xlUp).Row
        ReDim datablocks(sourcelastrow - 3, 3)
        ' Read data into array
        For j = 3 To sourcelastrow
            For k = 1 To 3
                datablocks(j - 3, k - 1) = sourceSheet.Cells(j, k + i - 1)
            Next k
        Next j
        'find the last row in the target sheet
        lastRow = targetSheet.Cells(targetSheet.Rows.Count, "B").End(xlUp).Row
        'write data array to target sheet, starting from column b2. Add Dest and date on the end
        For j = LBound(datablocks, 1) To UBound(datablocks, 1)
            For k = LBound(datablocks, 2) To UBound(datablocks, 2) - 1
                targetSheet.Cells(lastRow + j + 2, k + 2) = datablocks(j, k)
                targetSheet.Cells(lastRow + j + 2, 5) = sourceSheet.Cells(2, i)
                targetSheet.Cells(lastRow + j + 2, 6) = Format(sourceSheet.Cells(1, i), "dd-mmm-yy")
            Next k
        Next j
    Next i
End Sub

 

[Leorand]

Amazing!!!
It's works perfectly, and the result just like what I want.

I just need to do little modification with you're code.
Thankyou very much for you're help sir.

 

[myall_blues]

Excellent news. Thanks for the feedback.