Change values of a sheet based on negative positive values of different sheet

[Jyotirmaya]

I have 2 sheets, in sheet1 I have 2 columns Product code and Values, In sheet2 also I have 2 columns Product code and Values, In sheet1 A column a same product may be there for more than one time with different values but in sheet2 the product code is there only for once without having any repetitions.

I want the Sheet1 values should change based on the values of Sheet2

Sheet 1 & Sheet 2



Case 1


I want that in sheet2 when the sum of positive is more than the sum of negative then the negative values total should deduct from Sheet 1 Values, in this case -5 should deduct from Sheet 1 of Product code 2, then it will check the sum of product code 2 from sheet1 in this case its 7(B3)+7(B4)= 14 hence it should deduct 5 hence it can deduct the 5 towards downwards on the column so after deduction of 5 in B3 of sheet1 will be 2 and B4 should be as usual 7.

Similarly in case of product code 4 it should deduct 20 from B6 of sheet1 and the result should be 11 in B6 in Sheet1 after deduction




Case 2

Sheet 2

In the 2nd case if the sum of positive is less than the sum of negative then only I need to deduct that much from product code from Sheet 1. In this case I have sum of positive values is 15 and sum of negative values is 25 then I need to deduct 15 from any product code which has negative values in sheet2, but it should select higher values from the column, so in this case it will select B6 31 value and it should deduct 15 from B6 and the result should be 16 in B6 in sheet1 after deduction

What should be the macro code?

 

[DanteAmor]

Try this

Sub DAM_Change_Values()
  Dim sh1 As Worksheet, sh2 As Worksheet, s1 As Double, s2 As Double
  Dim v As Range, c As Range, r As Range, f As Range, cell As String
  Dim wSum As Double, s3 As Double, ded As Double, wmax As Double
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set v = sh2.Range("B2", sh2.Range("B" & Rows.Count).End(xlUp))
  Set r = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
  
  s1 = WorksheetFunction.SumIf(v, ">0")
  s2 = Abs(WorksheetFunction.SumIf(v, "<0"))
  If s1 > s2 Then
      For Each c In v
        If c < 0 Then
          ded = Abs(c)
          s3 = WorksheetFunction.SumIf(r, c.Offset(, -1), r.Offset(, 1))
          If s3 >= ded Then
            Set f = r.Find(c.Offset(, -1), , xlValues, xlWhole)
            If Not f Is Nothing Then
              cell = f.Address
              Do
                If f.Offset(, 1) >= ded Then
                  f.Offset(, 1) = f.Offset(, 1) - ded
                  Exit Do
                Else
                  f.Offset(, 1) = 0
                  ded = ded - f.Offset(, 1)
                End If
                Set f = r.FindNext(f)
              Loop While Not f Is Nothing And f.Address <> cell
            End If
          End If
        End If
      Next
  ElseIf s1 < s2 Then
    wmax = WorksheetFunction.Max(r.Offset(, 1))
    If wmax > s1 Then
      Set f = r.Offset(, 1).Find(wmax, , xlValues, xlWhole)
      f.Value = f.Value - s1
    End If
  End If
  MsgBox "End"
End Sub

Some issues to improve the code:
- What happens if the positives and negatives are equal, then do not deduct?
- In case 2, if the maximum of the values ​​in sheet1 is not greater than the value to be deducted, what is done?

 

[Jyotirmaya]

Some issues to improve the code:
- What happens if the positives and negatives are equal, then do not deduct?
- In case 2, if the maximum of the values ​​in sheet1 is not greater than the value to be deducted, what is done?

THANK YOU SO MUCH for helping, your code works good in Case 1

- What happens if the positives and negatives are equal, then do not deduct?

if the sum of positives and negatives are equal then case 1 formula will applicable it will deduct the sum of negative from the values in sheet 1

- In case 2, if the maximum of the values ​​in sheet1 is not greater than the value to be deducted, what is done?

Sheet1 and Sheet2

I have created two different sheet for this case to make you understand better for helping me

If the maximum value in sheet1 is not greater than the value to be deducted then in the above case I have to deduct 25 from higher values to lowers, hence in the above case, I have to deduct 25 but maximum value is 12 of the negative product code in sheet1 hence it will first make 12(B6) to zero, then in column it will check the next maximum value from upper to downwards hence it will select 8 (B7) then it will select (B3) 7, I want to deduct 25, hence 12+8+5 hence it will deduct 5 from B3 and the result in B3 should 2 after deduction.

