Macro to find matching value and do automatic action

[kosherboy]

Hello.
Below is an attempted code that should run automatically when a value is entered in any 2nd cell in column L. I would like the code to do the following, after a value is entered in, let's say cell L5, the code should use the value of the cell to the left of L5, which is K5, and copy the value of cell L5 to every cell in column L that has it's neighboring cell under column K matching cell K5. Hope this makes sense

Here is what i have so far but i can't get it to work:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, FirstAddress As String
Dim PO As String

    If Target.Count > 1 Then Exit Sub
        If Target.Column = 12 And Target.Row Mod 2 = 1 Then
        PO = Target.Offset(0, -1).Value
        Set rng = .Find(PO, .Cells(.Cells.Count), xlFormulas, xlPart)
            If Not rng Is Nothing Then
                If rng.Row Mod 2 = 1 Then
                    FirstAddress = rng.Address
                    Do
                    rng.Offset(0, 1) = Target
                    Set rng = .FindNext(rng)
                    Loop While Not rng Is Nothing And rng.Address <> FirstAddress
                End If
            End If
        End If
    End If

End Sub

Thanks in advance.

[karedog]

Hi,

Use array, it is very very much faster than range.find()
Look here : link
Using find(), you will need 9747ms, while using matrix (array) you will only need 66ms (0.68% of find()).

Private Sub Worksheet_Change(ByVal Target As Range)
  'Exit if outside criteria range
  If Target.Count > 1 Then Exit Sub
  If Not ((Target.Column = 12) And (Target.Row Mod 2 = 1)) Then Exit Sub

  Application.EnableEvents = False
  Dim mtx(), CurrCell, LeftCell, i As Long
  'Matrix of columns K:L
  mtx = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("K:L")).Value
  'Value of current cell
  CurrCell = Target.Value
  'Value of the cell left of current cell
  LeftCell = Target.Offset(0, -1).Value
  'Comparing and set if matched
  For i = 1 To UBound(mtx, 1)
      If mtx(i, 1) = LeftCell Then mtx(i, 2) = CurrCell
  Next i
  'Write matrix back to range K:L
  Range("K1").Resize(UBound(mtx, 1), UBound(mtx, 2)).Value = mtx
  Application.EnableEvents = True
End Sub

Regards

[kosherboy]

Hats off to you!! Unbelievable code! Thanks!

[karedog]

You are welcome. Many thanks for the reputation point.

Regards

[kosherboy]

Hi karedog,
Code is great but it's not letting the other automatic codes i have work. any ideas?
Here is my entire code, you will see in the middle of the code the one you helped me out with:

Private Sub Worksheet_Change(ByVal Target As Range)

        Application.EnableEvents = False
On Error GoTo ErrHandler
    If Target.Row > 4 Then
        If Target.Column = 3 Then
            Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 4 Then
            Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 5 And Target.Row Mod 2 = 0 Then
           Target.Value = Application.WorksheetFunction.Proper(Target.Value)
        End If
        If Target.Column = 5 And Target.Row Mod 2 = 1 Then
           Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 8 Then
            Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 9 And Target.Row Mod 2 = 1 Then
           Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 9 And Target.Row Mod 2 = 0 Then
           Target.Value = Application.WorksheetFunction.Proper(Target.Value)
        End If
        If Target.Column = 11 Then
            Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 12 Then
            Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 15 Then
            Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 16 Then
            Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 17 Then
            Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 18 Then
            Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 19 Then
            Target.Formula = UCase(Target.Formula)
        End If
            If Target.Column = 21 Then
            Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 22 Then
            Target.Formula = UCase(Target.Formula)
        End If
        If Target.Column = 1 Then
            Target.Value = Application.WorksheetFunction.Proper(Target.Value)
        End If
    End If
    
ErrHandler:
        Application.EnableEvents = True

