Merge two ranges together and wrap them into each other

HJA14

Board Regular
Joined
Apr 12, 2016
Messages
60
Hi all,

I want to merge two ranges together. The first range is equal to

Code:
Sheets("1").Range("B1:AA100")
the second range is equal to

Code:
Sheets("2").Range("B1:AA100")
I am familiar with the UNION-function, but I want to merge them differently.
Basically, I want to merge them column for column. Visually it looks as follows:

https://ibb.co/F4d4sdw


I tried using the following for each range

Code:
Sub inser_columns()
For c = 2 to lastColumn Step 2
   Columns(c).Insert Shift:=xlToRight
Next
End Sub
And paste the two new ranges together by skipping blanks. However, this is very slow especially when I increase the sizes of the two ranges.
Help is much appreciated

 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,717
Office Version
365
Platform
Windows
Try this

Code:
Sub MergeRanges()
    Dim sh1 As Range, sh2 As Range, cel As Range, c As Long
    Set sh1 = Sheets("1").Range("B1:AA100")
    Set sh2 = Sheets("2").Range("B1:AA100")
    Set cel = Sheets("Merge").Cells(1, 2)

    For c = 0 To sh1.Columns.Count - 1
        sh1.Resize(, 1).Offset(, c).Copy cel.Offset(, c * 2)
        sh2.Resize(, 1).Offset(, c).Copy cel.Offset(, c * 2 + 1)
    Next c
End Sub


Excel 2016 (Windows) 32 bit
B
C
D
E
F
G
1
B1C1D1E1F1G1
2
B1C1D1E1F1G1
3
B1C1D1E1F1G1
4
B1C1D1E1F1G1
5
B1C1D1E1F1G1
6
B1C1D1E1F1G1
7
B1C1D1E1F1G1
8
B1C1D1E1F1G1
9
B1C1D1E1F1G1
10
B1C1D1E1F1G1
Sheet: 1

Excel 2016 (Windows) 32 bit
B
C
D
E
F
G
1
B1C1D1E1F1G1
2
B1C1D1E1F1G1
3
B1C1D1E1F1G1
4
B1C1D1E1F1G1
5
B1C1D1E1F1G1
6
B1C1D1E1F1G1
7
B1C1D1E1F1G1
8
B1C1D1E1F1G1
9
B1C1D1E1F1G1
10
B1C1D1E1F1G1
Sheet: 2

RESULT

Excel 2016 (Windows) 32 bit
B
C
D
E
F
G
H
I
J
K
L
M
1
B1B1C1C1D1D1E1E1F1F1G1G1
2
B1B1C1C1D1D1E1E1F1F1G1G1
3
B1B1C1C1D1D1E1E1F1F1G1G1
4
B1B1C1C1D1D1E1E1F1F1G1G1
5
B1B1C1C1D1D1E1E1F1F1G1G1
6
B1B1C1C1D1D1E1E1F1F1G1G1
7
B1B1C1C1D1D1E1E1F1F1G1G1
8
B1B1C1C1D1D1E1E1F1F1G1G1
9
B1B1C1C1D1D1E1E1F1F1G1G1
10
B1B1C1C1D1D1E1E1F1F1G1G1
Sheet: Merge
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
42,320
Office Version
365
Platform
Windows
Since I had been playing around with this too, I will post my offering. This is a bit different as it does not require any looping. My testing showed it to be about 3 times as fast as the post 2 code though I do note that the range size is not very big so that speed difference is basically irrelevant. Anyway, if you feel like it you can give this a whirl as well.
My code assumes ..
- Sheets 'Merge' exists but does not contain data
- In Sheets '1' and '2', the column immediately to the right of the range in question (range AB1:AB100 with the current specs) does not contain data. A modification could be made if that is not the case.

Rich (BB code):
Sub Merge_Ranges()
  Dim a As Variant, vCols As Variant, vRws As Variant
  Dim cel As Range
  
  Const sRngAddress  As String = "B1:AA100" '<- Edit this if you want to adapt the code to a different range

  With Range(sRngAddress)
    vCols = Split(Join(Application.Transpose(Evaluate("row(" & .Column & ":" & .Columns.Count + .Column - 1 & ")")), "," & .Columns.Count + .Column & ","), ",")
    vRws = Evaluate("row(" & .Row & ":" & .Rows.Count + .Row - 1 & ")")
  End With
  Set cel = Sheets("Merge").Range(sRngAddress).Cells(1)
  a = Application.Index(Sheets("1").Cells, vRws, vCols)
  cel.Resize(UBound(a), UBound(a, 2)).Value = a
  a = Application.Index(Sheets("2").Cells, vRws, vCols)
  With cel.Offset(UBound(a)).Resize(UBound(a), UBound(a, 2))
    .Value = a
    .Copy
    cel.Offset(, 1).PasteSpecial xlPasteValues, SkipBlanks:=True
    .ClearContents
 End With
End Sub
 

mohadin

Active Member
Joined
Mar 22, 2015
Messages
361
Office Version
2013
Platform
Windows
Hi,
You might try this as well, if you like
Code:
Sub Merge()
    Dim sh1 As Range, sh2 As Range, cel As Range, c As Long
    a = Application.Transpose(Sheet1.Range("B1").CurrentRegion)
    b = Application.Transpose(Sheet2.Range("B1").CurrentRegion)
    Set dest = Sheet3
    k = 1
    cl = UBound(a, 2)
    dest.Activate
    For i = 1 To UBound(a, 1) * 2 - 1 Step 2
        Range(Cells(1, i), Cells(cl, i)).Offset(, 1) = Application.Transpose(Application.Index(a, k, 0))
        Range(Cells(1, i + 1), Cells(cl, i + 1)).Offset(, 1) = Application.Transpose(Application.Index(b, k, 0))
        k = k + 1
    Next i
End Sub
Flexible, Fast, ....
 

Forum statistics

Threads
1,082,587
Messages
5,366,484
Members
400,894
Latest member
frog9000

Some videos you may like

This Week's Hot Topics

Top