Copying the data from two columns from every sheet into a new sheet - excel

Question

I have several workbooks with multiple worksheets. Each worksheet has two columns in positions "H" and "I". These columns in each worksheet has a different number of rows for these two columns. The worksheets are named differently as in
Sheet1: Data
Sheet2: Calc
Sheet3: Settings
Sheet4: Append1
Sheet5: Append2
.....
After the "Settings" sheet, each sheet is named append and then 1,2,3,...
I want to copy the columns H and I from every sheet except Calc and Settings into a new sheet.
It should be copied as columns. So it should look something like this in the new sheet
Data.col(H)|Data.col(I)|Append1.col(H)|Append1.col(I)|Append2.col(H)|Append2.col(I)| .....
How do I achieve this?
I have been using the formula =Append1H:H and =Append1I: I but it is too much data and cannot be done manually.
Any help is appreciated.

Answer 1

Please, try the next way. It will be very fast, using arrays and working mostly in memory. It does not use clipboard, it will not copy the range format. It will return in columns "A:B" of the newly created sheet (or the cleaned one, if already existing):
Sub copyColumns()
Dim wb As Workbook, ws As Worksheet, lastR As Long, arrC, arrFin, i As Long
Set wb = ActiveWorkbook 'use here the apropriate workbook
For Each ws In wb.Worksheets
If ws.name <> "Settings" And ws.name <> "Calc" And _
ws.name <> "Cons_Sheet" Then
i = i + 1
lastR = ws.Range("H" & ws.rows.count).End(xlUp).row
arrC = ws.Range("H" & IIf(i = 1, 1, 2) & ":I" & lastR).value 'copy header only from the first sheet
arrFin = buildArr(arrFin, arrC, i) 'add arrC to the one keeping all processing result
End If
Next ws
'add a new sheet, or clean it if existing:
Dim shC As Worksheet
On Error Resume Next
Set shC = wb.Worksheets("Cons_Sheet")
On Error GoTo 0
If Not shC Is Nothing Then
shC.UsedRange.ClearContents
Else
Set shC = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.count))
shC.name = "Cons_Sheet"
End If
'drop the processed array content in the new added sheet:
shC.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
MsgBox "Ready..."
End Sub
Function buildArr(arrF, arrC, i As Long) As Variant
If i = 1 Then arrF = arrC: buildArr = arrF: Exit Function 'use the first returned array
Dim arrSum, j As Long, k As Long
arrSum = WorksheetFunction.Transpose(arrF)
ReDim Preserve arrSum(1 To UBound(arrF, 2), 1 To UBound(arrF) + UBound(arrC))
k = UBound(arrF)
For i = 1 To UBound(arrC)
k = k + 1
For j = 1 To UBound(arrC, 2)
arrSum(j, k) = arrC(i, j)
Next j
Next i
buildArr = WorksheetFunction.Transpose(arrSum)
End Function

Answer 2

You can Just use this formula.
I choose 3 different range in the formula just to show you, you can use any kind of range for this to work.
=FILTERXML(""&SUBSTITUTE(TEXTJOIN(",",TRUE,Table1[Fruits Name],Sheet3!E2:E128,Sheet4!A2:A73),",","")&"","//y")