Copy entire row if cell is not empty - VBA

[pantakos]

Hello,

There is a need to copy contents from a sheet if the value of a specific cell is NOT 0 or it is blank.
Need to copy the entire row and its contents to another sheet. Basically need to create rows in target sheet and not overwriten them.
Lets say that the source sheet is AUDIO and the target is TEST1. The value that needed to check is range B13:B25
Can this be done with multiple source sheets and multiple source ranges? All will copied to the same target sheet.

I have found some posts in mrexcel but I cant make them to work properly (maybe multiple criteria are wrong)

Can you help?

Thank you in advance!

 

[pantakos]

This should work. It may need some minor modifications, based on the structure of your data sheets (I assumed your data is in columns B-E in rows 13:25, as your original code was looking in E13:E25).

Sub BuildInvoice()

    Dim ws
    Dim i As Long
    Dim cell As Range
    Dim Descript As String
    Dim PPD As Double
    Dim PCS As Long
    Dim nr As Long
   
    Application.ScreenUpdating = False
   
'   Set array of worksheet names to copy from
    ws = Array("AUDIO", "LIGHTS")
   
    For i = LBound(ws) To UBound(ws)
'       Iterate through column D on each sheet looking for pieces
        For Each cell In Sheets(ws(i)).Range("E13:E25")
'           See if anything entered in pieces
            If cell > 0 Then
                Descript = cell.Offset(0, -3)  'get description from column B
                PPD = cell.Offset(0, -1) 'get price p/d from column D
                PCS = cell  'get pieces from column E
'               Find next available row in column A on Invoice sheet
                nr = Sheets("Invoice").Cells(Rows.Count, "A").End(xlUp).Row + 1
'               Populate values on Invoice sheet
                Sheets("Invoice").Cells(nr, "A") = Descript
                Sheets("Invoice").Cells(nr, "B") = PCS
                Sheets("Invoice").Cells(nr, "C") = PPD
            End If
        Next cell
    Next i
   
    Application.ScreenUpdating = False
   
    MsgBox "Invoice built!"
       
End Sub

wow! super fast ! I will try it and let you know!
Thank you very very much!

 

[Joe4]

You are welcome.

 

[pantakos]

You are welcome.

Hello again,

It works fine! Thank you!
Something more is I can ask, is it possible to start creating invoice from row A15 , as from A1 to A14 there are logos etc
About the source range, is it possible to be "E13:E25", "F13:F25" etc to have more than one source range? For more Sheets I understand that I have to insert them to ws = Array , is this correct?

The target is the same.

Thank you!

 

[pantakos]

@Joe4 Can I use that ?

' Dim r1 As Range, r2 As Range, myMultiAreaRange As Range
' Set r1 = Range("E13:E25")
' Set r2 = Range("E49:E71")
' Set myMultiAreaRange = Union(r1, r2)
' myMultiAreaRange.Select

and put myMultiAreaRang and not Range ?

 

[Joe4]

Something more is I can ask, is it possible to start creating invoice from row A15 , as from A1 to A14 there are logos etc

You can add this a new row after this section:

'               Find next available row in column A on Invoice sheet
                nr = Sheets("Invoice").Cells(Rows.Count, "A").End(xlUp).Row + 1

that looks like this:

If nr < 15 Then nr = 15

Regarding your question on your ranges, I think that should work.
Easiest way to find out is to try it and see if it works!

 

[pantakos]

You can add this a new row after this section:

'               Find next available row in column A on Invoice sheet
                nr = Sheets("Invoice").Cells(Rows.Count, "A").End(xlUp).Row + 1

that looks like this:

If nr < 15 Then nr = 15

Regarding your question on your ranges, I think that should work.
Easiest way to find out is to try it and see if it works!

I did the nr < 15, first doesnt working ... then I realised that there where merged cells! so unmerge and voila! worked just fine ! Thank you once again!
About the range I will try and if stuck somewhere I will let you know.
About the sheets if I put 4 sheets to check there is an error
The code is

ws = Array("AUDIO", "LIGHTS", "DCM")

and if I insert more, crashed
Three sheets are the max?

Thank you !!!

 

[Joe4]

I did the nr < 15, first doesnt working ... then I realised that there where merged cells! so unmerge and voila! worked just fine

Yes, merged cells are VERY problematic for things like VBA and other simple tasks (like sorting). I highly recommend never using them.
If just merging cells across single rows, you can usually accomplish the same visual effects without all the issues that merged cells cause by using the "Center Across Selection" formatting option instead. See: Tom’s Tutorials For Excel: Using Center Across Selection Instead of Merging Cells – Tom Urtis

About the sheets if I put 4 sheets to check there is an error
The code is

ws = Array("AUDIO", "LIGHTS", "DCM")

and if I insert more, crashed
Three sheets are the max?

No, I have done a lot more than 3 or 4 sheets before without issues. If you are getting an error, it may be do to something else (the strucuture of one of your sheets, or the data in one of the sheets).
Try just doing one or two sheets in a test, including the one that is causing the error. And make note of which line of code is causing the error (hit the "Debug" button, if that option exists, and see which line of code it highlights).

Note, if you have a whole bunch of sheets in your workbook, and you only want to skip one or two, instead of storing all the different sheet names in an array, you can simply loop through all sheets, and skip if the sheet is a particular name, i.e.

