Copy entire row if cell is not empty - VBA

P

pantakos

Board Regular
Joined
Oct 10, 2012
Messages
158
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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!
 
Sort by date Sort by votes
Joe4 said:
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:
VBA Code: 
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
Click to expand...
I really dont know what to say for your help!
I really appreciate that!
The same error again though.
1621527128978.png
 
Upvote 0

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
OK, since we built r1 and r2 to already include the sheet reference, we actually do not need to include it in our myMultiAreaRange reference, i.e.
VBA Code: 
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 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
 
Upvote 0
Solution
Joe4 said:
OK, since we built r1 and r2 to already include the sheet reference, we actually do not need to include it in our myMultiAreaRange reference, i.e.
VBA Code: 
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 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
Click to expand...
ok you are the best !
 
Upvote 0
I know that I ask for to much, but if the tables are as follows

SPEAKERS QTYPRICE PER DAYPCSAMPLIFIERSQTYPRICE PER DAYPCS
CLAIR BROS C1216€110,000L-ACOUSTICS LA 4870€30,00
CLAIR BROS C8 16€50,000L-ACOUSTICS LA 2417€20,00
CLAIR BROS CS1184€50,000L-ACOUSTICS LA 177€15,00
L-ACOUSTICS V-DOSC40€80,000L-ACOUSTICS LA 153€20,00
L-ACOUSTICS dV-DOSC114€30,000L-ACOUSTICS LA 12X32€100,00
L-ACOUSTICS KUDO6€60,000L-ACOUSTICS LA 4X8€60,00
L-ACOUSTICS SYVASET L-R€310,000LAB GRUPPEN PLM 12K4410€100,00
L-ACOUSTICS ARCS WIDE16€40,000LAB GRUPPEN FP 1000010€25,00
L-ACOUSTICS X1524€45,000LAB GRUPPEN FP C68:46€20,00
L-ACOUSTICS X1224€35,000POWERSOFT K316€25,00
L-ACOUSTICS X816€30,000POWERSOFR M50Q16€20,00
L-ACOUSTICS FM11518€25,000YPSILON M100034€10,00
L-ACOUSTICS XT-1158€25,000YPSILON M200092€15,00
L-ACOUSTICS XT-128€20,000YPSILON S100018€15,00
L-ACOUSTICS MTD 108A12€20,000PROCESSORSQTYPRICE PER DAYPCS
L-ACOUSTICS KS 2824€80,000DRIVERACK CLAIR -WLS-SMAART-LM441€100,00
L-ACOUSTICS dV-SUB16€25,000XTA DP 4486€50,00
L-ACOUSTICS SB1816€35,000XTA DP 22616€25,00
EAW SB 100050€25,000XTA DP 2248€20,00
NEXO PS1547€20,000LLC 115FM14€5,00
NEXO PS 1012€20,000KLARK TEKNIK DN 80002€25,00
ELECTROVOICE ELX112p18€20,000NEXO TD PS 1531€5,00


With the script above (you create) I can check columns B D E is it possible depending on a cell value to change the range and check that range? I mean lets say is G1 equal to AMPLIFIERS then check range is J13:J25 ?

Thank you!
 
Upvote 0
You seem to be adding new conditions every time I give you new code. That is a very inefficient way of doing things.
Please do not oversimplify your actual scenario, and build up to your actual scenario by slowly adding in new conditions one a time.
Please state your actual problem/situation in its entirety from the start, so we can come up with code that does what you want without having to go through multiple iterations to get there.
 
Upvote 0
Joe4 said:
You seem to be adding new conditions every time I give you new code. That is a very inefficient way of doing things.
Please do not oversimplify your actual scenario, and build up to your actual scenario by slowly adding in new conditions one a time.
Please state your actual problem/situation in its entirety from the start, so we can come up with code that does what you want without having to go through multiple iterations to get there.
Click to expand...
You are right!
I figure it out and I just add Set r3 = Sheets(ws(i)).Range("J13:J25") and r4 etc and worked. I made different subs for every sheet (AUDIO, LIGHTS etc)
Worked that way
Thank you !
 
Upvote 0
@Joe4 I finally made the code (with your suggestions and help) and it is working fine! Thank you for you valuable help !
 
Upvote 0
Excellent.
Glad you got it working the way you need.
 
Upvote 0
@Joe4 Hello again.
I need your help if it is possible (and I am asking you because you know the case).
Can I use the Intersection in order to:
Within the source ranges (Union above etc) I need to find out if a cell that is already copied in Proforma, and the cell located to other sheets ranges (audio, lights etc), changed, can be then copied to proforms (entire row or the cell value, and delete the previous one).

Can this be done?
I have tried various examples with Intersection but no luck :(

Thank you in advance!
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Need VBA to automatically copy paste rows based factory selected
Replies
8
Views
164
Alex Blakenburg
A
B
  • Question
VBA code to cut and paste multiple filtered rows based on multiple criteria
Replies
2
Views
488
Alex Blakenburg
A
D
  • Solved
Copy row based on cell value and paste as text in another worksheet
Replies
2
Views
477
DH937
D
tabbytomo
  • Solved
Copy entire row if cell has specific value, looking at multiple columns and worksheets.
Replies
2
Views
289
NateSC
NateSC
K
  • Solved
VBA Help!!! Paste Special Value based on Existing Code
Replies
3
Views
324
Armstrong_N14
A

Forum statistics

Threads
1,214,885
Messages
6,122,090
Members
449,065
Latest member
Danger_SF

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top