Locate Change VBA (Intersection)

[pantakos]

Hello,

I have the following code that locates and copy cell value (if the cell is >0) from a sheet (AUDIO) to another sheet (PROFORMA DRYHIRE). What I want to do is,if a cell that is already copied to Proforma has beed changed (value), if the new value can be copied to proforma sheet (entire row or the cell value) by overwritten the previous one.
Can I use the Intersection to do that or there is another way?

I have tried various examples with Intersection but no luck

PRICE LIST 2021 FINAL.xlsm
	B	C	D	E	F	G	H	I	J	K
1
2								audio equipment - 1
3
4
5
6
7
8
9
10								TOTAL	0,00
11
12	R1 SPEAKERS	QTY	PRICE PER DAY	PCS		AMPLIFIERS	QTY	PRICE PER DAY	PCS
13	CLAIR BROS C12	16	€110,00		0	L-ACOUSTICS LA 48	70	€30,00		0
14	CLAIR BROS C8	16	€50,00		0	L-ACOUSTICS LA 24	17	€20,00		0
15	CLAIR BROS CS118	4	€50,00		0	L-ACOUSTICS LA 17	7	€15,00		0
16	L-ACOUSTICS V-DOSC	40	€80,00		0	L-ACOUSTICS LA 15	3	€20,00		0
17	L-ACOUSTICS dV-DOSC	114	€30,00		0	L-ACOUSTICS LA 12X	32	€100,00		0
18	L-ACOUSTICS KUDO	6	€60,00		0	L-ACOUSTICS LA 4X	8	€60,00		0
19	L-ACOUSTICS SYVA	SET L-R	€310,00		0	LAB GRUPPEN PLM 12K44	10	€100,00		0
20	L-ACOUSTICS ARCS WIDE	16	€40,00		0	LAB GRUPPEN FP 10000	10	€25,00		0
21	L-ACOUSTICS X15	24	€45,00		0	LAB GRUPPEN FP C68:4	6	€20,00		0
22	L-ACOUSTICS X12	24	€35,00		0	POWERSOFT K3	16	€25,00		0
23	L-ACOUSTICS X8	16	€30,00		0	POWERSOFR M50Q	16	€20,00		0
24	L-ACOUSTICS FM115	18	€25,00		0	YPSILON M1000	34	€10,00		0
25	L-ACOUSTICS XT-115	8	€25,00		0	YPSILON M2000	92	€15,00		0
26	L-ACOUSTICS XT-12	8	€20,00		0	YPSILON S1000	18	€15,00		0
27	L-ACOUSTICS MTD 108A	12	€20,00		0					0
28	L-ACOUSTICS KS 28	24	€80,00		0					0
29	L-ACOUSTICS dV-SUB	16	€25,00		0					0
30	L-ACOUSTICS SB18	16	€35,00		0					0
31	EAW SB 1000	50	€25,00		0	PROCESSORS	QTY	PRICE PER DAY	PCS
32	NEXO PS15	47	€20,00		0	DRIVERACK CLAIR -WLS-SMAART-LM44	1	€100,00		0
33	NEXO PS 10	12	€20,00		0	XTA DP 448	6	€50,00		0
34	ELECTROVOICE ELX112p	18	€20,00		0	XTA DP 226	16	€25,00		0
35	SLS LS 8800	72	€20,00		0	XTA DP 224	8	€20,00		0
36					0	LLC 115FM	14	€5,00		0
37					0	KLARK TEKNIK DN 8000	2	€25,00		0
38					0	NEXO TD PS 15	31	€5,00		0
39					0	NEXO TD PS 10	5	€5,00		0
40					0					0
41										0
42										0
43					0					0
44			TOTAL	€0,00				TOTAL	€0,00
AUDIO

Cell Formulas
Range	Formula
J10	J10	=SUM(E44,J44,E85,J85,E132,J132,E192,J198)
K32:K43,F43,F13:F40,K13:K30	K13	=I13*J13
E44,J44	E44	=SUM(F13:F43)

