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.

CodePudding user response：

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

CodePudding user response：

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