Copy range of data from multiple worksheets based on numerical criteria

[CampbellSoup]

I have been playing with this code for a few days now. I have a spreadsheet that has about 10 tabs. Only 4 of the tabs I need to use for this code.

I created a master sheet called "Quickbooks" to make uploading materials into QB easier for the team and save hours a week for the production staff.

- They are all 4 formatted the same. "Data Take-Off", "Security Take-Off", "Electrical Take-Off", "AV Map Take-Off". We just use a different worksheet for each department to keep them separated during estimating.
- Column D is where the number will be at for the unit amounts.
-Range C-H of that particular row is what I need to copy to the "Quickbooks" sheets if a number is populated in D. "Next available row"
-I also need to be able to do this across all 4 worksheets simultaneously so I can keep the formatting of the "Quickbooks" sheet intact as shown below, unless there is an easier way to "rinse and repeat". This being because sometimes we go in and update quantities on these sheets last minute and will need to update the master sheet with the new quantities and not duplicate line items for quickbooks purposes.

Here is the basic code I got to work on a dummy spreadsheet when only dealing with one sheet at a time. I just can't seem to figure out how to call on multiple worksheets at the same time with the same commands "IF"/"THEN".

Sub qbcopy()

Dim i, lastrow

lastrow = Sheets("Data Take-Off").Range("D" & Rows.Count).End(xlUp).Row
Sheets("Quickbooks").Range("A2:I1500").ClearContents
Sheets("Quickbooks").Range("A2:I1500").ClearFormats
For i = 30 To lastrow
If Sheets("Data Take-Off").Cells(i, "D").Value > 0 Then
Sheets("Data Take-Off").Range(Cells(i, "C"), Cells(i, "H")).Copy
Destination:=Sheets("Quickbooks").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End Sub

 

[JLGWhiz]

See how this works for you

Sub qbCopy()
Dim ary As Variant, i As Long, rng As Range
ary = Array("Data Take-Off", "Security Take-Off", "Electrical Take-Off", "AV Map Take-Off")
Sheets("QuickBooks").UsedRange.Offset(1).ClearContents
    For i = LBound(ary) To UBound(ary)
        With Sheets(ary(i))
            Set rng = .Range("C30:H" & .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row)
            rng.AutoFilter 2, ">0"
            If Application.CountA(rng.SpecialCells(xlCellTypeVisible)) > 0 Then
                rng.SpecialCells(xlCellTypeVisible).Copy _
                Sheets("QuickBooks").Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            .AutoFilterMode = False
        End With
    Next
End Sub

 

[CampbellSoup]

Wow. I was WAYYY off. This is excellent JLGWHIZ. I'm sure you have saved us a lot of effort. Much appreciated. I was able to make some slight modifications with ease.

 

[JLGWhiz]

Wow. I was WAYYY off. This is excellent JLGWHIZ. I'm sure you have saved us a lot of effort. Much appreciated. I was able to make some slight modifications with ease.

Thanks for the feedback,
Regards, JLG

 

[CampbellSoup]

JLG,

Question. In the code provided, it is adding the first line reverenced in the range even through there is no value in the D column. Apparently QB doesn't like this blank line and I have tried to modify the code to not include the blank line and only include the rows that contain a number in the D column. Here is the slightly modified code.

Dim ary As Variant, i As Long, rng As Range
ary = Array("Data Take-Off", "Security Take-Off", "Electrical Take-Off", "AV Map Take-Off", "NG Take-Off")
Sheets("QuickBooks").UsedRange.Offset(1).ClearContents
Sheets("Quickbooks").Range("A2:I1500").ClearContents
Sheets("Quickbooks").Range("A2:I1500").ClearFormats
    For i = LBound(ary) To UBound(ary)
        With Sheets(ary(i))
            Set rng = .Range("C25:H" & .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row)
            rng.AutoFilter 2, ">0"
            If Application.CountA(rng.SpecialCells(xlCellTypeVisible)) > 0 Then
                rng.SpecialCells(xlCellTypeVisible).Copy _
                Sheets("QuickBooks").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            End If
            .AutoFilterMode = False
        End With
    Next
End Sub

****** id="cke_pastebin" style="position: absolute; top: 0px; width: 1px; height: 1px; overflow: hidden; left: -1000px;">Dim ary As Variant, i As Long, rng As Range
ary = Array("Data Take-Off", "Security Take-Off", "Electrical Take-Off", "AV Map Take-Off", "NG Take-Off")
Sheets("QuickBooks").UsedRange.Offset(1).ClearContents
Sheets("Quickbooks").Range("A2:I1500").ClearContents
Sheets("Quickbooks").Range("A2:I1500").ClearFormats
For i = LBound(ary) To UBound(ary)
With Sheets(ary(i))
Set rng = .Range("C25:H" & .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row)
rng.AutoFilter 2, ">0"
If Application.CountA(rng.SpecialCells(xlCellTypeVisible)) > 0 Then
rng.SpecialCells(xlCellTypeVisible).Copy _
Sheets("QuickBooks").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
.AutoFilterMode = False
End With
Next
End Sub
</body>

 