The sheet (AUDIO) is bigger , just post it for example

PROFORMA-DRYHIRE example

PRICE LIST 2021 FINAL.xlsm
	A	B	C	D
1
2		ΥΠΕΥΘΥΝΟΣ
3	ΠΡΟΣΦΟΡΑ / PRO-FORMA	ΠΕΛΑΤΗΣ
4	NO:	ΥΠΟΨΙΝ
5		ΔΙΕΥΘΥΝΣΗ
6		ΠΟΛΗ
7		ΑΦΜ
8		ΔOY
9		ΤΗΛ
10		email
11		ΠΑΡΑΓΩΓΗ
12		ΠΕΡΙΟΔΟΣ
13
14	ΤΥΠΟΣ - ΠΕΡΙΓΡΑΦΗ	ΤΕΜΑΧΙΑ	ΤΙΜΗ ΜΟΝΑΔΟΣ	ΣΥΝΟΛΟ
15				0,00 €
16				0,00 €
17				0,00 €
18				0,00 €
19				0,00 €
20				0,00 €
21				0,00 €
22				0,00 €
23				0,00 €
24				0,00 €
25				0,00 €
26				0,00 €
27				0,00 €
28				0,00 €
29				0,00 €
30				0,00 €
31				0,00 €
PROFORMA DRYHIRE

Cell Formulas
Range	Formula
D15:D31	D15	=B15*C15

Sub BuildInvoiceAudio()

    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, r3 As Range, r4 As Range, r5 As Range, r6 As Range, r7 As Range, r8 As Range, r9 As Range, r10 As Range, r11 As Range, r12 As Range, r13 As Range, r14 As Range, myMultiAreaRange As Range
    
    Application.ScreenUpdating = False
   
'   ' Set array of worksheet names to copy from
    ws = Array("AUDIO")
   
    
'   Loop through all shees inthe array
    For i = LBound(ws) To UBound(ws)
        Set r1 = Sheets(ws(i)).Range("E13:E43")
        Set r2 = Sheets(ws(i)).Range("J13:J30")
        Set r3 = Sheets(ws(i)).Range("J32:J43")
        Set r4 = Sheets(ws(i)).Range("E57:E84")
        Set r5 = Sheets(ws(i)).Range("J57:J84")
        Set r6 = Sheets(ws(i)).Range("E100:E131")
        Set r7 = Sheets(ws(i)).Range("J100:J107")
        Set r8 = Sheets(ws(i)).Range("J109:J118")
        Set r9 = Sheets(ws(i)).Range("J120:J131")
        Set r10 = Sheets(ws(i)).Range("E146:E176")
        Set r11 = Sheets(ws(i)).Range("E178:E191")
        Set r12 = Sheets(ws(i)).Range("J146:J176")
        Set r13 = Sheets(ws(i)).Range("J178:J184")
        Set r14 = Sheets(ws(i)).Range("J186:J197")
                        
        Set myMultiAreaRange = Union(r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12, r13, r14)
        
'       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 DRYHIRE").Cells(Rows.Count, "A").End(xlUp).Row + 1
                If nr < 15 Then nr = 15
'               Populate values on Invoice sheet
                Sheets("PROFORMA DRYHIRE").Cells(nr, "A") = Descript
                Sheets("PROFORMA DRYHIRE").Cells(nr, "B") = PCS
                Sheets("PROFORMA DRYHIRE").Cells(nr, "C") = PPD
            End If
        Next cell
    Next i
   
    Application.ScreenUpdating = False

End Sub

Thank you in advance!

 

[pantakos]

Try this

