VBA Code to Copy multiple Columns from Source Sheet into 4 columns of Destination Sheet

[MHamid]

Hello,

I need some assistance creating a VBA code that will copy 24 columns into 4 columns.
Source sheet (DSMT) has 22 columns labeled as MS Level 4 ID and MS Level 4 Name where the number 4 would change to number 5, 6, 7, etc up to number 14. They are in columns M-AH. Then I have a Sector column (Column AI) and Business Name column (Column AJ) that I need copied over.

MS Level 4 ID

MS Level 4 Name

MS Level 5 ID

MS Level 5 Name

MS Level 6 ID

MS Level 6 Name

MS Level 7 ID

MS Level 7 Name

MS Level 8 ID

MS Level 8 Name

MS Level 9 ID

MS Level 9 Name

MS Level 10 ID

MS Level 10 Name

MS Level 11 ID

MS Level 11 Name

MS Level 12 ID

MS Level 12 Name

MS Level 13 ID

MS Level 13 Name

MS Level 14 ID

MS Level 14 Name

Sector

Business Name

The columns in the destination sheet (DSMT List) looks like this:

The idea is to Copy all data (even blank cells) 4 columns at a time. AG, AH, AI, AJ copied from source sheet and paste into destination sheet. Then copy data from AE, AF, AI, AJ copied from source sheet and paste into destination sheet after the first data was copied ... then copy data from columns AC, AD, AI, AJ and paste into destination sheet after last row of data ... and so forth. So for evert MS Level ID and MS Level Name I need the corresponding Sector and Business Name. The issue I am having is that data copied from the MS levels can be blanks. Any way I can skip the blanks and copy items with data?

I found the below code that I attempted to manipulate to what I need, but because of the blanks I am missing data.
Any assistance would be greatly appreciated.

Sub DSMT_List()
Dim lrSource, lrDest As Long
Dim SourceSh, DestSh As Worksheet
Dim PasteRow As Long, iCheckCol As Integer

Set SourceSh = Worksheets("DSMT")
Set DestSh = Worksheets("DSMT List")

lrSource = SourceSh.Cells.SpecialCells(xlCellTypeLastCell).Row
lrDest = DestSh.Cells(DestSh.Rows.Count, "C").End(xlUp).Row + 1

PasteRow = 0

For iCheckCol = 1 To 4 'Check column A-D
    If DestSh.Cells(DestSh.Rows.Count, iCheckCol).End(xlUp).Row > PasteRow Then
        PasteRow = DestSh.Cells(DestSh.Rows.Count, iCheckCol).End(xlUp).Row 'Find last row with data
    End If
Next iCheckCol

