Appending into a master sheet by row after row by taking first row of each sheets from multiple sheets then move on two second rows appending [closed] - excel

Question

Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 2 years ago.
Improve this question
Can someone suggest me on how to appending into a master sheet by row after row by taking the first row of each sheet from multiple sheets then move on to second rows appending, suppose in the first iteration, we have each first row of each sheet, that should copy and paste as row1, row2, row3 into the master sheet, then in the next iteration the second row of each sheet comes and add/append at the end of the master sheet means it would be row4, row5...etc into the master sheet
I even tried below piece of code which sent from the user https://stackoverflow.com/users/7444507/michael
but I can't able to get the right output
Public Sub MergeTabs()
'Merges selected tabs (or all visible tabs if only 1 selected) in current workbook into a new tab
Dim i As Integer, wb As Workbook, w As Window, wsTo As Worksheet, wsFrom As Collection 'Worksheet collection
Dim strScope As String, strNewTab As String
Dim raTarget As Range
Set wb = ActiveWorkbook
Set w = ActiveWindow
Set wsFrom = New Collection
If w.SelectedSheets.Count = 1 Then
For i = 1 To wb.Worksheets.Count
If wb.Worksheets(i).Visible Then wsFrom.Add wb.Worksheets(i)
Next
strScope = "ALL VISIBLE"
Else
For i = 1 To w.SelectedSheets.Count
If w.SelectedSheets(i).Visible Then wsFrom.Add w.SelectedSheets(i)
Next
strScope = wsFrom.Count & " SELECTED"
End If
strNewTab = InputBox("Merge data from " & strScope & " sheets to new sheet named:", "Merge tabs", "All")
If strNewTab = vbNullString Then Exit Sub
Set wsTo = wb.Worksheets.Add(wsFrom(1), Count:=1) 'Add before first selected sheet
wsTo.Name = strNewTab
wsFrom(1).Range("A1").CurrentRegion.Copy
wsTo.Range("A1").PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
For i = 2 To wsFrom.Count
wsFrom(i).Range("A2", wsFrom(i).Range("A1").CurrentRegion.Cells(wsFrom(i).Range("A1").CurrentRegion.Cells.Count)).Copy
wsTo.Cells(wsTo.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
Next i
wsTo.Range("A1").Select
MsgBox "Merge Done"
End Sub

Answer 1

Try this code, please. It firstly counts the maximum number of rows for sheets to be processed, the maximum number of columns and number of sheets. For maximum number of columns, it counts only the sheet first row. So, it must be the longer of the sheet! All that is done for being able to correctly dimension the arrFin array which will collect all the lines. It will have more rows then necessary, multiplying the max number of rows with the sheets number. Then the array is filled with data. I switched the rows with columns because only the second dimension of the array can be Redim, preserving the existing data. Finally the transposed array is dropped in the Master sheet at once. It should work very fast... Please, confirm that it works as you need.
Private Sub testApendCopySameRows()
Dim ws As Worksheet, wDest As Worksheet, arrWork As Variant, arrFin As Variant
Dim lastCol As Long, lastC As Long, lastColM As Long, lastR As Long, nrSheets As Long
Dim maxR As Long, maxRows As Long, i As Long, j As Long, k As Long
Set wDest = Worksheets("Master1") ' please, use here your master sheet name
For Each ws In Worksheets
If ws.Name <> wDest.Name Then
'If ws.Name = "sh1" Or ws.Name = "sh2" Then 'used (by me) for testing
nrSheets = nrSheets + 1
lastC = ws.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
If lastC > lastCol Then lastCol = lastC
maxR = ws.Range("A" & Cells.Rows.Count).End(xlUp).Row
If maxR > maxRows Then maxRows = maxR
'End If
End If
Next
ReDim arrFin(1 To lastCol, 1 To maxRows * nrSheets)
ReDim arrWork(1 To 1, 1 To lastCol)
k = 1 'arrFin first row
For i = 1 To maxRows
For Each ws In Worksheets
If ws.Name <> wDest.Name Then
'If ws.Name = "sh1" Or ws.Name = "sh2" Then
lastR = ws.Range("A" & Cells.Rows.Count).End(xlUp).Row
If i <= lastR Then
'input the same rows content in the array:
arrWork = ws.Range(ws.Cells(i, 1), ws.Cells(i, lastCol)).value
For j = 1 To lastCol
arrFin(j, k) = arrWork(1, j)
Next j
k = k + 1
Erase arrWork
ReDim arrWork(1 To 1, 1 To lastCol)
End If
'End If
End If
Next
Next i
ReDim Preserve arrFin(1 To lastCol, 1 To k - 1)
wDest.Range("A1").Resize(UBound(arrFin, 2), UBound(arrFin, 1)).value = _
WorksheetFunction.Transpose(arrFin)
End Sub
Do not forget to use your Master sheet name in Set wDest = Worksheets("Master1")!