Sub BuildInvoiceAudio()
  Dim ws As Variant, arr As Variant
  Dim i As Long, j As Long, nr As Long
  Dim cell As Range, f As Range, MultiRange As Range
  Dim Descript As String
   
  Application.ScreenUpdating = False
  '   ' Set array of worksheet names to copy from
  ws = Array("AUDIO")
  arr = Array("E13:E43", "J13:J30", "J32:J43", "E57:E84", "J57:J84", "E100:E131", "J100:J107", _
        "J109:J118", "J120:J131", "E146:E176", "E178:E191", "J146:J176", "J178:J184", "J186:J197")
  '   Loop through all shees inthe array
  For i = LBound(ws) To UBound(ws)
    Set MultiRange = Sheets(ws(i)).Range("A" & Rows.Count).End(3)(2)
    For j = 0 To UBound(arr)
      Set MultiRange = Union(MultiRange, Sheets(ws(i)).Range(arr(j)))
    Next
    For Each cell In MultiRange         'Loop through all cells inthe multirange
      If cell > 0 Then                  'See if anything entered in pieces
        Descript = cell.Offset(0, -3)   'get description from column B
        With Sheets("PROFORMA DRYHIRE")
          Set f = .Range("A15:A70").Find(Descript, , xlValues, xlWhole)
          If Not f Is Nothing Then
            nr = f.Row
          Else
            nr = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            If nr > 70 Then
              MsgBox "Rows are full"
              Exit Sub
            End If
            If nr < 15 Then nr = 15
          End If
          '               Populate values on PROFORMA sheet
          .Cells(nr, "A") = Descript
          .Cells(nr, "B") = cell                  'get pieces from column E
          .Cells(nr, "C") = cell.Offset(0, -1)    'get price p/d from column D
        End With
      End If
    Next cell
  Next i
  Application.ScreenUpdating = False
End Sub

You are the best !

 

[pantakos]

@DanteAmor ok... Its me again. When I run the sub, it displays the message that Rows are Full, even though they are not.

Here is the full code. There are four subs (Audio, Lights, Truss, Distro) so maybe because I have activate all, there is the error.

Sub Macro1()

    Call BuildInvoiceAudio
    Call BuildInvoiceLIGHTS
    Call BuildInvoiceHTD
    Call BuildInvoiceDCM

End Sub

Sub BuildInvoiceAudio()
  Dim ws As Variant, arr As Variant
  Dim i As Long, j As Long, nr As Long
  Dim cell As Range, f As Range, MultiRange As Range
  Dim Descript As String
    
  Application.ScreenUpdating = False
  '   ' Set array of worksheet names to copy from
  ws = Array("AUDIO")
  arr = Array("E13:E43", "J13:J30", "J32:J43", "E57:E84", "J57:J84", "E100:E131", "J100:J107", _
        "J109:J118", "J120:J131", "E146:E176", "E178:E191", "J146:J176", "J178:J184", "J186:J197")
  '   Loop through all shees inthe array
  For i = LBound(ws) To UBound(ws)
    Set MultiRange = Sheets(ws(i)).Range("A" & Rows.Count).End(3)(2)
    For j = 0 To UBound(arr)
      Set MultiRange = Union(MultiRange, Sheets(ws(i)).Range(arr(j)))
    Next
    For Each cell In MultiRange         'Loop through all cells inthe multirange
      If cell > 0 Then                  'See if anything entered in pieces
        Descript = cell.Offset(0, -3)   'get description from column B
        With Sheets("PROFORMA DRYHIRE")
          Set f = .Range("A15:A70").Find(Descript, , xlValues, xlWhole)
          If Not f Is Nothing Then
            nr = f.Row
          Else
            nr = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            If nr > 70 Then
              MsgBox "Rows are full"
              Exit Sub
            End If
            If nr < 15 Then nr = 15
          End If
          '               Populate values on PROFORMA sheet
          .Cells(nr, "A") = Descript
          .Cells(nr, "B") = cell                  'get pieces from column E
          .Cells(nr, "C") = cell.Offset(0, -1)    'get price p/d from column D
        End With
      End If
    Next cell
  Next i
  Application.ScreenUpdating = False
