VBA copy paste cell range below first blank row from one wb to another

[picklefactory]

Hi folks
I'm struggling again..... no change there.
I'm collecting data in one wb and need to copy/paste but also split it to a 2nd wb. Below is my source data in wba. I want the first range, range 1, being all rows to the first blank row, to paste to cols A1:D1 in wbb and the range of source data below the first blank row, range 2, to paste to cols F1:H1 in wbb. Both ranges of data can vary in length, so needs to be dynamic finding both to and from the first blank row.

WorkbookA.xlsx
	A	B	C	D
1	RANGE 1	RANGE 1	RANGE 1	RANGE 1
2	RANGE 1	RANGE 1	RANGE 1	RANGE 1
3	RANGE 1	RANGE 1	RANGE 1	RANGE 1
4
5	RANGE 2	RANGE 2	RANGE 2
6	RANGE 2	RANGE 2	RANGE 2
7	RANGE 2	RANGE 2	RANGE 2
8	RANGE 2	RANGE 2	RANGE 2
9	RANGE 2	RANGE 2	RANGE 2
10	RANGE 2	RANGE 2	RANGE 2
11	RANGE 2	RANGE 2	RANGE 2
12	RANGE 2	RANGE 2	RANGE 2
13	RANGE 2	RANGE 2	RANGE 2
14	RANGE 2	RANGE 2	RANGE 2
15	RANGE 2	RANGE 2	RANGE 2
Sheet3

So what I'm trying to achieve is this

WorkbookB.xlsm
	A	B	C	D	E	F	G	H
1	RANGE 1	RANGE 1	RANGE 1	RANGE 1		RANGE 2	RANGE 2	RANGE 2
2	RANGE 1	RANGE 1	RANGE 1	RANGE 1		RANGE 2	RANGE 2	RANGE 2
3	RANGE 1	RANGE 1	RANGE 1	RANGE 1		RANGE 2	RANGE 2	RANGE 2
4						RANGE 2	RANGE 2	RANGE 2
5						RANGE 2	RANGE 2	RANGE 2
6						RANGE 2	RANGE 2	RANGE 2
7						RANGE 2	RANGE 2	RANGE 2
8						RANGE 2	RANGE 2	RANGE 2
9						RANGE 2	RANGE 2	RANGE 2
10						RANGE 2	RANGE 2	RANGE 2
11						RANGE 2	RANGE 2	RANGE 2
Sheet3

I found and jiggled some code which will copy/paste the first range OK, but can't fathom how to find/copy the 2nd range, range 2, to cols F1:H1 in wbb?
This is what I have so far for the first range, which works OK
If someone could maybe gimme a hint please on how to grab the 2nd range it would be much appreciated?
Thanks

Sub COPYRANGE()
Dim wba As Workbook
Dim wbb As Workbook

Set wba = Workbooks("Workbook A.xlsx")
Set wbb = Workbooks("Workbook B.xlsm")

With wba.Worksheets("Sheet1")
        .Range("A1:D1", .Range("A1:D1").End(xlDown)).Copy
End With

wbb.Worksheets("Sheet2").Range("A1:D1").PasteSpecial xlPasteValues

End Sub

 

[Joe4]

I think Current Region is your friend here!
Current Region is the same as the CTRL+ALT+* keyboard shortcut which selects all rows and columns in a data range up to the first fully blank row and column.

Assuming that for all your ranges, you have data in column A, here is a simple little procedure that will loop through all of your ranges on your sheet, set them equal to a range, and return the range's address in a Message Box for you to see.

Sub MyRanges()

    Dim rng As Range

'   Select cell A1 to start
    Range("A1").Select

    Do
'       Check to see if you are at end of sheet
        If ActiveCell.Row = Rows.Count Then
            MsgBox "You have reached the bottom of the sheet"
            Exit Do
        End If
'       Return size of range
        If ActiveCell.Value <> "" Then
            Set rng = ActiveCell.CurrentRegion
            MsgBox "Address of range is " & rng.Address
        End If
'       Move to next range
        If ActiveCell.Offset(1, 0) = "" Then
            ActiveCell.End(xlDown).Select
        Else
            ActiveCell.End(xlDown).Select
            ActiveCell.End(xlDown).Select
        End If
    Loop
    
End Sub

So this shows you how to iterate through all the ranges.
See if you can incorporate this logic into the procedure you are creating.

 

[picklefactory]

Ooh.... a practical test..... I'll have a bash

Can I get a sticker if I pass?

 

[picklefactory]

No bloody sticker for me!!! Tried and failed umpteen different approaches. That works beautifully in giving me the Range.Address, but I can't fathom how to take that mid loop and copy/paste to 2 different destinations ranges. I tried creating 2 ranges and saving each loop result as a separate range by a variable... failed miserably. I'm now trying a similar approach by setting 2 destination variables and having the loop copy/paste to a different one each time but I can't work out how to set that.
Latest failed effort below. Excel does not like my attempt at a variable destination, if that is in fact possible at all

