• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Combining sheets

I would really appreciate if someone can help me with this inquiry as I have to do this task every week and looking for some easy way.

I have attached the excel (sample). Attached sheet has only 2 sheets for example, but the original file has over 35- 40 sheets, how can i combine this information into a single sheet? as i have to create a table and the apply filter to do the further analysis

Thank you for helping!
 

Attachments

  • Book1.xlsx
    13 KB · Views: 16
The following code can be in any workbook but it acts on whichever workbook is the active workbook, adding a new sheet to it and running through the sheets in that active workbook, processing it if that sheet's cell A1 has the text 'Shortage Report' in it.
The resultant table is ready for pivoting or further filtering.
Code:
Sub blah()
With ActiveWorkbook
  Set NewSht = .Sheets.Add(after:=.Sheets(.Sheets.Count))
  NewSht.Range("A1:U1").Value = Array("JOB", "JOB ITEM", "JOB QTY", "ORDER DUE DATE", "Item Number", "Item Type", "Source", "Req Qty", "Ext Qty", "UOM", "Item Description", "Qty Issued", "On Hand", "PO", "Qty Due", "Due Date", "PO Confirmed", "Buyer", "Planner Code", "Vendor", "Vendor Name")

  Set Destn = NewSht.Range("A2")
  For Each Sht In .Worksheets
    'If Sht.Name <> NewSht.Name Then
    If InStr(1, Sht.Cells(1), "Shortage Report", vbTextCompare) > 0 Then
      Set mycell = Nothing
      Set mycell = Sht.UsedRange.Find("JOB ITEM", LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=False)
      If Not mycell Is Nothing Then
        Set rngFourHeaders = Union(mycell.Offset(, -1), mycell.Offset(, 1), mycell.Offset(, 3), mycell.Offset(, 5))
        Set rngMyTable = mycell.Offset(2).CurrentRegion
        Set rngMyTable = Intersect(rngMyTable, rngMyTable.Offset(1))
        rngFourHeaders.Copy Destn.Resize(rngMyTable.Rows.Count, 4)
        rngMyTable.Copy Destn.Offset(, 4)
        Set Destn = Destn.Offset(rngMyTable.Rows.Count)
      End If
    End If
  Next Sht
End With    'ActiveWorkbook
NewSht.Columns("A:U").AutoFit
End Sub

ps. I note that in your sample file, it looks like some of the Item Numbers in your file have been converted to dates when they shouldn't have been. You need to make sure these are not dates in the file before you start. This has been caused by the way that data got into Excel in the first place.
 
Last edited:
maybe?

Code:
Sub cons()
    Dim c As New Collection
    Dim a, b As Variant
    ReDim d(1 To ThisWorkbook.Sheets.Count)
    i = 1
    For Each sh In ThisWorkbook.Sheets
        sh.Activate

        a = Cells(6, 1).CurrentRegion.Offset(1).Value
        c.Add a
        d(i) = Array(c)
        i = i + 1
    Next
    ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "whatever"
    Sheet1.Range("a5:q5").Copy Sheets("whatever").Range("a1")
    l = 1
    For i = 1 To UBound(d)
        Sheets("whatever").Range("a" & l + 1, "q" & l + UBound(d(i)(0)(i)) - 1) = d(i)(0)(i)
        l = l + UBound(d(i)(0)(i)) - 1
    Next

End Sub
 
as i have to create a table and the apply filter to do the further analysis
According to your attachment a beginner starter demonstration to paste to the ThisWorkbook module :​
Code:
Sub Demo()
     Dim R&, Ws As Worksheet, L&
         R = 1
         Application.ScreenUpdating = False
    With Workbooks.Add.Worksheets(1)
        For Each Ws In Worksheets
            L = Ws.UsedRange.Rows.Count
            Ws.UsedRange.Rows(6 + (R = 1) & ":" & L).Copy .Cells(R, 1)
            R = R + L - 5 - (R = 1)
        Next
           .ListObjects.Add , .UsedRange, , xlYes
           .UsedRange.Columns.AutoFit
    End With
         Application.ScreenUpdating = True
End Sub
Do you like it ? So thanks to click on bottom right Like !​
 
maybe?

Code:
Sub cons()
    Dim c As New Collection
    Dim a, b As Variant
    ReDim d(1 To ThisWorkbook.Sheets.Count)
    i = 1
    For Each sh In ThisWorkbook.Sheets
        sh.Activate

        a = Cells(6, 1).CurrentRegion.Offset(1).Value
        c.Add a
        d(i) = Array(c)
        i = i + 1
    Next
    ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "whatever"
    Sheet1.Range("a5:q5").Copy Sheets("whatever").Range("a1")
    l = 1
    For i = 1 To UBound(d)
        Sheets("whatever").Range("a" & l + 1, "q" & l + UBound(d(i)(0)(i)) - 1) = d(i)(0)(i)
        l = l + UBound(d(i)(0)(i)) - 1
    Next

End Sub


Thank you so much! you are amazing :)
 
Back
Top