For Each ws in Worksheets
    If ws.Name = "Invoice1" or ws.Name = "Invoce2" Then
'      do nothing
    Else
'       your main code here
    End If
Next ws

So that structure above would ignore any sheet named "Invoice1" or "Invoice2", and process all the others.

Next ws

 

[pantakos]

Yes, merged cells are VERY problematic for things like VBA and other simple tasks (like sorting). I highly recommend never using them.
If just merging cells across single rows, you can usually accomplish the same visual effects without all the issues that merged cells cause by using the "Center Across Selection" formatting option instead. See: Tom’s Tutorials For Excel: Using Center Across Selection Instead of Merging Cells – Tom Urtis


No, I have done a lot more than 3 or 4 sheets before without issues. If you are getting an error, it may be do to something else (the strucuture of one of your sheets, or the data in one of the sheets).
Try just doing one or two sheets in a test, including the one that is causing the error. And make note of which line of code is causing the error (hit the "Debug" button, if that option exists, and see which line of code it highlights).

Note, if you have a whole bunch of sheets in your workbook, and you only want to skip one or two, instead of storing all the different sheet names in an array, you can simply loop through all sheets, and skip if the sheet is a particular name, i.e.

For Each ws in Worksheets
    If ws.Name = "Invoice1" or ws.Name = "Invoce2" Then
'      do nothing
    Else
'       your main code here
    End If
Next ws

So that structure above would ignore any sheet named "Invoice1" or "Invoice2", and process all the others.

Next ws

Yes, I made it work ! Excel was a mess ... so I fix formatings and everything ok.
Now, I will try Range!
I only have 4 sheets, so its ok! thanks

 

[pantakos]

Range, first error

Sub BuildInvoice()


    Dim ws
    Dim i As Long
    Dim cell As Range
    Dim Descript As String
    Dim PPD As Double
    Dim PCS As Long
    Dim nr As Long
    Dim r1 As Range, r2 As Range, myMultiAreaRange As Range
    
    Application.ScreenUpdating = False
   
'   ' Set array of worksheet names to copy from
    ws = Array("AUDIO", "LIGHTS", "DCM", "HTD")
    Set r1 = Range("E13:E25")
    Set r2 = Range("E33:E39")
    Set myMultiAreaRange = Union(r1, r2)
    'myMultiAreaRange.Select
   
    For i = LBound(ws) To UBound(ws)
'       Iterate through column D on each sheet looking for pieces
        For Each cell In Sheets(ws(i)).myMultiAreaRange
'           See if anything entered in pieces
            If cell > 0 Then
                Descript = cell.Offset(0, -3)  'get description from column B
                PPD = cell.Offset(0, -1) 'get price p/d from column D
                PCS = cell  'get pieces from column E
'               Find next available row in column A on Invoice sheet
                nr = Sheets("PROFORMA").Cells(Rows.Count, "A").End(xlUp).Row + 1
                If nr < 15 Then nr = 15
'               Populate values on Invoice sheet
                Sheets("PROFORMA").Cells(nr, "A") = Descript
                Sheets("PROFORMA").Cells(nr, "B") = PCS
                Sheets("PROFORMA").Cells(nr, "C") = PPD
            End If
        Next cell
    Next i
   
    Application.ScreenUpdating = False
   
    MsgBox "Invoice built!"
       
End Sub

?

 

[Joe4]

You don't want to build your range until you are inside the loop, so that they will apply to each sheet.
If you build them outside of the loop, they will just be applied to whatever the active sheet was when you started running the code (and will not change at all after that).
And you need to include the worksheet reference when building the initial ranges.

So, try something like this:

Sub BuildInvoice()


    Dim ws
    Dim i As Long
    Dim cell As Range
    Dim Descript As String
    Dim PPD As Double
    Dim PCS As Long
    Dim nr As Long
    Dim r1 As Range, r2 As Range, myMultiAreaRange As Range
    
    Application.ScreenUpdating = False
   
'   ' Set array of worksheet names to copy from
    ws = Array("AUDIO", "LIGHTS", "DCM", "HTD")
   
'   Loop through all shees inthe array
    For i = LBound(ws) To UBound(ws)
        Set r1 = Sheets(ws(i)).Range("E13:E25")
        Set r2 = Sheets(ws(i)).Range("E33:E39")
        Set myMultiAreaRange = Union(r1, r2)
'       Iterate through column D on each sheet looking for pieces
        For Each cell In Sheets(ws(i)).myMultiAreaRange
'           See if anything entered in pieces
            If cell > 0 Then
                Descript = cell.Offset(0, -3)  'get description from column B
                PPD = cell.Offset(0, -1) 'get price p/d from column D
                PCS = cell  'get pieces from column E
'               Find next available row in column A on Invoice sheet
                nr = Sheets("PROFORMA").Cells(Rows.Count, "A").End(xlUp).Row + 1
                If nr < 15 Then nr = 15
'               Populate values on Invoice sheet
                Sheets("PROFORMA").Cells(nr, "A") = Descript
                Sheets("PROFORMA").Cells(nr, "B") = PCS
                Sheets("PROFORMA").Cells(nr, "C") = PPD
            End If
        Next cell
    Next i
   
    Application.ScreenUpdating = False
   
    MsgBox "Invoice built!"
       
End Sub