Copy 2 columns to last row of sheet removing blanks?

[JumboCactuar]

Hi,
Having trouble with this

I'm wanting to copy from sheet1:
Columns C + G (only rows with data)
To
Sheet2 (columns A+B) last row

So Sheet2 should never have any blanks between rows

Appreciate any help

Was thinking maybe an advanced filter then copying the filtered range to sheet 2 but maybe an easier way

 

[JumboCactuar]

Here's my attempt:

Option Explicit
Sub Macro1()

    Dim lngLastRow  As Long
    Dim lngPasteRow As Long
    Dim lngMyRow    As Long
    
    Application.ScreenUpdating = False

    lngLastRow = Sheets("Sheet1").Range("C:C,G:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = 2 To lngLastRow 'Starts from Row 2. Change to suit if necessary.
        If Len(Sheets("Sheet1").Range("C" & lngMyRow)) > 0 Or Len(Sheets("Sheet1").Range("G" & lngMyRow)) > 0 Then
            If lngPasteRow = 0 Then
                On Error Resume Next 'In case there's data in Sheet2
                    lngPasteRow = Sheets("Sheet2").Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    If lngPasteRow = 0 Then
                        lngPasteRow = 2 'Default output row if there's no data on Sheet2. Change to suit if necessary.
                    End If
                On Error GoTo 0
            Else
                lngPasteRow = Sheets("Sheet2").Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            End If
            With Sheets("Sheet2")
                .Range("A" & lngPasteRow) = Sheets("Sheet1").Range("C" & lngMyRow)
                .Range("B" & lngPasteRow) = Sheets("Sheet1").Range("G" & lngMyRow)
            End With
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

HTH

Robert

this one works, although it takes over a minute (2000 rows)

 

[footoo]

hi, i tried yours and it copys over the formulas in column G, so ends up outputting as #REF
also i only need values

Sub FT()
Dim lr&
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "C").End(xlUp).Row
    .Range("C2:C" & lr).Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp)(2)
    .Range("G2:G" & lr).Copy
    Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp)(2).PasteSpecial Paste:=xlValues
End With
On Error Resume Next
Sheets("Sheet2").[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

 

[JumboCactuar]

Sub FT()
Dim lr&
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "C").End(xlUp).Row
    .Range("C2:C" & lr).Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp)(2)
    .Range("G2:G" & lr).Copy
    Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp)(2).PasteSpecial Paste:=xlValues
End With
On Error Resume Next
Sheets("Sheet2").[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

thankyou this works
modified it slightly as it was copying formats of column C

Sub FT()Application.Calculation = xlManual
Application.ScreenUpdating = False


Dim lr&
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "C").End(xlUp).Row
    .Range("C2:C" & lr).Copy
    Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp)(2).PasteSpecial Paste:=xlValues
    .Range("G2:G" & lr).Copy
    Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp)(2).PasteSpecial Paste:=xlValues
End With
On Error Resume Next
Sheets("Sheet2").[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete


Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub

Takes roughly 10 seconds (2000 rows) and even with the screen updating disabled i get the white screen / excel not responding whilst this is running
unsure why

 

[footoo]

If it's OK to sort Sheet2 by column A :

Sub FT()
Application.Calculation = xlManual
Application.ScreenUpdating = False


Dim lr&
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "C").End(xlUp).Row
    .Range("C2:C" & lr).Copy
    Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp)(2).PasteSpecial Paste:=xlValues
    .Range("G2:G" & lr).Copy
    Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp)(2).PasteSpecial Paste:=xlValues
End With
On Error Resume Next


Sheets("Sheet2").Activate
With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add2 Key:=[A1], SortOn:=xlSortOnValues, Order:=xlAscending
    .SetRange Intersect([A:A], ActiveSheet.UsedRange).EntireRow
    .Header = xlYes
    .Apply
End With


Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub

 

[Trebor76]

Here's my code tweaked so that's faster (hopefully) due to the turning off and then back to whatever calculation method the user had originally:

Option Explicit
Sub Macro1()

    Dim lngLastRow  As Long
    Dim lngPasteRow As Long
    Dim lngMyRow    As Long
    Dim xlnCalcMethod As XlCalculation
    
    With Application
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    Sheets("Sheet1").Calculate
   
    lngLastRow = Sheets("Sheet1").Range("C:C,G:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = 2 To lngLastRow 'Starts from Row 2. Change to suit if necessary.
        If Len(Sheets("Sheet1").Range("C" & lngMyRow)) > 0 Or Len(Sheets("Sheet1").Range("G" & lngMyRow)) > 0 Then
            If lngPasteRow = 0 Then
                On Error Resume Next 'In case there's data in Sheet2
                    lngPasteRow = Sheets("Sheet2").Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    If lngPasteRow = 0 Then
                        lngPasteRow = 2 'Default output row if there's no data on Sheet2. Change to suit if necessary.
                    End If
                On Error GoTo 0
            Else
                lngPasteRow = Sheets("Sheet2").Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            End If
            With Sheets("Sheet2")
                .Range("A" & lngPasteRow) = Sheets("Sheet1").Range("C" & lngMyRow)
                .Range("B" & lngPasteRow) = Sheets("Sheet1").Range("G" & lngMyRow)
            End With
        End If
    Next lngMyRow
    
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With

End Sub

HTH

Robert