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.

 

[mansoorsak]

Is it filtering non zeros from column "short_charged_new" and then copying the data ?

 

[mumps]

Yes it is. Check your destination sheet after you run the macro and see if any rows for that sheet contain zeros.

 

[mansoorsak]

Something is wrong here, macro is throwing a run time error 1004 with the message "You can't paste this here because the copy area and paste area aren't same size. Select just once cell in the paste area or an area that's the same size, and try pasting again."

It seems like the data is going beyond excel limit of 1048576 rows which shouldn't be the case as I have manually checked the final result after appending the copied data from all the sheets based on the specified criteria & it should be less than 6k rows.

Is it copying the filtered data of all the 4 columns (i.e order_id, product_id, short_charged_new & warehouse_state) after filtering non zeros in "short_charged_new" column.

 

[mumps]

In Post#2 I asked:

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

In Post# 3 you responded:

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

You didn't say anything about filtering the other columns. If you want to filter all the columns, then I need to know the filter criteria for the other 3 columns.

 

[mansoorsak]

yes, the filtering criteria is just one "short_charged_new" values should not be equal to zero. It should copy all the 4 columns data after filtering the non zeros from "short_charged_new". Example out of say total 100 rows in a sheet there are 30 rows with the numbers not equal to zero in "short_charged_new" column, then it should copy this column filtered with non zero rows along with the corresponding data of other 3 columns of these 30 rows only.

With the data I have, if we copy the data in the above manner then the total copied result of the all the sheets won't be more than 6k rows.

Hope it is clear now

 

[mansoorsak]

I really appreciate for your patience and support you have shown in looking into my issues.

 

[mansoorsak]

I am also getting error when there are only zeros (no other numbers apart from 0) in column "short_charged_new". Can we also skip the sheets from copying which has only zero in "short_charged_new" column

 

[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", "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
            short = ws.Rows(1).Find("short_charged_new", LookIn:=xlValues, lookat:=xlWhole).Column
            With ws.Range("A1").CurrentRegion
                .AutoFilter short, "<>0"
                If ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row > 1 Then
                    ws.Range(ws.Cells(2, short), ws.Cells(LastRow, short)).SpecialCells(xlCellTypeVisible).Copy _
                        desWS.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
                Else
                    GoTo cont
                End If
            End With
            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)).SpecialCells(xlCellTypeVisible).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)).SpecialCells(xlCellTypeVisible).Copy _
                            desWS.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                    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)).SpecialCells(xlCellTypeVisible).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
            ws.Range("A1").AutoFilter
        End If
cont:
    Next ws
    Application.ScreenUpdating = True
End Sub

 

[mansoorsak]

Thanks a lot Mumps!! it's working fine

 

[mumps]

My pleasure.