Populate multiple cell entries of one sheet with data on another sheet cells

user_13050868 0
Viewed 50

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):

Sheet1 Sheet2 Sheet3

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

My VBA code output: My VBA code Output

left-join excel-formula vba excel
1 Answers

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

user_22333080
Related