'MESSAGE BOX POPS UP WHEN CUSTOMER COST EXCEEDS OUR COST
If Target.Row > 4 Then
    If Target.Count > 1 Then Exit Sub
        If Target.Column = 5 And Target.Row Mod 2 = 1 Then
            If Target > Target.Offset(0, 4) Then
            If Target.Offset(0, 4) = "" Or Target.Offset(0, 4) = "N/A" Or Target.Offset(0, 4) = "LISTED" Then
            Exit Sub
            End If
            If Target = "" Or Target = "N/A" Or Target = "LISTED" Then
            Exit Sub
            End If
            MsgBox "WARNING!" & vbNewLine & vbNewLine & "Customer cost exceeds our cost"
        End If
    End If
End If
If Target.Row > 4 Then
    If Target.Count > 1 Then Exit Sub
        If Target.Column = 9 And Target.Row Mod 2 = 1 Then
            If Target < Target.Offset(0, -4) Then
            If Target.Offset(0, -4) = "" Or Target.Offset(0, -4) = "N/A" Or Target.Offset(0, -4) = "LISTED" Then
            Exit Sub
            End If
            If Target = "" Or Target = "N/A" Or Target = "LISTED" Then
            Exit Sub
            End If
            MsgBox "WARNING!" & vbNewLine & vbNewLine & "Customer cost exceeds our cost"
        End If
    End If
End If

'This code will copy the date PO placed into all orders with matching PO
  'Exit if outside criteria range
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Application.Calculation = xlManual
  If Target.Row > 4 Then
  If Target.Count > 1 Then Exit Sub
  If Not ((Target.Column = 12) And (Target.Row Mod 2 = 1)) Then Exit Sub


  Dim mtx(), CurrCell, LeftCell, i As Long
  'Matrix of columns K:L
  mtx = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("K:L")).Value
  'Value of current cell
  CurrCell = Target.Value
  'Value of the cell left of current cell
  LeftCell = Target.Offset(0, -1).Value
  'Comparing and set if matched
  For i = 1 To UBound(mtx, 1)
      If mtx(i, 1) = LeftCell Then mtx(i, 2) = CurrCell
  Next i
  'Write matrix back to range K:L
  Range("K1").Resize(UBound(mtx, 1), UBound(mtx, 2)).Value = mtx
  End If
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic

'Creates Pro-Forma invoice
    With ActiveCell
        If .Column = 14 Then
            If (.Row Mod 2 = 0) Then Exit Sub
                If ActiveCell.Value = "Create Pro-Forma Invoice" Then
                Call Proforma_Invoice
            End If
        End If
    End With
    
'Creates Sales Order
    With ActiveCell
        If .Column = 14 Then
            If (.Row Mod 2 = 0) Then Exit Sub
                If ActiveCell.Value = "Create Sales Order" Then
                Call Sales_Order
            End If
        End If
    End With
    
'Creates Invoice
With ActiveCell
    If .Column = 14 Then
        If (.Row Mod 2 = 0) Then Exit Sub
            If ActiveCell.Value = "Create invoice" Then
            Call Invoice
        End If
    End If
End With

'Creates PO
With ActiveCell
    If .Column = 14 Then
        If (.Row Mod 2 = 0) Then Exit Sub
            If ActiveCell.Value = "Create PO" Then
            Call Purchase_Order
        End If
    End If
End With

'Creates CM
With ActiveCell
    If .Column = 14 Then
        If (.Row Mod 2 = 0) Then Exit Sub
            If ActiveCell.Value = "Create Credit Memo" Then
            Call Purchase_Order
        End If
    End If
End With

End Sub

[karedog]

Hi,

Try to change the blue lines code to this :

'This code will copy the date PO placed into all orders with matching PO
  If (target.Row > 4) And (target.Count > 1) And (target.Column = 12) And (target.Row Mod 2 = 1) Then
     Application.EnableEvents = False
     Application.ScreenUpdating = False
     Application.Calculation = xlManual

     Dim mtx(), CurrCell, LeftCell, i As Long
     'Matrix of columns K:L
     mtx = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("K:L")).Value
     'Value of current cell
     CurrCell = target.Value
     'Value of the cell left of current cell
     LeftCell = target.Offset(0, -1).Value
     'Comparing and set if matched
     For i = 1 To UBound(mtx, 1)
         If mtx(i, 1) = LeftCell Then mtx(i, 2) = CurrCell
     Next i
     'Write matrix back to range K:L
     Range("K1").Resize(UBound(mtx, 1), UBound(mtx, 2)).Value = mtx

     Application.EnableEvents = True
     Application.ScreenUpdating = True
     Application.Calculation = xlCalculationAutomatic
  End If