[JLGWhiz]

On which row does your headers reside and on which row does your data begin on the source sheets? It is difficult to solve the issue without some Idea of your sheet layout.

 

[CampbellSoup]

On which row does your headers reside and on which row does your data begin on the source sheets? It is difficult to solve the issue without some Idea of your sheet layout.

Headers reside on row 13. Data begins on row 25. But I only need the range of data from rows where there is a quantity greater than 0 in the D column. The script worked great and I was ok with it. But to import into excel the blank row has to be deleted prior to import. So the script starts at C25 (Set rng = .Range("C25:H") and references D column to check for quantities for the copy. But there isn't always a quantity in D25 yet the script copies that first row referenced in the range anyways then filters for quantities.

 

[JLGWhiz]

Let's try this one.

Sub qbCopy2()
Dim ary As Variant, i As Long, rng As Range, strt As Range, lr As Long
ary = Array("Data Take-Off", "Security Take-Off", "Electrical Take-Off", "AV Map Take-Off")
Sheets("QuickBooks").UsedRange.Offset(1).ClearContents
    For i = LBound(ary) To UBound(ary)
        With Sheets(ary(i))
            lr = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
            If .Cells(25, "D") = "" Then
                Set strt = .Cells(25, "D").End(xlDown)
            Else
                Set strt = .Cells(25, "D")
            End If
            Set rng = .Range(strt, "H" & lr)
            rng.AutoFilter 2, "<>0"
            If Application.CountA(rng.SpecialCells(xlCellTypeVisible)) > 0 Then
                rng.SpecialCells(xlCellTypeVisible).Copy _
                Sheets("QuickBooks").Cells(Rows.Count, 1).End(xlUp)(2)
            End If
            .AutoFilterMode = False
        End With
    Next
End Sub

 

[CampbellSoup]

So I have updated it a bit and this got it working with no blank rows.

However, its not copying in the data from column C if the ">0" condition is met in column D. I need the copy range to be C:H. But the condition is in D.

When I change the "strt" it copies in ALL rows because that condition is always met in column C but i need it to reference Column D.

Here is what I got to work with no blank rows.

Sub QBcopy()

Dim ary As Variant, i As Long, rng As Range, strt As Range, lr As Long
ary = Array("Data Take-Off", "Security Take-Off", "Electrical Take-Off", "AV Map Take-Off")
Sheets("QuickBooks").UsedRange.Offset(1).ClearContents
Sheets("Quickbooks").Range("A2:I1500").ClearContents
Sheets("Quickbooks").Range("A2:I1500").ClearFormats
    For i = LBound(ary) To UBound(ary)
        With Sheets(ary(i))
             lr = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
            If .Cells(25, "D") = "" Then
                Set strt = .Cells(25, "D").End(xlDown)
            Else
                Set strt = .Cells(25, "D")
            End If
            Set rng = .Range(strt, "H" & lr)
            rng.AutoFilter 1, ">0"
            If Application.CountA(rng.SpecialCells(xlCellTypeVisible)) > 0 Then
                rng.SpecialCells(xlCellTypeVisible).Copy _
                Sheets("QuickBooks").Cells(Rows.Count, 1).End(xlUp).Offset(1)
            End If
            .AutoFilterMode = False
        End With
    Next
End Sub

 

[JLGWhiz]

Sorry about that, I was concentrating on getting the blanks out and inadvertantly changed deleted reference to column C. This should do it.

Sub QBcopy()
Dim ary As Variant, i As Long, rng As Range, strt As Range, lr As Long
ary = Array("Data Take-Off", "Security Take-Off", "Electrical Take-Off", "AV Map Take-Off")
Sheets("QuickBooks").UsedRange.Offset(1).ClearContents
Sheets("Quickbooks").Range("A2:I1500").ClearContents
Sheets("Quickbooks").Range("A2:I1500").ClearFormats
    For i = LBound(ary) To UBound(ary)
        With Sheets(ary(i))
             lr = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
            If .Cells(25, "D") = "" Then
                Set strt = .Cells(25, "D").End(xlDown).Offset(, -1)
            Else
                Set strt = .Cells(25, "C")
            End If
            Set rng = .Range(strt, "H" & lr)
            rng.AutoFilter 1, ">0"
            If Application.CountA(rng.SpecialCells(xlCellTypeVisible)) > 0 Then
                rng.SpecialCells(xlCellTypeVisible).Copy _
                Sheets("QuickBooks").Cells(Rows.Count, 1).End(xlUp).Offset(1)
            End If
            .AutoFilterMode = False
        End With
    Next
End Sub