VBA to Transfer Data from Worksheet to Worksheet and Skip Row

[tsroque]

I have a data table of almost 7000 products. I only need 3 of the columns for my final report (J, K, and O...Part Number, Description and Price). What is a quick and easy way to transfer defined columns to another worksheet (starting row 7, in columns A, C and E) and have a blank row between each row?

Thank you!

 

[Warship]

try:

Sub CopyPasteInsertRowEveryOther()
    Dim arrCol As Variant, i As Integer
    Dim LastRow As Long, LastMax As Long
    Dim shSource As Worksheet, shDestin As Worksheet
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Set shDestin = Sheets("Sheet1")
    Set shSource = Sheets("Sheet2")
    arrCol = Array("J", "A", "K", "C", "O", "E")
    
    For i = 0 To 5 Step 2
        LastRow = shSource.Range(arrCol(i) & Rows.Count).End(xlUp).Row
        If LastMax < LastRow Then LastMax = LastRow
        shSource.Range(arrCol(i) & "1:" & arrCol(i) & LastRow).Copy shDestin.Range(arrCol(i + 1) & "7")
    Next i
    For i = LastMax + 7 To 8 Step -1
        Range("A" & i & ",C" & i & ",E" & i).Insert Shift:=xlDown
    Next i
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

[tsroque]

Hi Warship!

I forgot to mention that source sheet starts on row 3. Also, it works but it's copying as a formula instead of text. The values in J and K are text and O is currency. All three contain values are based off a formula in the source sheet. Other than that, it works...LOL! If I can get the #Ref error fixed, I will be interesting to see how it handles 7000 lines

 

[Warship]

Please update me on the 7000 run.

get the #Ref error fixed

error ???

Sub CopyPasteInsertRowEveryOther2()
    Dim arrCol As Variant, i As Integer
    Dim LastRow As Long, LastMax As Long
    Dim shSource As Worksheet, shDestin As Worksheet
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Set shDestin = Sheets("Sheet1")
    Set shSource = Sheets("Sheet2")
    arrCol = Array("J", "A", "K", "C", "O", "E")
    
    For i = 0 To 5 Step 2
        LastRow = shSource.Range(arrCol(i) & Rows.Count).End(xlUp).Row
        If LastMax < LastRow Then LastMax = LastRow
        shSource.Range(arrCol(i) & "3:" & arrCol(i) & LastRow).Copy
        shDestin.Range(arrCol(i + 1) & "7").PasteSpecial xlPasteValues
    Next i
    For i = LastMax + 7 To 8 Step -1
        Range("A" & i & ",C" & i & ",E" & i).Insert Shift:=xlDown
    Next i
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

[tsroque]

Works like a charm! But apparently not for 7000 source lines...LOL!!!