Regards

[kosherboy]

Thanks.
I changed it but now all other codes work besides for this one

[karedog]

Oops, sorry :

If (target.Row > 4) And (target.Count = 1) And (target.Column = 12) And (target.Row Mod 2 = 1) Then

[kosherboy]

It worked! I really appreciate your knowledge, thank you.

[karedog]

You are welcome, thanks.

[kosherboy]

Hi again
I am trying to make your code work for the target now being column M instead of L but can't get it to work. I don't fully understand how your code works but every way i tried tweaking it i hit a dead end. Can you help me make the code work for column M?

here's what i have:

If (Target.Row > 4) And (Target.Count = 1) And (Target.Column = 13) And (Target.Row Mod 2 = 1) Then
     Application.EnableEvents = False
     Application.ScreenUpdating = False
     Application.Calculation = xlManual

     Dim mtx2(), CurrCell2, LeftCell2, i2 As Long
     'Matrix of columns K:M
     mtx2 = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("K:M")).Value
     'Value of current cell
     CurrCell2 = Target.Value
     'Value of the cell left of current cell
     LeftCell2 = Target.Offset(0, -2).Value
     'Comparing and set if matched
     For i2 = 1 To UBound(mtx2, 1)
         If mtx2(i2, 1) = LeftCell2 Then mtx2(i2, 3) = CurrCell2
     Next i2
     'Write matrix back to range K:M
     Range("K1").Resize(UBound(mtx2, 1), UBound(mtx2, 2)).Value = mtx2

     Application.EnableEvents = True
     Application.ScreenUpdating = True
     Application.Calculation = xlCalculationAutomatic
  End If

[karedog]

Hi,

Since you shift one column to right, so should the code

If (Target.Row > 4) And (Target.Count = 1) And (Target.Column = 13) And (Target.Row Mod 2 = 1) Then
     Application.EnableEvents = False
     Application.ScreenUpdating = False
     Application.Calculation = xlManual

     Dim mtx2(), CurrCell2, LeftCell2, i2 As Long
     'Matrix of columns L:M
     mtx2 = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("L:M")).Value
     'Value of current cell
     CurrCell2 = Target.Value
     'Value of the cell left of current cell
     LeftCell2 = Target.Offset(0, -2).Value
     'Comparing and set if matched
     For i2 = 1 To UBound(mtx2, 1)
         If mtx2(i2, 1) = LeftCell2 Then mtx2(i2, 3) = CurrCell2
     Next i2
     'Write matrix back to range L:M
     Range("L1").Resize(UBound(mtx2, 1), UBound(mtx2, 2)).Value = mtx2

     Application.EnableEvents = True
     Application.ScreenUpdating = True
     Application.Calculation = xlCalculationAutomatic
  End If

Regards

[kosherboy]

Thanks but i meant only the target cell gets shifted one to the right. Meaning column K should remain the same, and instead of using column L as the active cell this time i would like column M to be the active cell.

[karedog]

I see.

This is because two cells left of triggered cell is changed to uppercase by these :

        If Target.Column = 11 Then
            Target.Formula = UCase(Target.Formula)
        End If

while remaining of the column K has not been changed to uppercase yet.

So the code should be changed to :

     'Comparing and set if matched
     For i2 = 1 To UBound(mtx2, 1)
         If UCase(mtx2(i2, 1)) = LeftCell2 Then
            mtx2(i2, 3) = CurrCell2
            mtx2(i2, 1) = UCase(mtx2(i2, 1))
         End If
     Next i2
     'Write matrix back to range K:M

Regards

[kosherboy]

Once again, i am dumbfounded as to how you figured all that out!
Thank you, most appreciated

