Distribute Cell values as compared to Negative excel values

[Jyotirmaya]

Distribute Black text values of excel as compared to Red Text values, In the below example I want to distribute 45+15 = 60 among 1,3,4,5 but the sum of 1,3,4,5 is 66 so it can distribute the values up to 60 It will choose to distribute the values from Max values to Min values, so I want the C column like as shown in my example.

The red value is the negative value but that is converted into positive and having color red.

what should be the macro code ?

 

[Peter_SSs]

For the future, please try to provide your sample data in a form we can copy/paste as many helpers will just bypass your question if they have to manually type it out.
My signature block below has more help on that.

For the layout you provided in your sample, try this code in a copy of your workbook.

Sub DistributeNegativeValues()
  Dim AL As Object
  Dim a As Variant, itm As Variant
  Dim Dist As Long, i As Long, uba As Long
  
  Set AL = CreateObject("System.Collections.ArrayList")
  a = Range("B1", Range("B" & Rows.Count).End(xlUp)).Value
  uba = UBound(a)
  For Each itm In a
    If itm < 0 Then
      Dist = Dist - itm
    Else
      AL.Add itm
    End If
  Next itm
  AL.Sort
  AL.Reverse
  ReDim Preserve a(1 To uba, 1 To 2)
  For Each itm In AL
    For i = 1 To uba
      If a(i, 1) = itm Then
        a(i, 2) = a(i, 1)
        If a(i, 2) > Dist Then a(i, 2) = Dist
        Dist = Dist - a(i, 2)
      End If
    Next i
  Next itm
  With Range("C1").Resize(uba)
    .Value = Application.Index(a, 0, 2)
    On Error Resume Next
    .SpecialCells(xlBlanks).Value = 0
    On Error GoTo 0
  End With
End Sub

Here is my worksheet. Original data in A:B, result of code in column C

Excel 2016
	A	B	C
1	1	10	10
2	2	-15	0
3	3	45	45
4	4	5	0
5	5	6	5
6	6	-45	0
Distribute

 

[Jyotirmaya]

For the future, please try to provide your sample data in a form we can copy/paste as many helpers will just bypass your question if they have to manually type it out.
My signature block below has more help on that.

For the layout you provided in your sample, try this code in a copy of your workbook.

Sub DistributeNegativeValues()
  Dim AL As Object
  Dim a As Variant, itm As Variant
  Dim Dist As Long, i As Long, uba As Long
  
  Set AL = CreateObject("System.Collections.ArrayList")
  a = Range("B1", Range("B" & Rows.Count).End(xlUp)).Value
  uba = UBound(a)
  For Each itm In a
    If itm < 0 Then
      Dist = Dist - itm
    Else
      AL.Add itm
    End If
  Next itm
  AL.Sort
  AL.Reverse
  ReDim Preserve a(1 To uba, 1 To 2)
  For Each itm In AL
    For i = 1 To uba
      If a(i, 1) = itm Then
        a(i, 2) = a(i, 1)
        If a(i, 2) > Dist Then a(i, 2) = Dist
        Dist = Dist - a(i, 2)
      End If
    Next i
  Next itm
  With Range("C1").Resize(uba)
    .Value = Application.Index(a, 0, 2)
    On Error Resume Next
    .SpecialCells(xlBlanks).Value = 0
    On Error GoTo 0
  End With
End Sub

Here is my worksheet. Original data in A:B, result of code in column C

Excel 2016

	A	B	C
1	1	10	10
2	2	-15	0
3	3	45	45
4	4	5	0
5	5	6	5
6	6	-45	0

<colgroup><col style="width: 25pxpx"><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Distribute​

Thank you so much, it works perfect, thank you for your help, I need a little bit more help, I have Serial number in Column A and I have data from Column B to Column P and I want the same code to perform in each column from B to P. and as in this code it showed the result in Column C of Sheet1. I want it to show on Sheet2 in column B to P. Please help

 

[Peter_SSs]