End Sub

Sub BuildInvoiceLIGHTS()
  Dim ws As Variant, arr As Variant
  Dim i As Long, j As Long, nr As Long
  Dim cell As Range, f As Range, MultiRange As Range
  Dim Descript As String
    
  Application.ScreenUpdating = False
  '   ' Set array of worksheet names to copy from
  ws = Array("LIGHTS")
  arr = Array("E13:E34", "J13:J59", "E36:E59", "E73:E89", "J73:J82", "J84:J91", "E91:E98", "J93:J101", "E100:E109", "J103:J113")
  '   Loop through all shees inthe array
  For i = LBound(ws) To UBound(ws)
    Set MultiRange = Sheets(ws(i)).Range("A" & Rows.Count).End(3)(2)
    For j = 0 To UBound(arr)
      Set MultiRange = Union(MultiRange, Sheets(ws(i)).Range(arr(j)))
    Next
    For Each cell In MultiRange         'Loop through all cells inthe multirange
      If cell > 0 Then                  'See if anything entered in pieces
        Descript = cell.Offset(0, -3)   'get description from column B
        With Sheets("PROFORMA DRYHIRE")
          Set f = .Range("A15:A70").Find(Descript, , xlValues, xlWhole)
          If Not f Is Nothing Then
            nr = f.Row
          Else
            nr = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            If nr > 70 Then
              MsgBox "Rows are full"
              Exit Sub
            End If
            If nr < 15 Then nr = 15
          End If
          '               Populate values on PROFORMA sheet
          .Cells(nr, "A") = Descript
          .Cells(nr, "B") = cell                  'get pieces from column E
          .Cells(nr, "C") = cell.Offset(0, -1)    'get price p/d from column D
        End With
      End If
    Next cell
  Next i
  Application.ScreenUpdating = False
End Sub

Sub BuildInvoiceHTD()
  Dim ws As Variant, arr As Variant
  Dim i As Long, j As Long, nr As Long
  Dim cell As Range, f As Range, MultiRange As Range
  Dim Descript As String
    
  Application.ScreenUpdating = False
  '   ' Set array of worksheet names to copy from
  ws = Array("HOISTS - TRUSS - DRAPES")
  arr = Array("E13:E28", "K13:K37", "E30:E40", "E42:E52", "E67:E91", "K67:K85", "E106:E123", "K106:K119", "K121:K129", "E127:E137")
  '   Loop through all shees inthe array
  For i = LBound(ws) To UBound(ws)
    Set MultiRange = Sheets(ws(i)).Range("A" & Rows.Count).End(3)(2)
    For j = 0 To UBound(arr)
      Set MultiRange = Union(MultiRange, Sheets(ws(i)).Range(arr(j)))
    Next
    For Each cell In MultiRange         'Loop through all cells inthe multirange
      If cell > 0 Then                  'See if anything entered in pieces
        Descript = cell.Offset(0, -3)   'get description from column B
        With Sheets("PROFORMA DRYHIRE")
          Set f = .Range("A15:A70").Find(Descript, , xlValues, xlWhole)
          If Not f Is Nothing Then
            nr = f.Row
          Else
            nr = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            If nr > 70 Then
              MsgBox "Rows are full"
              Exit Sub
            End If
            If nr < 15 Then nr = 15
          End If
          '               Populate values on PROFORMA sheet
          .Cells(nr, "A") = Descript
          .Cells(nr, "B") = cell                  'get pieces from column E
          .Cells(nr, "C") = cell.Offset(0, -1)    'get price p/d from column D
        End With
      End If
    Next cell
  Next i
  Application.ScreenUpdating = False
End Sub