[kosherboy]

Hi karedog, i hope i'm not being to pushy but i have another request. I tried to tweak the code as much as i could to get the answer but am not being successful.
My question is what if i enter into the target cell a hyperlink, how can i get the other cells to copy that hyperlink and not just the value?
This is what i tried so far, see my tweak in blue:

If (Target.Row > 4) And (Target.Count = 1) And (Target.Column = 13) And (Target.Row Mod 2 = 1) Then
If Not Target.Offset(0, -2) = "N/A" Then
     Application.EnableEvents = False
     Application.ScreenUpdating = False
     Application.Calculation = xlManual

     Dim mtx2(), CurrCell2, LeftCell2, i2 As Long
     'Matrix of columns K:M
     mtx2 = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("K:M")).Value
     'Value of current cell
     CurrCell2 = Target.Value
     'Value of the cell left of current cell
     LeftCell2 = Target.Offset(0, -2).Value
     'Comparing and set if matched
     For i2 = 1 To UBound(mtx2, 1)
         If UCase(mtx2(i2, 1)) = LeftCell2 Then
            
            With mtx2(i2, 3)
            .Copy CurrCell2
            End With
            
            'mtx2(i2, 3) = CurrCell2
            mtx2(i2, 1) = UCase(mtx2(i2, 1))
         End If
     Next i2
     'Write matrix back to range K:M
     Range("K1").Resize(UBound(mtx2, 1), UBound(mtx2, 2)).Value = mtx2

     Application.EnableEvents = True
     Application.ScreenUpdating = True
     Application.Calculation = xlCalculationAutomatic
End If
End If

[karedog]

Hi,

In that case, we cannot use array operation anymore, use AutoFilter method instead.

  If (target.Row > 4) And (target.Count = 1) And (target.Column = 13) And (target.Row Mod 2 = 1) Then
     Application.EnableEvents = False
     Application.ScreenUpdating = False
     Application.Calculation = xlManual

     Dim cell As Range, strRange As String

     'Filter column K to match the value of 2 cells left of current cell
     Range("K:K").AutoFilter field:=1, Criteria1:=target.Offset(0, -2).Value
     'Copy current cell to every cells in matched Autofilter range
     strRange = ""
     For Each cell In Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("M:M")).SpecialCells(xlCellTypeVisible)
         If cell.Row > 4 Then
            'Instead change matched cells one by one which is much slower, change in cells group instead
            strRange = strRange & "," & cell.Address(False, False)
            If Len(strRange) > 250 Then
               target.Copy Range(Mid(strRange, 2))
               strRange = ""
            End If
         End If
     Next cell
     If Len(strRange) > 0 Then target.Copy Range(Mid(strRange, 2))
     'Autofilter off
     Range("K:K").AutoFilter

     Application.EnableEvents = True
     Application.ScreenUpdating = True
     Application.Calculation = xlCalculationAutomatic
  End If

Regards

[kosherboy]

It worked like a charm! I can't thank you enough!
All the best to you

[kosherboy]

Hi karedog,
I feel bad i keep bugging you but this is seriously the last time...i hope
I was googling the upper bound function and matrix but i'm still not getting it 100 percent. It would be most appreciated if you can guide me to the right site where i can learn this new concept in vba.
Also, i am trying to incorporate into the code a target cell of column R instead of L and M. So i still want the "leftcell" to remain as column K but i want the target cell to be R. I thought i was understanding your code and that it would be easy for me to incorporate column R as the target cell but after the code executes it write the value in column Q??
Here is what i have so far:

If (Target.Row > 4) And (Target.Count = 1) And (Target.Column = 18) And (Target.Row Mod 2 = 1) Then
If Not Target.Offset(0, -7) = "N/A" Then
     Application.EnableEvents = False
     Application.ScreenUpdating = False
     Application.Calculation = xlManual

     Dim mtx3(), CurrCell3, LeftCell3, i3 As Long
     'Matrix of columns K:R
     mtx3 = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("K:R")).Value
     'Value of current cell
     CurrCell3 = Target.Value
     'Value of the cell left of current cell
     LeftCell3 = Target.Offset(0, -7).Value
     'Comparing and set if matched
     For i3 = 1 To UBound(mtx3, 1)
         If UCase(mtx3(i3, 1)) = LeftCell3 Then
            mtx3(i3, 7) = CurrCell3
            mtx3(i3, 1) = UCase(mtx3(i3, 1))
         End If
     Next i3
     'Write matrix back to range K:R
     Range("K1").Resize(UBound(mtx3, 1), UBound(mtx3, 2)).Value = mtx3

     Application.EnableEvents = True
     Application.ScreenUpdating = True
     Application.Calculation = xlCalculationAutomatic
End If
End If

Once again i apologize for returning to this post but i am really stuck!
Thank you in advance.

[kosherboy]

Hi karedog,
I got the code to work by playing around with it! But i would really like to know how it works. Here is the code, i highlighted in blue the part i tweaked.

If (Target.Row > 4) And (Target.Count = 1) And (Target.Column = 18) And (Target.Row Mod 2 = 1) Then
If Not Target.Offset(0, -7) = "N/A" Then
     Application.EnableEvents = False
     Application.ScreenUpdating = False
     Application.Calculation = xlManual

     Dim mtx3(), CurrCell3, LeftCell3, i3 As Long
     'Matrix of columns K:R
     mtx3 = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("K:R")).Value
     'Value of current cell
     CurrCell3 = Target.Value
     'Value of the cell left of current cell
     LeftCell3 = Target.Offset(0, -7).Value
     'Comparing and set if matched
     For i3 = 1 To UBound(mtx3, 1)
         If mtx3(i3, 1) = LeftCell3 Then mtx3(i3, 8) = CurrCell3
     Next i3
     
     'Write matrix back to range K:R
     Range("K1").Resize(UBound(mtx3, 1), UBound(mtx3, 2)).Value = mtx3

     Application.EnableEvents = True
     Application.ScreenUpdating = True
     Application.Calculation = xlCalculationAutomatic
End If
End If

[karedog]

Hi kosherboy,

No problem. Unfortunately I don't remember the website(s) that teach about this. I learned and collected this info from so many places, so I don't remember all of
them, sorry. But I am sure that if you googling using keywords like "Excel VBA array operations" you will get many of them.

One thing that could lead into confusion is maybe lbound() and ubound() function.

lbound() <lower bound> is to get index of the lowest member of the matrix while
ubound() <upper bound> is to get index of the higher member of the matrix

For example, a code like this :

Sub Test1()
  Dim mtx(3 To 7)
  MsgBox LBound(mtx)
  MsgBox UBound(mtx)
End Sub

You will get the lbound of the matrix is 3 and ubound of the matrix is 7.
This is an example for one dimension matrix.


Now the example for 2 dimensions matrix :

Sub Tes2()
  Dim mtx(2 To 4, 6 To 8)
  MsgBox LBound(mtx, 1)  'is 2
  MsgBox LBound(mtx, 2)  'is 6
  MsgBox UBound(mtx, 1)  'is 4
  MsgBox UBound(mtx, 2)  'is 8
End Sub

Since this is a multidimensional matrix, we must tell Excel which dimension we want to examine, by passing the dimension number to second argument of the function.

So for the first the example, it can actually be written as :

Sub Test1()
  Dim mtx(3 To 7)
  MsgBox LBound(mtx, 1)
  MsgBox UBound(mtx, 1)
End Sub

but since this is a one dimensional matrix, we can neglect the second argument completely.


Now about the lower bound values, if we don't specifically defined the lower bound value, Excel will start this from 0 or 1. By default it is start with 0 except you
use statement Option Base 1, this will start the lower bound value from 1.


And now about index in Excel range. Please fill some values in range A1:B2

Sub Test3()
  MsgBox Range("A1").Cells(1, 1)
  MsgBox Range("A1").Offset(1, 1)
End Sub

