Copy multiple columns based on header name of all the sheets

[mansoorsak]

I am looking for VBA code that can copy the data of multiple (4) columns based on header names from all the sheets in a workbook and paste (append the data of all the sheets) it into another sheet in the same workbook, where the values in one of the columns header should be <> 0.


For example
Out of say 30 column headers in sheet4, look for column headers with the name "order_id", "product_id", "short_charged_new" & "warehouse_state".
Then copy the values to "Sheet 1" in first 4 columns with the name "order_id", "product_id", "short_charged_new" & "warehouse_state" and in column 5 it should filldown the sheet name (sheet4) from the sheet where we copy the data . Here the copied values in column "short_charged_new" <> 0. Likewise it should search for columns & copy the data based on about criteria of all the sheets in the same workbook and paste (append) the data in sheet1 (first 4 columns) apart from sheet 1, sheet 2 & sheet 3.

 

[mumps]

Are you saying that you want to copy all the values in the columns that do not equal zero?

 

[mansoorsak]

Nope..values in only column "short_charged_new" should not be equal to zero...

 

[mumps]

Untested:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, ws As Worksheet, desWS As Worksheet, colArr As Variant _
        , order As Long, prod As Long, short As Long, ware As Long, i As Long
    Set desWS = Sheets("Sheet1")
    colArr = Array("order_id", "product_id", "short_charged_new", "warehouse_state")
    For Each ws In Sheets
        If ws.Name <> "Sheet1" Then
            LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For i = LBound(colArr) To UBound(colArr)
                Select Case colArr(i).Value
                    Case "order_id"
                        order = ws.Rows(1).Find("order_id", LookIn:=xlValues, lookat:=xlWhole).Column
                        ws.Range(ws.Cells(2, order), ws.Cells(LastRow, order)).Copy desWS.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                    Case "product_id"
                        prod = ws.Rows(1).Find("product_id", LookIn:=xlValues, lookat:=xlWhole).Column
                        ws.Range(ws.Cells(2, prod), ws.Cells(LastRow, prod)).Copy desWS.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                    Case "short_charged_new"
                        short = ws.Rows(1).Find("short_charged_new", LookIn:=xlValues, lookat:=xlWhole).Column
                        With ws.Range("A1").CurrentRegion
                            .AutoFilter short, "<>0"
                            ws.Range(ws.Cells(2, short), ws.Cells(LastRow, short)).SpecialCells(xlCellTypeVisible).Copy _
                                desWS.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
                            .AutoFilter
                        End With
                    Case "warehouse_state"
                        ware = ws.Rows(1).Find("warehouse_state", LookIn:=xlValues, lookat:=xlWhole).Column
                        ws.Range(Cells(2, ware), ws.Cells(LastRow, ware)).Copy desWS.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
                End Select
            Next i
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[mansoorsak]

It's not working
Can we please change the following:
1. If these column headers "order_id", "product_id", "short_charged_new" are not found in the sheet then it should skip to next sheet (should not copy anything from that sheet).
2. In sheet1 can we add additional column called "sheet name" apart from these 4 columns "order_id", "product_id", "short_charged_new", "warehouse_state" to highlight the name of the sheet from where we copied the data.
3. Just pasting the sample data of all the columns "order_id" 171-0000165-1373900, "product_id" B087PYDQCR , "short_charged_new" 2087.92 to specify the right data type

 

[mumps]

Must all three headers be found in the sheet? What if only two headers are found? What about "warehouse_state"? Must that header also be in the sheet? I think that it would be easier to help and test possible solutions if I could work with your actual file which includes any macros you are currently using. Perhaps you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[mansoorsak]

yes, all the three headers should be there, if one of these 3 headers are missing then it should go to next sheet. Please ignore "warehouse_state". Please find below the link of the file uploaded in dropbox
https://www.dropbox.com/s/isf7q3hah3e8724/PTC data.xlsm?dl=0

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, header As Range, ws As Worksheet, desWS As Worksheet, colArr As Variant, colArr2 As Variant _
        , order As Long, prod As Long, short As Long, ware As Long, i As Long, bottomD As Long, bottomE As Long
    Set desWS = Sheets("Sheet1")
    colArr = Array("order_id", "product_id", "short_charged_new", "warehouse_state")
    colArr2 = Array("order_id", "product_id", "short_charged_new")
    For Each ws In Sheets
        If ws.Name <> "Sheet1" Then
            For i = LBound(colArr2) To UBound(colArr2)
                Set header = ws.Rows(1).Find(colArr2(i))
                If header Is Nothing Then GoTo cont
            Next i
            LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For i = LBound(colArr) To UBound(colArr)
                Select Case colArr(i)
                    Case "order_id"
                        order = ws.Rows(1).Find("order_id", LookIn:=xlValues, lookat:=xlWhole).Column
                        ws.Range(ws.Cells(2, order), ws.Cells(LastRow, order)).Copy desWS.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                    Case "product_id"
                        prod = ws.Rows(1).Find("product_id", LookIn:=xlValues, lookat:=xlWhole).Column
                        ws.Range(ws.Cells(2, prod), ws.Cells(LastRow, prod)).Copy desWS.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                    Case "short_charged_new"
                        short = ws.Rows(1).Find("short_charged_new", LookIn:=xlValues, lookat:=xlWhole).Column
                        With ws.Range("A1").CurrentRegion
                            .AutoFilter short, "<>0"
                            ws.Range(ws.Cells(2, short), ws.Cells(LastRow, short)).SpecialCells(xlCellTypeVisible).Copy _
                                desWS.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
                            .AutoFilter
                        End With
                    Case "warehouse_state"
                        ware = ws.Rows(1).Find("warehouse_state", LookIn:=xlValues, lookat:=xlWhole).Column
                        ws.Range(ws.Cells(2, ware), ws.Cells(LastRow, ware)).Copy desWS.Cells(desWS.Rows.Count, "D").End(xlUp).Offset(1, 0)
                End Select
            Next i
            With desWS
                bottomD = .Range("D" & .Rows.Count).End(xlUp).Row
                bottomE = .Range("E" & .Rows.Count).End(xlUp).Row
                .Range("E" & bottomE + 1 & ":E" & bottomD) = ws.Name
            End With
        End If
cont:
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[mansoorsak]

Sorry for multiple Iterations, it's not working because the data is going beyond 1048576 rows. Can we filter non zero values first in column "short_charged_new" and then copy the data to sheet 1 instead of first copy the entire column and then remove zeros?

 

[mumps]

The macro is doing that already. It filters first and then copies only the visible rows.