PasteRow = PasteRow + 1 'Go down from last row used
SourceSh.Range("AG2:AG" & lrSource).Copy DestSh.Cells(PasteRow, 1)
SourceSh.Range("AH2:AH" & lrSource).Copy DestSh.Cells(PasteRow, 2)
SourceSh.Range("AI2:AI" & lrSource).Copy DestSh.Cells(PasteRow, 3)
SourceSh.Range("AJ2:AJ" & lrSource).Copy DestSh.Cells(PasteRow, 4)
SourceSh.Range("AE2:AE" & lrSource).Copy DestSh.Cells(PasteRow, 1)
SourceSh.Range("AF2:AF" & lrSource).Copy DestSh.Cells(PasteRow, 2)
SourceSh.Range("AI2:AI" & lrSource).Copy DestSh.Cells(PasteRow, 3)
SourceSh.Range("AJ2:AJ" & lrSource).Copy DestSh.Cells(PasteRow, 4)
SourceSh.Range("AC2:AC" & lrSource).Copy DestSh.Cells(PasteRow, 1)
SourceSh.Range("AD2:AD" & lrSource).Copy DestSh.Cells(PasteRow, 2)
SourceSh.Range("AI2:AI" & lrSource).Copy DestSh.Cells(PasteRow, 3)
SourceSh.Range("AJ2:AJ" & lrSource).Copy DestSh.Cells(PasteRow, 4)
SourceSh.Range("AA2:AA" & lrSource).Copy DestSh.Cells(PasteRow, 1)
SourceSh.Range("AB2:AB" & lrSource).Copy DestSh.Cells(PasteRow, 2)
SourceSh.Range("AI2:AI" & lrSource).Copy DestSh.Cells(PasteRow, 3)
SourceSh.Range("AJ2:AJ" & lrSource).Copy DestSh.Cells(PasteRow, 4)
SourceSh.Range("Y2:Y" & lrSource).Copy DestSh.Cells(PasteRow, 1)
SourceSh.Range("Z2:Z" & lrSource).Copy DestSh.Cells(PasteRow, 2)
SourceSh.Range("AI2:AI" & lrSource).Copy DestSh.Cells(PasteRow, 3)
SourceSh.Range("AJ2:AJ" & lrSource).Copy DestSh.Cells(PasteRow, 4)
SourceSh.Range("W2:W" & lrSource).Copy DestSh.Cells(PasteRow, 1)
SourceSh.Range("X2:X" & lrSource).Copy DestSh.Cells(PasteRow, 2)
SourceSh.Range("AI2:AI" & lrSource).Copy DestSh.Cells(PasteRow, 3)
SourceSh.Range("AJ2:AJ" & lrSource).Copy DestSh.Cells(PasteRow, 4)
SourceSh.Range("U2:U" & lrSource).Copy DestSh.Cells(PasteRow, 1)
SourceSh.Range("V2:V" & lrSource).Copy DestSh.Cells(PasteRow, 2)
SourceSh.Range("AI2:AI" & lrSource).Copy DestSh.Cells(PasteRow, 3)
SourceSh.Range("AJ2:AJ" & lrSource).Copy DestSh.Cells(PasteRow, 4)
SourceSh.Range("S2:S" & lrSource).Copy DestSh.Cells(PasteRow, 1)
SourceSh.Range("T2:T" & lrSource).Copy DestSh.Cells(PasteRow, 2)
SourceSh.Range("AI2:AI" & lrSource).Copy DestSh.Cells(PasteRow, 3)
SourceSh.Range("AJ2:AJ" & lrSource).Copy DestSh.Cells(PasteRow, 4)
SourceSh.Range("Q2:Q" & lrSource).Copy DestSh.Cells(PasteRow, 1)
SourceSh.Range("R2:R" & lrSource).Copy DestSh.Cells(PasteRow, 2)
SourceSh.Range("AI2:AI" & lrSource).Copy DestSh.Cells(PasteRow, 3)
SourceSh.Range("AJ2:AJ" & lrSource).Copy DestSh.Cells(PasteRow, 4)
SourceSh.Range("O2:O" & lrSource).Copy DestSh.Cells(PasteRow, 1)
SourceSh.Range("P2:P" & lrSource).Copy DestSh.Cells(PasteRow, 2)
SourceSh.Range("AI2:AI" & lrSource).Copy DestSh.Cells(PasteRow, 3)
SourceSh.Range("AJ2:AJ" & lrSource).Copy DestSh.Cells(PasteRow, 4)
SourceSh.Range("M2:M" & lrSource).Copy DestSh.Cells(PasteRow, 1)
SourceSh.Range("N2:N" & lrSource).Copy DestSh.Cells(PasteRow, 2)
SourceSh.Range("AI2:AI" & lrSource).Copy DestSh.Cells(PasteRow, 3)
SourceSh.Range("AJ2:AJ" & lrSource).Copy DestSh.Cells(PasteRow, 4)


Application.CutCopyMode = False

End Sub

Thank you,

 

[kevin9999]

I expect this might take a few attempts to get it right. Let's start with this, and see how close it is to your desired result.

Option Explicit
Sub MHamid_1()
    Dim lr1 As Long, lr2 As Long, i As Long, ar1, ar2
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Temprng As Range
    Set ws1 = Worksheets("DSMT")
    Set ws2 = Worksheets("DSMT List")
    Application.ScreenUpdating = False
    
    For i = 33 To 7 Step -2
        lr1 = Union(ws1.Columns(i), ws1.Columns(i + 1)).Find("*", , xlFormulas, , 1, 2).Row
        lr2 = ws2.Cells.Find("*", , xlFormulas, , 1, 2).Row + 1
        Set Temprng = ws1.Cells(2, 35).Resize(lr1 - 1, 2)
        
        ar1 = ws1.Cells(2, i).Resize(lr1 - 1, 2).Value
        ar2 = Temprng.Value
        
        ws2.Cells(lr2, 1).Resize(UBound(ar1, 1), UBound(ar1, 2)).Value = ar1
        ws2.Cells(lr2, 3).Resize(UBound(ar2, 1), UBound(ar2, 2)).Value = ar2
    Next i
    Application.ScreenUpdating = True
End Sub