Using Union to combine ranges in VBA

Hi,

I have to copy and paste number of ranges from one spreadsheet to another for which I have written the below VBA


Private Sub CommandButton1_Click()

LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row

Dim R1, R2, R3, R4, R5, R6, R7, Multiplerange As Range

For i = 6 To LastRow

If Cells(i, 18) = "Open" And Cells(i, 53) = "Escalated to JLR Senior Leadership" Then

Set R1 = Range(Cells(i, 2), Cells(i, 2))
Set R2 = Range(Cells(i, 4), Cells(i, 4))
Set R3 = Range(Cells(i, 6), Cells(i, 16))
Set R4 = Range(Cells(i, 58), Cells(i, 58))
Set R5 = Range(Cells(i, 56), Cells(i, 56))
Set R6 = Range(Cells(i, 20), Cells(i, 20))
Union(R1, R2,R3,R4, R5, R6).Select
'
Selection.Copy

Workbooks.Open Filename:="C:\Documents and Settings\ssachde1\My Documents\extract.xlsx"

Dim p As Integer, q As Integer

p = Worksheets.Count

For q = 1 To p

If ActiveWorkbook.Worksheets(q).Name = "Risk Log" Then
Worksheets("Risk Log").Select
End If

Next q

erow = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 2).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False

End If

Next i

End Sub


The entire code works fine but the only problem I have is that 'union' changes the order of selection to R1, R2,R3,R6,R5,R4.

How can keep the range in the order that I want.

Please help me.

Thanks

Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code.

Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here



(This thread should receive no further responses until this moderation request is fulfilled, as per Forum Rule 7)

I am really very sorry Stephen, I have never posted a code before.

Please let me know if what I have done below is correct

Private Sub CommandButton1_Click()

LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row

Dim R1, R2, R3, R4, R5, R6, R7, Multiplerange As Range

For i = 6 To LastRow

If Cells(i, 18) = "Open" And Cells(i, 53) = "Escalated to JLR Senior Leadership" Then

Set R1 = Range(Cells(i, 2), Cells(i, 2))
Set R2 = Range(Cells(i, 4), Cells(i, 4))
Set R3 = Range(Cells(i, 6), Cells(i, 16))
Set R4 = Range(Cells(i, 58), Cells(i, 58))
Set R5 = Range(Cells(i, 56), Cells(i, 56))
Set R6 = Range(Cells(i, 20), Cells(i, 20))
Union(R1, R2,R3,R4, R5, R6).Select
'
Selection.Copy

Workbooks.Open Filename:="C:\Documents and Settings\ssachde1\My Documents\extract.xlsx"

Dim p As Integer, q As Integer

p = Worksheets.Count

For q = 1 To p

If ActiveWorkbook.Worksheets(q).Name = "Risk Log" Then
Worksheets("Risk Log").Select
End If

Next q

erow = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 2).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False

End If

Next i

End Sub

That's it, thanks. I think you'd probably have to loop through each range and copy in turn. Union, in effect, creates a single range so the different elements are lost.

I tried to do it but it does not seem to work. Your help will be appreciated.

I made a stab at tidying up your code a little

Private Sub CommandButton1_Click()

Dim R1 As Range, R2 As Range, R3 As Range, R4 As Range, R5 As Range, R6 As Range, R7 As Range
Dim LastRow As Long, wb1 As Workbook, ws As Worksheet, i As Long

Set ws = ThisWorkbook.ActiveSheet
LastRow = ws.Range("B" & Rows.Count).End(xlUp).Row

Set wb1 = Workbooks.Open(Filename:="C:\Documents and Settings\ssachde1\My Documents\extract.xlsx")

For i = 6 To LastRow
    If ws.Cells(i, 18) = "Open" And ws.Cells(i, 53) = "Escalated to JLR Senior Leadership" Then
        With ws
            Set R1 = .Range(.Cells(i, 2), .Cells(i, 2))
            Set R2 = .Range(.Cells(i, 4), .Cells(i, 4))
            Set R3 = .Range(.Cells(i, 6), .Cells(i, 16))
            Set R4 = .Range(.Cells(i, 58), .Cells(i, 58))
            Set R5 = .Range(.Cells(i, 56), .Cells(i, 56))
            Set R6 = .Range(.Cells(i, 20), .Cells(i, 20))
        End With
        
        With wb1.Worksheets("Risk Log")
            R1.Copy .Cells(.Rows.Count, 2).End(xlUp)(2)
            R2.Copy .Cells(.Rows.Count, 2).End(xlUp)(2)
            R3.Copy .Cells(.Rows.Count, 2).End(xlUp)(2)
            R4.Copy .Cells(.Rows.Count, 2).End(xlUp)(2)
            R5.Copy .Cells(.Rows.Count, 2).End(xlUp)(2)
            R6.Copy .Cells(.Rows.Count, 2).End(xlUp)(2)
        End With
    End If
Next i

wb1.Save
wb1.Close

End Sub

Thanks for your help HaHobe,

I tried to paste the code but it does not seem to work.
All the data is pasted into the 8th Column in Risk log. Rather than being pasted into row as per my code.

Thanks StephenR

Your logic is working correctly but the only problem it is pasting each range in column 2 one after the other whereas the first range should be pasted in Column 2, then second range should be pasted in column 3 the third range should be pasted column 4, the fourth range should be pasted in column 13.
I don't know how to attach the extracted file because that would have shown you clearly how it looks.

Thanks Stephen I understood the logic and have made the changes to the code and it works Brilliantly Thanks for your help and also HaHobe I am using his code somewhere else.

 
            R1.Copy .Cells(.Rows.Count, 2).End(xlUp)(2)
            R2.Copy .Cells(.Rows.Count, 3).End(xlUp)(2)
            R3.Copy .Cells(.Rows.Count, 4).End(xlUp)(2)
            R4.Copy .Cells(.Rows.Count, 15).End(xlUp)(2)
            R5.Copy .Cells(.Rows.Count, 16).End(xlUp)(2)
            R6.Copy .Cells(.Rows.Count, 17).End(xlUp)(2)

Thanks Romperstomper the code works fine.

Appreciate help from all of you.

Hi Romperstomper, Stephen

The code works fine but some of my cells are formulas how can I paste values only.

Thanks

Thanks Romperstomper.