Sub BuildInvoiceDCM()
  Dim ws As Variant, arr As Variant
  Dim i As Long, j As Long, nr As Long
  Dim cell As Range, f As Range, MultiRange As Range
  Dim Descript As String
    
  Application.ScreenUpdating = False
  '   ' Set array of worksheet names to copy from
  ws = Array("DISTRO - CABLES - MISC")
  arr = Array("E13:E35", "K13:K50", "E37:E50", "E64:E116", "K64:K88", "K92:K108", "K111:K120", "E131:E148", "K131:K148", "K150:K159", _
  "E152:E180", "K163:K188", "K190:K203", "E184:E216", "K207:K238", "K240:K249")
  '   Loop through all shees inthe array
  For i = LBound(ws) To UBound(ws)
    Set MultiRange = Sheets(ws(i)).Range("A" & Rows.Count).End(3)(2)
    For j = 0 To UBound(arr)
      Set MultiRange = Union(MultiRange, Sheets(ws(i)).Range(arr(j)))
    Next
    For Each cell In MultiRange         'Loop through all cells inthe multirange
      If cell > 0 Then                  'See if anything entered in pieces
        Descript = cell.Offset(0, -3)   'get description from column B
        With Sheets("PROFORMA DRYHIRE")
          Set f = .Range("A15:A70").Find(Descript, , xlValues, xlWhole)
          If Not f Is Nothing Then
            nr = f.Row
          Else
            nr = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            If nr > 70 Then
              MsgBox "Rows are full"
              Exit Sub
            End If
            If nr < 15 Then nr = 15
          End If
          '               Populate values on PROFORMA sheet
          .Cells(nr, "A") = Descript
          .Cells(nr, "B") = cell                  'get pieces from column E
          .Cells(nr, "C") = cell.Offset(0, -1)    'get price p/d from column D
        End With
      End If
    Next cell
  Next i
  Application.ScreenUpdating = False
End Sub
 

Sub ClearContents()
'   Clear All contents from Sheet - Proforma
    Worksheets("PROFORMA DRYHIRE").Range("A15:C70").ClearContents
    MsgBox "Ç öüñìá êáèÜñéóå!"
End Sub

Thank you !!!

 

[DanteAmor]

Check the data in each sheet, maybe there are hidden rows or hidden values that you are not seeing and it is being passed to the sheet "PROFORMA DRYHIRE"

Also check that in the "PROFORMA DRYHIRE" sheet there is no data after row 70 or any text that you have put after cell A70 or blank spaces after cell A70.

 

[pantakos]

Check the data in each sheet, maybe there are hidden rows or hidden values that you are not seeing and it is being passed to the sheet "PROFORMA DRYHIRE"

Also check that in the "PROFORMA DRYHIRE" sheet there is no data after row 70 or any text that you have put after cell A70 or blank spaces after cell A70.

There are data after row 70, some data and blank spaces etc that are needed to be there. Of cource if there is no other solution I can move them. My though was that if rows A15 to A70 gets full then there will be a message.

 

[DanteAmor]

Ok, there is an error in the logic of your original macro, I make the correction and I put the macro here.

 

[DanteAmor]

Try this.
One macro for all your sheets