Sub MyRanges()

    Dim rng As Range
    Dim dest As Range
    Dim dest1 As Range
    Dim dest2 As Range
    Dim r As Integer
    r = 1
    Set dest1 = Workbooks("WorkbookB.xlsm").Worksheets("Sheet2").Range("A1")
    Set dest2 = Workbooks("WorkbookB.xlsm").Worksheets("Sheet2").Range("F1")
    
'   Select cell A1 to start
    Workbooks("WorkbookA.xlsx").Worksheets("Sheet1").Range("A1").Select

    Do
'       Check to see if you are at end of sheet
        If ActiveCell.Row = Rows.Count Then
            Workbooks("GRN & INVOICE BY PART AND DATE.xlsx").Worksheets("Sheet1").Range("A1").Select
            Exit Do
        End If
'       Return size of range
        If ActiveCell.Value <> "" Then
            Set rng = ActiveCell.CurrentRegion
            'MsgBox "Address of range is " & rng.Address
            rng.Copy Destination:="dest" & r
            r = r + 1
        End If
        
        
'       Move to next range
        
        If ActiveCell.Offset(1, 0) = "" Then
            ActiveCell.End(xlDown).Select
        Else
            ActiveCell.End(xlDown).Select
            ActiveCell.End(xlDown).Select
        End If
    Loop
    
End Sub

 

[Joe4]

You don't need two ranges for your destination sheet.

You can find the last cell with data in row 1, and then shift over two columns from that (to skip a column), i.e.

Cells(1, Columns.Count).End(xlToLeft).Offset(0, 2).Select

So, the first one range you would paste to cell A1, and then you can use the code above to dynamically find the next cell to paste to.

 

[picklefactory]

Thanks again Joe, but apologies I'm being thick. The code just loops this section twice, and selects a different range but I need it to output something different on each loop. I can set destination on cell A1 of target sheet, but then won't it just use that again on the 2nd loop and place range 2 in cell A1 just overwriting the first loop? I'm not grasping how to make it do something different on each of the 2 loops?

Sub MyRanges()

'       Return size of range
        If ActiveCell.Value <> "" Then
            Set rng = ActiveCell.CurrentRegion
            'MsgBox "Address of range is " & rng.Address
            rng.Copy Destination:=dest
          
        End If

 

[Joe4]

Try this. You would just need to change the file and sheet names in the code.

Sub MyCopyRanges()

    Dim wbS As Workbook
    Dim wbD As Workbook
    Dim wsS As Worksheet
    Dim wsD As Worksheet
    Dim rng As Range
    
'   Set workbook and worksheet objects
    Set wbS = Workbooks("Book2.xlsm")  'Source workbook
    Set wbD = Workbooks("Book3.xlsx")  'Destination workbook
    Set wsS = wbS.Sheets("Sheet1")  'Source sheet
    Set wsD = wbD.Sheets("Sheet2")  'Desintation sheet

'   Select in cell A1 on Destination sheet to start
    wbS.Activate
    wsS.Activate
    Range("A1").Select

'   Loop through ranges
    Do
'       Check to see if you are at end of sheet
        If ActiveCell.Row = Rows.Count Then
            Exit Do
        End If
'       Capture range to copy
        If ActiveCell.Value <> "" Then
            Set rng = ActiveCell.CurrentRegion
            rng.Copy
        End If
'       Go to destination workbook/sheet
        wbD.Activate
        wsD.Activate
'       Select range to paste to
        If Range("A1") = "" Then
            Range("A1").Select
            ActiveSheet.Paste
        Else
            wsD.Cells(1, wsD.Columns.Count).End(xlToLeft).Offset(0, 2).Select
            ActiveSheet.Paste
        End If
'       Go back to source file and move to next range in source sheet
        wbS.Activate
        If ActiveCell.Offset(1, 0) = "" Then
            ActiveCell.End(xlDown).Select
        Else
            ActiveCell.End(xlDown).Select
            ActiveCell.End(xlDown).Select
        End If
    Loop
    
    MsgBox "Copy complete!"
    
End Sub

 

[picklefactory]

Thanks again Joe
I was never going to manage a sticker, that's above my meagre level I'm afraid.
Still a couple of issues though..... sorry.
1. My initial explanation was probably crap, but I need to run this and overwrite Workbook 2 each time it runs. I think I'll manage to add a bit of code to open and clear WB2 before running this, that shouldn't be beyond me.
2. The cycle doesn't end, it keeps looping and repeating the 2 ranges across the destination sheet.

Nearly there and I'll go away then

 

[picklefactory]

Ignore me Joe, I'm playing a blinder on this one
It works fine.
Thank you very much for the help, you're a star

 

[Joe4]

You are welcome.
Glad I was able to help!