Merge two ranges together and wrap them into each other

[HJA14]

Hi all,

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

Sheets("1").Range("B1:AA100")

the second range is equal to

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

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]

Try this

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​	B1	C1	D1	E1	F1	G1
2​	B1	C1	D1	E1	F1	G1
3​	B1	C1	D1	E1	F1	G1
4​	B1	C1	D1	E1	F1	G1
5​	B1	C1	D1	E1	F1	G1
6​	B1	C1	D1	E1	F1	G1
7​	B1	C1	D1	E1	F1	G1
8​	B1	C1	D1	E1	F1	G1
9​	B1	C1	D1	E1	F1	G1
10​	B1	C1	D1	E1	F1	G1

Sheet: 1

Excel 2016 (Windows) 32 bit

	B​	C​	D​	E​	F​	G​
1​	B1	C1	D1	E1	F1	G1
2​	B1	C1	D1	E1	F1	G1
3​	B1	C1	D1	E1	F1	G1
4​	B1	C1	D1	E1	F1	G1
5​	B1	C1	D1	E1	F1	G1
6​	B1	C1	D1	E1	F1	G1
7​	B1	C1	D1	E1	F1	G1
8​	B1	C1	D1	E1	F1	G1
9​	B1	C1	D1	E1	F1	G1
10​	B1	C1	D1	E1	F1	G1

Sheet: 2

RESULT

Excel 2016 (Windows) 32 bit

	B​	C​	D​	E​	F​	G​	H​	I​	J​	K​	L​	M​
1​	B1	B1	C1	C1	D1	D1	E1	E1	F1	F1	G1	G1
2​	B1	B1	C1	C1	D1	D1	E1	E1	F1	F1	G1	G1
3​	B1	B1	C1	C1	D1	D1	E1	E1	F1	F1	G1	G1
4​	B1	B1	C1	C1	D1	D1	E1	E1	F1	F1	G1	G1
5​	B1	B1	C1	C1	D1	D1	E1	E1	F1	F1	G1	G1
6​	B1	B1	C1	C1	D1	D1	E1	E1	F1	F1	G1	G1
7​	B1	B1	C1	C1	D1	D1	E1	E1	F1	F1	G1	G1
8​	B1	B1	C1	C1	D1	D1	E1	E1	F1	F1	G1	G1
9​	B1	B1	C1	C1	D1	D1	E1	E1	F1	F1	G1	G1
10​	B1	B1	C1	C1	D1	D1	E1	E1	F1	F1	G1	G1

Sheet: Merge

 

[HJA14]

yess!!! Thank you

 

[Peter_SSs]

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.

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]

Hi,
You might try this as well, if you like

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, ....