Sub BuildInvoiceAll()
  Dim ws As Variant, arr1 As Variant, arr2 As Variant, arr3 As Variant, arr4 As Variant, arry As Variant
  Dim i As Long, j As Long, nr As Long
  Dim cell As Range, f As Range, MultiRange As Range
  Dim Descript As String
    
  Application.ScreenUpdating = False
  'Set array of worksheet names to copy from
  ws = Array("AUDIO", "LIGHTS", "HOISTS - TRUSS - DRAPES", "DISTRO - CABLES - MISC")
  
  'cells to AUDIO sheet
  arr1 = Array("E13:E43", "J13:J30", "J32:J43", "E57:E84", "J57:J84", "E100:E131", "J100:J107", _
        "J109:J118", "J120:J131", "E146:E176", "E178:E191", "J146:J176", "J178:J184", "J186:J197")
  'cells to LIGHTS sheet
  arr2 = Array("E13:E34", "J13:J59", "E36:E59", "E73:E89", "J73:J82", "J84:J91", "E91:E98", "J93:J101", "E100:E109", "J103:J113")
  'cells to HOISTS sheet
  arr3 = Array("E13:E28", "K13:K37", "E30:E40", "E42:E52", "E67:E91", "K67:K85", "E106:E123", "K106:K119", "K121:K129", "E127:E137")
  'cells to DISTRO sheet
  arr4 = Array("E13:E35", "K13:K50", "E37:E50", "E64:E116", "K64:K88", "K92:K108", "K111:K120", "E131:E148", "K131:K148", "K150:K159", _
         "E152:E180", "K163:K188", "K190:K203", "E184:E216", "K207:K238", "K240:K249")
  
  arry = Array(arr1, arr2, arr3, arr4)
  nr = 14
  'Loop through all shees inthe array
  For i = LBound(ws) To UBound(ws)
    Set MultiRange = Sheets(ws(i)).Range("A" & Rows.Count).End(3)(2)
    For j = 0 To UBound(arry(i))
      Set MultiRange = Union(MultiRange, Sheets(ws(i)).Range(arry(i)(j)))
    Next
    For Each cell In MultiRange         'Loop through all cells inthe multirange
      If cell > 0 Then                  'See if anything entered in pieces
        Descript = cell.Offset(0, -3)   'get description from column B
        With Sheets("PROFORMA DRYHIRE")
          Set f = .Range("A15:A70").Find(Descript, , xlValues, xlWhole)
          If Not f Is Nothing Then
            nr = f.Row
          Else
            nr = nr + 1
            If nr > 70 Then
              MsgBox "Rows are full"
              Exit Sub
            End If
          End If
          '               Populate values in PROFORMA sheet
          .Cells(nr, "A") = Descript
          .Cells(nr, "B") = cell                  'get pieces from column E
          .Cells(nr, "C") = cell.Offset(0, -1)    'get price p/d from column D
        End With
      End If
    Next cell
  Next i
  Application.ScreenUpdating = False
End Sub

 

[DanteAmor]

Here another enhancement. Multi range is not necessary.

Sub BuildInvoiceAll()
  Dim ws As Variant, arr1 As String, arr2 As String, arr3 As String, arr4 As String, arry As Variant
  Dim i As Long, j As Long, nr As Long
  Dim cell As Range, f As Range
  Dim Descript As String
    
  Application.ScreenUpdating = False
  'Set array of worksheet names to copy from
  ws = Array("AUDIO", "LIGHTS", "HOISTS - TRUSS - DRAPES", "DISTRO - CABLES - MISC")
  
  'cells to AUDIO sheet
  arr1 = "E13:E43, J13:J30, J32:J43, E57:E84, J57:J84, E100:E131, J100:J107," & _
        "J109:J118, J120:J131, E146:E176, E178:E191, J146:J176, J178:J184, J186:J197"
  'cells to LIGHTS sheet
  arr2 = "E13:E34, J13:J59, E36:E59, E73:E89, J73:J82, J84:J91, E91:E98, J93:J101, E100:E109, J103:J113"
  'cells to HOISTS sheet
  arr3 = "E13:E28, K13:K37, E30:E40, E42:E52, E67:E91, K67:K85, E106:E123, K106:K119, K121:K129, E127:E137"
  'cells to DISTRO sheet
  arr4 = "E13:E35, K13:K50, E37:E50, E64:E116, K64:K88, K92:K108, K111:K120, E131:E148, K131:K148, K150:K159," & _
         "E152:E180 , K163:K188 , K190:K203 , E184:E216 , K207:K238 , K240:K249 "
  arry = Array(arr1, arr2, arr3, arr4)
  nr = 14
  
  For i = LBound(ws) To UBound(ws)                  'Loop through all shees inthe array
    For Each cell In Sheets(ws(i)).Range(arry(i))   'Loop through all cells inthe multirange
      If cell > 0 Then                              'See if anything entered in pieces
        Descript = cell.Offset(0, -3)               'get description from column B
        With Sheets("PROFORMA DRYHIRE")
          Set f = .Range("A15:A70").Find(Descript, , xlValues, xlWhole)
          If Not f Is Nothing Then
            nr = f.Row
          Else
            nr = nr + 1
            If nr > 70 Then
              MsgBox "Rows are full"
              Exit Sub
            End If
          End If
          '               Populate values in PROFORMA sheet
          .Cells(nr, "A") = Descript
          .Cells(nr, "B") = cell                  'get pieces from column E
          .Cells(nr, "C") = cell.Offset(0, -1)    'get price p/d from column D
        End With
      End If
    Next cell
  Next i
  Application.ScreenUpdating = False
