I have a spreadsheet #1 which has rows of data and values in many columns such as Column A being ORDER DATE, column B being Region Column C as Reps etc.(Total M rows)
I have another spreadsheet #2 with other columns and many rows. Column A is Item, Column B is Region, column C is a number of items and so forth (Total N rows)
I would like a macro which would populate data in sheet 1 with all the data in sheet 2. For example if 10 rows are present in sheet 1 and five rows sheet 2 then sheet 3 must have 50 rows i.e. all the five rows of sheet 2 must be populated with each individual rows of sheet 1.
Note: The number of columns are not static (their is no fixed structure for no. of columns in both the sheets)
I have provided screenshots for better understanding (Sheet 1, Sheet 2 and Sheet 3):
I have tried to append data column wise but I am not able to create repetitions for data in sheet 2 Currently my code is only joining the columns of sheets 1 and sheet 2 but nit able to create m X n rows
Sub ColumnsPaste()
Dim Source As Worksheet
Dim Destination As Worksheet
Dim Last As Long
Application.ScreenUpdating = False
Set Destination = Worksheets.Add(after:=Worksheets("Sheet1"))
Destination.Name = "Sheet3"
For Each Source In ThisWorkbook.Worksheets
If Source.Name <> "Sheet3" Then
Last = Destination.Range("A1").SpecialCells(xlCellTypeLastCell).Column
If Last = 1 Then
Source.UsedRange.Copy Destination.Columns(Last)
Else
Source.UsedRange.Copy Destination.Columns(Last 1)
End If
End If
Next
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
CodePudding user response:
Please, use the next code. It will be fast enough, using clipboard only for copying the header. It assumes that the range to be processed exists in columns "A:C" (starting from the second row) and returns in column "D:D":
Sub CombiteSheets()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lastR1 As Long, lastR2 As Long, lastR3 As Long
Dim lastCol1 As Long, lastCol2 As Long, repRows As Long, arr2, i As Long, iRow As Long
Set sh1 = ActiveSheet 'use here the sheet you need
Set sh2 = sh1.Next 'use here the sheet you need
Set sh3 = sh2.Next 'the same...
lastR1 = sh1.Range("A" & sh1.rows.count).End(xlUp).row 'last row on the first sheet
lastR2 = sh2.Range("A" & sh2.rows.count).End(xlUp).row 'last row on the second sheet
lastCol1 = sh1.cells(1, sh1.Columns.count).End(xlToLeft).Column 'last column on the first sheet
lastCol2 = sh2.cells(1, sh2.Columns.count).End(xlToLeft).Column 'last columln on the second sheet
repRows = lastR2 - 1
arr2 = sh2.Range("A2", sh2.cells(lastR2, lastCol2)).value 'place the range in an array for faster processing
On Error GoTo SaveExit
'some code optimization:
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual: Application.EnableEvents = False
For i = 2 To lastR1
sh3.Range("A" & i iRow).Resize(repRows, lastCol1).value = _
sh1.Range("A" & i, sh1.cells(i, lastCol1)).value
sh3.cells(i iRow, lastCol1 1).Resize(UBound(arr2), UBound(arr2, 2)).value = arr2
iRow = iRow repRows - 1
Next i
'copy headers:
sh1.Range("A1", sh1.cells(1, lastCol1)).Copy sh3.Range("A1")
sh2.Range("A1", sh2.cells(1, lastCol2)).Copy sh3.cells(1, lastCol1 1)
'a little formatting:
someFormat sh3.Range("A1", sh3.cells(UBound(arr2) * (lastR1 - 1) 1, lastCol1 lastCol2))
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic: Application.EnableEvents = True
MsgBox "Ready..."
Exit Sub
SaveExit:
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic: Application.EnableEvents = True
MsgBox err.Description, vbCritical, err.Number
End Sub
Private Sub someFormat(rng As Range) 'formatting the returned range
Dim i As Long
rng.EntireColumn.AutoFit
For i = 7 To 12
With rng.Borders(i)
.LineStyle = xlContinuous
.ColorIndex = 47
.Weight = xlThin
End With
Next i
End Sub
Please, send some feedback after testing it...