Best not to fully quote long posts as it makes the thread harder to read/navigate. If you want to quote, quote small, relevant parts only.

I have Serial number in Column A and I have data from Column B to Column P and I want the same code to perform in each column from B to P. and as in this code it showed the result in Column C of Sheet1. I want it to show on Sheet2 in column B to P. Please help

I found a bit of a glitch in the original code. Corrected here as well as allowing for the multiple columns. See how it goes.

Sub DistributeNegativeValues_v2()
  Dim AL As Object
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim a As Variant, itm As Variant
  Dim Dist As Long, i As Long, uba As Long, c As Long
  
  Set AL = CreateObject("System.Collections.ArrayList")
  Set ws1 = Sheets("Sheet1")
  Set ws2 = Sheets("Sheet2")
  For c = 2 To 16 'Columns B:P
    a = ws1.Range(ws1.Cells(1, c), ws1.Cells(ws1.Rows.Count, c).End(xlUp)).Value
    AL.Clear
    uba = UBound(a)
    Dist = 0
    For Each itm In a
      If itm < 0 Then
        Dist = Dist - itm
      Else
        AL.Add itm
      End If
    Next itm
    AL.Sort
    AL.Reverse
    ReDim Preserve a(1 To uba, 1 To 2)
    For Each itm In AL
      For i = 1 To uba
        If a(i, 1) = itm Then
          If IsEmpty(a(i, 2)) Then
            a(i, 2) = a(i, 1)
            If a(i, 2) > Dist Then a(i, 2) = Dist
            Dist = Dist - a(i, 2)
          End If
        End If
      Next i
    Next itm
    With ws2
      With .Cells(1, c).Resize(uba)
        .Value = Application.Index(a, 0, 2)
        On Error Resume Next
        .SpecialCells(xlBlanks).Value = 0
        On Error GoTo 0
      End With
    End With
  Next c
  ws1.Range("A1", ws1.Range("A" & ws1.Rows.Count).End(xlUp)).Copy Destination:=ws2.Range("A1")
End Sub

 

[Jyotirmaya]

best not to fully quote long posts as it makes the thread harder to read/navigate. If you want to quote, quote small, relevant parts only.

i found a bit of a glitch in the original code. Corrected here as well as allowing for the multiple columns. See how it goes.

sub distributenegativevalues_v2()
  dim al as object
  dim ws1 as worksheet, ws2 as worksheet
  dim a as variant, itm as variant
  dim dist as long, i as long, uba as long, c as long
  
  set al = createobject("system.collections.arraylist")
  set ws1 = sheets("sheet1")
  set ws2 = sheets("sheet2")
  for c = 2 to 16 'columns b:p
    a = ws1.range(ws1.cells(1, c), ws1.cells(ws1.rows.count, c).end(xlup)).value
    al.clear
    uba = ubound(a)
    dist = 0
    for each itm in a
      if itm < 0 then
        dist = dist - itm
      else
        al.add itm
      end if
    next itm
    al.sort
    al.reverse
    redim preserve a(1 to uba, 1 to 2)
    for each itm in al
      for i = 1 to uba
        if a(i, 1) = itm then
          if isempty(a(i, 2)) then
            a(i, 2) = a(i, 1)
            if a(i, 2) > dist then a(i, 2) = dist
            dist = dist - a(i, 2)
          end if
        end if
      next i
    next itm
    with ws2
      with .cells(1, c).resize(uba)
        .value = application.index(a, 0, 2)
        on error resume next
        .specialcells(xlblanks).value = 0
        on error goto 0
      end with
    end with
  next c
  ws1.range("a1", ws1.range("a" & ws1.rows.count).end(xlup)).copy destination:=ws2.range("a1")
end sub

thank you so much it works perfect

 

[Peter_SSs]

Remember:

Best not to fully quote long posts as it makes the thread harder to read/navigate. If you want to quote, quote small, relevant parts only.

thank you so much it works perfect

You're welcome.