End Sub

 

[pantakos]

Here another enhancement. Multi range is not necessary.

Sub BuildInvoiceAll()
  Dim ws As Variant, arr1 As String, arr2 As String, arr3 As String, arr4 As String, arry As Variant
  Dim i As Long, j As Long, nr As Long
  Dim cell As Range, f As Range
  Dim Descript As String
   
  Application.ScreenUpdating = False
  'Set array of worksheet names to copy from
  ws = Array("AUDIO", "LIGHTS", "HOISTS - TRUSS - DRAPES", "DISTRO - CABLES - MISC")
 
  'cells to AUDIO sheet
  arr1 = "E13:E43, J13:J30, J32:J43, E57:E84, J57:J84, E100:E131, J100:J107," & _
        "J109:J118, J120:J131, E146:E176, E178:E191, J146:J176, J178:J184, J186:J197"
  'cells to LIGHTS sheet
  arr2 = "E13:E34, J13:J59, E36:E59, E73:E89, J73:J82, J84:J91, E91:E98, J93:J101, E100:E109, J103:J113"
  'cells to HOISTS sheet
  arr3 = "E13:E28, K13:K37, E30:E40, E42:E52, E67:E91, K67:K85, E106:E123, K106:K119, K121:K129, E127:E137"
  'cells to DISTRO sheet
  arr4 = "E13:E35, K13:K50, E37:E50, E64:E116, K64:K88, K92:K108, K111:K120, E131:E148, K131:K148, K150:K159," & _
         "E152:E180 , K163:K188 , K190:K203 , E184:E216 , K207:K238 , K240:K249 "
  arry = Array(arr1, arr2, arr3, arr4)
  nr = 14
 
  For i = LBound(ws) To UBound(ws)                  'Loop through all shees inthe array
    For Each cell In Sheets(ws(i)).Range(arry(i))   'Loop through all cells inthe multirange
      If cell > 0 Then                              'See if anything entered in pieces
        Descript = cell.Offset(0, -3)               'get description from column B
        With Sheets("PROFORMA DRYHIRE")
          Set f = .Range("A15:A70").Find(Descript, , xlValues, xlWhole)
          If Not f Is Nothing Then
            nr = f.Row
          Else
            nr = nr + 1
            If nr > 70 Then
              MsgBox "Rows are full"
              Exit Sub
            End If
          End If
          '               Populate values in PROFORMA sheet
          .Cells(nr, "A") = Descript
          .Cells(nr, "B") = cell                  'get pieces from column E
          .Cells(nr, "C") = cell.Offset(0, -1)    'get price p/d from column D
        End With
      End If
    Next cell
  Next i
  Application.ScreenUpdating = False
End Sub

Everything is ok! Thank you so much !

 

[DanteAmor]

Again with pleasure. Thanks for the feedback

 

[pantakos]

Again with pleasure. Thanks for the feedback

@DanteAmor something last ... is it possible if I erase a value in source cells (audio, lights etc) when I run the macro to check if there is a change to delete it from target (proforma) ? Just the one that gone from a value (lets say 5) to nothing , not 0 , delete the value from target sheet (proforma)

Is it?

Thank you !!!