And One more thing I want the code to perform the code from column B to P, I have data in sheet2 from column B to P and also I have data in Sheet1 from column B to P, and the same these two type cases are applicable for each column.

 

[DanteAmor]

And One more thing I want the code to perform the code from column B to P

Try this

Sub DAM_Change_Values()
  Dim sh1 As Worksheet, sh2 As Worksheet, s1 As Double, s2 As Double
  Dim v As Range, c As Range, r As Range, f As Range, cell As String
  Dim ded As Double, wmax As Double, col As Long
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set r = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
  
  For col =[COLOR=#0000ff] Columns("B").Column To Columns("P").Column[/COLOR]
    Set v = sh2.Range(sh2.Cells(2, col), sh2.Cells(Rows.Count, col).End(xlUp))
    
    s1 = WorksheetFunction.SumIf(v, ">0")
    s2 = Abs(WorksheetFunction.SumIf(v, "<0"))
    If s1 >= s2 Then
        For Each c In v
          If c < 0 Then
            ded = Abs(c)
            Set f = r.Find(sh2.Cells(c.Row, "A"), , xlValues, xlWhole)
            If Not f Is Nothing Then
              cell = f.Address
              Do
                If f.Offset(, col - 1) >= ded Then
                  f.Offset(, col - 1) = f.Offset(, col - 1) - ded
                  Exit Do
                Else
                  ded = ded - f.Offset(, col - 1)
                  f.Offset(, col - 1) = 0
                End If
                Set f = r.FindNext(f)
              Loop While Not f Is Nothing And f.Address <> cell
            End If
          End If
        Next
    Else
      ded = s1
      Do
        wmax = WorksheetFunction.Large(r.Offset(, col - 1), 1)
        Set f = r.Offset(, col - 1).Find(wmax, , xlValues, xlWhole)
        If wmax >= ded Then
          f.Value = f.Value - ded
          Exit Do
        Else
          ded = ded - f.Value
          f.Value = 0
        End If
      Loop While wmax > 0
    End If
  Next
  MsgBox "End"
End Sub

 

[Jyotirmaya]

Try this

Sub DAM_Change_Values()
  Dim sh1 As Worksheet, sh2 As Worksheet, s1 As Double, s2 As Double
  Dim v As Range, c As Range, r As Range, f As Range, cell As String
  Dim ded As Double, wmax As Double, col As Long
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set r = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
  
  For col =[COLOR=#0000ff] Columns("B").Column To Columns("P").Column[/COLOR]
    Set v = sh2.Range(sh2.Cells(2, col), sh2.Cells(Rows.Count, col).End(xlUp))
    
    s1 = WorksheetFunction.SumIf(v, ">0")
    s2 = Abs(WorksheetFunction.SumIf(v, "<0"))
    If s1 >= s2 Then
        For Each c In v
          If c < 0 Then
            ded = Abs(c)
            Set f = r.Find(sh2.Cells(c.Row, "A"), , xlValues, xlWhole)
            If Not f Is Nothing Then
              cell = f.Address
              Do
                If f.Offset(, col - 1) >= ded Then
                  f.Offset(, col - 1) = f.Offset(, col - 1) - ded
                  Exit Do
                Else
                  ded = ded - f.Offset(, col - 1)
                  f.Offset(, col - 1) = 0
                End If
                Set f = r.FindNext(f)
              Loop While Not f Is Nothing And f.Address <> cell
            End If
          End If
        Next
    Else
      ded = s1
      Do
        wmax = WorksheetFunction.Large(r.Offset(, col - 1), 1)
        Set f = r.Offset(, col - 1).Find(wmax, , xlValues, xlWhole)
        If wmax >= ded Then
          f.Value = f.Value - ded
          Exit Do
        Else
          ded = ded - f.Value
          f.Value = 0
        End If
      Loop While wmax > 0
    End If
  Next
  MsgBox "End"
End Sub

Sorry for the late response I was trying to find out the error and was testing the code, I am getting an error with the code. In the above example I wanted to deduct 25 in sheet1 from product code 2 and 4 only because they have the negative values in sheet2 but with the above code it deducted 20 from sheet1 product code 1 and only 5 from product code 4, instead of 20 from product code 4 and 5 from product code2

Please kindly make the changes in the code.

 

[DanteAmor]

How are the data in sheet1 and sheet2 before execution?

 

[Jyotirmaya]

How are the data in sheet1 and sheet2 before execution?

Sheet1 & Sheet2

If the maximum value in sheet1 is not greater than the value to be deducted then in the above case I have to deduct 25 from higher values to lowers, hence in the above case, I have to deduct 25 but maximum value is 12 of the negative product code in sheet1 hence it will first make 12(B6) to zero, then in column it will check the next maximum value from upper to downwards hence it will select 8 (B7) then it will select (B3) 7, I want to deduct 25, hence 12+8+5 hence it will deduct 5 from B3 and the result in B3 should 2 after deduction.

I am using code

Sub DAM_Change_Values()  Dim sh1 As Worksheet, sh2 As Worksheet, s1 As Double, s2 As Double
  Dim v As Range, c As Range, r As Range, f As Range, cell As String
  Dim ded As Double, wmax As Double, col As Long
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set r = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
  
  For col = Columns("B").Column To Columns("P").Column
    Set v = sh2.Range(sh2.Cells(2, col), sh2.Cells(Rows.Count, col).End(xlUp))
    
    s1 = WorksheetFunction.SumIf(v, ">0")
    s2 = Abs(WorksheetFunction.SumIf(v, "<0"))
    If s1 >= s2 Then
        For Each c In v
          If c < 0 Then
            ded = Abs(c)
            Set f = r.Find(sh2.Cells(c.Row, "A"), , xlValues, xlWhole)
            If Not f Is Nothing Then
              cell = f.Address
              Do
                If f.Offset(, col - 1) >= ded Then
                  f.Offset(, col - 1) = f.Offset(, col - 1) - ded
                  Exit Do
                Else
                  ded = ded - f.Offset(, col - 1)
                  f.Offset(, col - 1) = 0
                End If
                Set f = r.FindNext(f)
              Loop While Not f Is Nothing And f.Address <> cell
            End If
          End If
        Next
    Else
      ded = s1
      Do
        wmax = WorksheetFunction.Large(r.Offset(, col - 1), 1)
        Set f = r.Offset(, col - 1).Find(wmax, , xlValues, xlWhole)
        If wmax >= ded Then
          f.Value = f.Value - ded
          Exit Do
        Else
          ded = ded - f.Value
          f.Value = 0
        End If
      Loop While wmax > 0
    End If
  Next
  MsgBox "End"
End Sub

I am getting an error with the code. In the above example I wanted to deduct 25 in sheet1 from product code 2 and 4 only because they have the negative values in sheet2 but with the above code it deducted 20 from sheet1 product code 1 and only 5 from product code 4, instead of 20 from product code 4 and 5 from product code2

 

[DanteAmor]

Try this

Sub DAM_Change_Values()
  Dim sh1 As Worksheet, sh2 As Worksheet, s1 As Double, s2 As Double
  Dim v As Range, c As Range, r As Range, f As Range, cell As String
  Dim ded As Double, wmax As Double, col As Long, fila As Long
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set r = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
  
  For col = Columns("B").Column To Columns("B").Column
    Set v = sh2.Range(sh2.Cells(2, col), sh2.Cells(Rows.Count, col).End(xlUp))
    
    s1 = WorksheetFunction.SumIf(v, ">0")
    s2 = Abs(WorksheetFunction.SumIf(v, "<0"))
    If s1 >= s2 Then
        For Each c In v
          If c < 0 Then
            ded = Abs(c)
            Set f = r.Find(sh2.Cells(c.Row, "A"), , xlValues, xlWhole)
            If Not f Is Nothing Then
              cell = f.Address
              Do
                If f.Offset(, col - 1) >= ded Then
                  f.Offset(, col - 1) = f.Offset(, col - 1) - ded
                  Exit Do
                Else
                  ded = ded - f.Offset(, col - 1)
                  f.Offset(, col - 1) = 0
                End If
                Set f = r.FindNext(f)
              Loop While Not f Is Nothing And f.Address <> cell
            End If
          End If
        Next
    Else
      ded = s1
      Do
        fila = 0
        wmax = 0
        For Each c In v
          If c < 0 Then
            wmax = 0
            Set f = r.Find(sh2.Cells(c.Row, "A"), , xlValues, xlWhole)
            If Not f Is Nothing Then
              cell = f.Address
              Do
                If f.Offset(, col - 1) > wmax Then
                  wmax = f.Offset(, col - 1)
                  fila = f.Row
                End If
                Set f = r.FindNext(f)
              Loop While Not f Is Nothing And f.Address <> cell
            End If
          End If
        Next
        If fila = 0 Then
          Exit Do
        Else
          If sh1.Cells(fila, col).Value > ded Then
            sh1.Cells(fila, col).Value = sh1.Cells(fila, col).Value - ded
            Exit Do
          Else
            ded = ded - sh1.Cells(fila, col).Value
            sh1.Cells(fila, col).Value = 0
          End If
        End If
      Loop While ded > 0
    End If
  Next
  MsgBox "End"
End Sub

 

[Jyotirmaya]

Thank you so much for helping me til now, I am sorry I have made a mistake. I have mentioned that in the example I need to deduct 25 but mentioned that it will select values in the column from maximum values to minimum but I was wrong, I need to deduct 15 from product 4 then in sheet1 it can deduct maximum 15 from sheet1 from product 4 then 10 from product 2 as it can deduct maximum 13 from product code 2 of sheet1, But earlier we were used to deduct 25 from maximum values of negative product codes.

Sheet1 & Sheet2


hence the result will be like this

Sorry and please help

 

[DanteAmor]

I annex my best effort.

You must create a sheet called "Temp" the macro needs to do some calculations.


Then, try the following:

Sub DAM_Change_Values()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, s1 As Double, s2 As Double
  Dim v As Range, c As Range, r As Range, f As Range, cell As String
  Dim ded As Double, wmax As Double, col As Long, fila As Long, n As Long
  Dim lr As Long, newv As Range, newded As Variant
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set r = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
  
  For col = Columns("B").Column To Columns("B").Column
    Set v = sh2.Range(sh2.Cells(2, col), sh2.Cells(Rows.Count, col).End(xlUp))
    
    s1 = WorksheetFunction.SumIf(v, ">0")
    s2 = Abs(WorksheetFunction.SumIf(v, "<0"))
    If s1 >= s2 Then
      'POSITIVE
      For Each c In v
        If c < 0 Then
          ded = Abs(c)
          Set f = r.Find(sh2.Cells(c.Row, "A"), , xlValues, xlWhole)
          If Not f Is Nothing Then
            cell = f.Address
            Do
              If f.Offset(, col - 1) >= ded Then
                f.Offset(, col - 1) = f.Offset(, col - 1) - ded
                Exit Do
              Else
                ded = ded - f.Offset(, col - 1)
                f.Offset(, col - 1) = 0
              End If
              Set f = r.FindNext(f)
            Loop While Not f Is Nothing And f.Address <> cell
          End If
        End If
      Next
    Else
      'NEGATIVE
      n = 1
      Set sh3 = Sheets("Temp")
      sh3.Cells.Clear
      newded = s1
      lr = 1
      For Each c In v
        If c < 0 Then
          sh3.Cells(lr, "A") = c
          sh3.Cells(lr, "B") = sh2.Cells(c.Row, "A")
          lr = lr + 1
        End If
      Next
      
      sh3.Range("A1:B" & lr).Sort key1:=sh3.Range("A1"), order1:=xlAscending, Header:=xlNo
      Set newv = sh3.Range("A1:A" & lr - 1)
      
      For Each c In newv
        If Abs(c) >= newded Then
          c = newded * -1
        Else
          newded = newded - Abs(c)
        End If
      Next
      
      For Each c In newv
       ded = Abs(c)
       Set f = r.Find(c.Offset(, 1), , xlValues, xlWhole)
       If Not f Is Nothing Then
         cell = f.Address
         Do
            If f.Offset(, col - 1) >= ded Then
              f.Offset(, col - 1) = f.Offset(, col - 1) - ded
              Exit Do
            Else
              ded = ded - f.Offset(, col - 1)
              f.Offset(, col - 1) = 0
            End If
           Set f = r.FindNext(f)
         Loop While Not f Is Nothing And f.Address <> cell
       End If
      Next
    End If
  Next
  MsgBox "End"
End Sub