Problem copying data to next available row with VBA

[sramsay]

Hi all,

Im trying to piece together a Macro that will copy data from columns across multiple worksheets and paste into one column on a destination worksheet. It works for the first 1 but im struggling with the second and it just overwrites the cells copied from source1 sheet. - This is far as I've got as no point going anyfuther for the remaining 4 sheets if I cant get it to work.

Does anyone have any advice?

Sub CopyRange()


Application.ScreenUpdating = True


Dim source1 As Worksheet
Dim source2 As Worksheet
Dim source3 As Worksheet
Dim source4 As Worksheet
Dim source5 As Worksheet
Dim source6 As Worksheet
Dim destination As Worksheet
Dim emptyColumn As Long


Set source1 = Sheets("JLL Elec")
Set source2 = Sheets("JLL Gas")
Set source3 = Sheets("JLL Water")
Set source4 = Sheets("L&G Elec")
Set source5 = Sheets("L&G Gas")
Set source6 = Sheets("L&G Water")
Set destination = Sheets("Tidy")


        
    emptyRow = destination.Range("A65536").End(xlUp).Offset(1).Column


    source1.Range("I:I").Copy destination.Cells(1, emptyRow)
    source2.Range("I:I").Copy destination.Cells(1, emptyRow)


End Sub

Thanks

 

[mancubus]

hi...

emptyRow = destination.Range("A" & Rows.Count).End(xlUp).Offset(1).Row

 

[jain2712]

Sometimes thing looks much difficult then they are exactly not.

Try this.

After everycode, select the first cell of the column in which you are pasting the data. Range("A1") in below example shown only for instruction purpose.

Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select

Thanks,
Jain

 

[Trebor76]

Hi sramsay,

You've got the cells argument the wrong way round as the first argument should be row then column i.e. your last two line should be like this:

source1.Range("I:I").Copy destination.Cells(emptyRow, 1)
    source2.Range("I:I").Copy destination.Cells(emptyRow, 1)

Also as I pointed out to humdingaling here just today, Excel 2007 increased the number of rows 16 fold over Excel 2003 to a whopping 1,048,576 rows per tab. So using code that "only" works with a maximum 65,536 may catch you out. Though there are a number of variations, based on your existing code I'd use this instead:

emptyRow = destination.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row

HTH

Robert

 

[mancubus]

i aproach to requirement would be:

Sub mrxl_851986_ConsWss()

    Dim wsNames As Variant
    Dim copyRange As Range
    Dim i As Long
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    wsNames = Array("JLL Elec", "JLL Gas", "JLL Water", "L&G Elec", "L&G Gas", "L&G Water")
    
    Worksheets("Tidy").Range("A:A").Clear
    
    For i = LBound(wsNames) To UBound(wsNames)
        With Worksheets(wsNames(i))
            Set copyRange = .Range("I1:I" & .Range("I" & .Rows.Count).End(xlUp).Row)
        End With
        Worksheets("Tidy").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(copyRange.Rows.Count, 1).Value = copyRange.Value
    Next i

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

 

[dmt32]

not tested but slight variation on a suggestion:

Sub CopyRange()
Dim wsDestination As Worksheet, ws As Worksheet
Dim LastRow As Long
Dim arr As Variant
Dim rng As Range


arr = Array("JLL Elec", "JLL Gas", "JLL Water", "L&G Elec", "L&G Gas", "L&G Water")


Set wsDestination = Sheets("Tidy")


Application.ScreenUpdating = False
For Each sh In Worksheets(arr)


    LastRow = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
    
    Set rng = sh.Range(sh.Range("I1"), sh.Range("I" & sh.Rows.Count).End(xlUp))
    
    rng.Copy wsDestination.Cells(LastRow, 1)
    
    Set rng = Nothing
Next sh
Application.ScreenUpdating = True
End Sub

Dave