The first line will produce the value of cell A1 while the second line will produce value of cell B2. So the index rule is different for cells property with offset
property (although both is filled with the same values that is (1,1) ).

When we assign a range to a matrix, the rule that used is cell's rule, so the first member of matrix will get index (1,1) <not offset's rule which is (0,0)>.

So now you have already know, that there is different value (it is exactly 1) when working with cells and working with offset.


Now we apply this to your problem :

'Value of the cell left of current cell
LeftCell3 = Target.Offset(0, -7).Value

You assign the LeftCell3 variable, seven cells to left from currenct cell, USING OFFSET METHOD.

Now this one,

If UCase(mtx3(i3, 1)) = LeftCell3 Then
   mtx3(i3, 7) = CurrCell3

You try to assign a value to matrix (which is USE CELL's RULE instead of offset's rule), but you pass the "7" value, while actually it must be "8".
Because you have already know the differences between offset's rule and cell's rule, so it must be clear enough for you now.

Sorry for the long post.

Regards

[kosherboy]

Please don't be sorry, you've gone out of your way in explaining Upper bound lower bound concept. I really appreciate it. Thank you so much

[kosherboy]

Hi karedog,
I ran into a little issue while trying to recreate your code into a different scenario. Your code has the target cell, matching cell and out-put range all on the ODD row, what if my target cell is on an even row and the matching cells are on the odd row and the output cells on an even row?

So below is the recreated code that uses the target cell that's in the even row and uses the matching cell which is in an ODD row, however, i am unable to get the output range to be in the EVEN row. Instead, the value gets copied into the ODD row. It would be really great and appreciated if you can help me figure out how to to get the output range to be in the EVEN rows as opposed to the ODD rows.
here is what i have so far:

If (Target.Row > 4) And (Target.Count = 1) And (Target.Column = 23) And (Target.Row Mod 2 = 0) Then
If Not Target.Offset(-1, -11) = "N/A" Then
     Application.EnableEvents = False
     Application.ScreenUpdating = False
     Application.Calculation = xlManual

     Dim mtx4(), CurrCell4, LeftCell4, i4 As Long
     'Matrix of columns L:W
     mtx4 = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("L:W")).Value
     'Value of current cell
     CurrCell4 = Target.Value
     'Value of the cell left of current cell
     LeftCell4 = Target.Offset(-1, -11).Value
     'Comparing and set if matched
     For i4 = 1 To UBound(mtx4, 1)
         If mtx4(i4, 1) = LeftCell4 Then mtx4(i4, 12) = CurrCell4
     Next i4
     
     'Write matrix back to range L:W
     Range("L1").Resize(UBound(mtx4, 1), UBound(mtx4, 2)).Value = mtx4

     Application.EnableEvents = True
     Application.ScreenUpdating = True
     Application.Calculation = xlCalculationAutomatic
End If
End If

[kosherboy]

Hi karedog, i solved it! See blue font below

Private Sub Worksheet_Change(ByVal Target As Range)

    If (Target.Row > 4) And (Target.Count = 1) And (Target.Column = 23) And (Target.Row Mod 2 = 0) Then
        If Not Target.Offset(-1, -11) = "N/A" Then
        
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            Application.Calculation = xlManual
        
                Dim mtx4(), CurrCell4, LeftCell4, i4 As Long
                'Matrix of columns L:W
                mtx4 = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("L:W")).Value
                'Value of current cell
                CurrCell4 = Target.Value
                'Value of the cell left of current cell
                LeftCell4 = Target.Offset(-1, -11).Value
                'Comparing and set if matched
                For i4 = 1 To UBound(mtx4, 1)
                    If mtx4(i4, 1) = LeftCell4 Then mtx4(i4 + 1, 12) = CurrCell4
                Next i4
                
                'Write matrix back to range L:W
                Range("L1").Resize(UBound(mtx4, 1), UBound(mtx4, 2)).Value = mtx4
        
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
            
        End If
    End If

End Sub

[karedog]

Hi kosherboy,

Glad you can solve it by yourself, sorry I am late to respond, it has been (and still) busy for the last few days for me.

Regards