请教用代码将回收款对应到销售金额

鄂龙蒙

请教:用代码将回收款对应到销售金额，谢谢！



将回收款对应到销售金额.rar (7.35 KB, 下载次数: 43)

2018-9-27 20:07 上传

点击文件名下载附件

excel玉米

想法如下(需要新增一行辅助行），抛砖引玉：
1.先用C列数据从上住下循环，减去B列从上往下第一个数，如果
  a:C-B>0,则取C=B,再新增一列，将余数填入下新列中。
  b:C-B=0,则取C=B,将余数填入.
  c:C-B<0,则新增一列，将C列填入，再循环到C列下一数据，直至a为止。
2.将相应数据合并居中操作。

鄂龙蒙

excel玉米 发表于 2018-9-27 21:39
想法如下(需要新增一行辅助行），抛砖引玉：
1.先用C列数据从上住下循环，减去B列从上往下第一个数，如果
...

按您的提示还是没做出来，能否帮写一下代码？谢谢！

一把小刀闯天下

'合计、单元格合并等自己处理一下，，，

Option Explicit

Sub test()
  Dim arr, i, j, a, b, cnt, t1, t2, sum, t
  arr = Range("a3:c" & Cells(Rows.Count, "a").End(xlUp).Row - 1)
  ReDim brr(1 To 10 * UBound(arr, 1), 1 To 4)
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 2)) Then a = a + 1: brr(a, 1) = arr(i, 1): brr(a, 2) = arr(i, 2)
    If Len(arr(i, 3)) Then b = b + 1: brr(b, 3) = arr(i, 1): brr(b, 4) = arr(i, 3)
  Next
  For i = 1 To UBound(brr, 1)
    If Len(brr(i, 2)) = 0 And Len(brr(i, 4)) = 0 Then Exit For
    If Len(brr(i, 2)) = 0 Then
      sum = 0
      For j = i To 1 Step -1
        sum = sum + brr(j, 4)
        If Len(brr(j, 2)) > 0 Then Exit For
      Next
      If brr(j, 2) < sum Then
        sum = sum - brr(j, 2): t = brr(j, 2)
        For j = i - 1 To j: t = t - brr(j, 4): Next
        b = b + 1
        For j = b To i + 2 Step -1
          brr(j, 3) = brr(j - 1, 3): brr(j, 4) = brr(j - 1, 4)
        Next
        brr(j, 3) = brr(i, 3): brr(j, 4) = sum: brr(i, 4) = t
      ElseIf brr(j, 2) > sum Then
        a = a + 1
        For j = a To i + 2 Step -1
          brr(j, 1) = brr(j - 1, 1): brr(j, 2) = brr(j - 1, 2)
        Next
        brr(j, 1) = vbNullString: brr(j, 2) = vbNullString
      End If
    Else
      If brr(i, 2) < brr(i, 4) Then
        b = b + 1
        For j = b To i + 2 Step -1
          brr(j, 3) = brr(j - 1, 3): brr(j, 4) = brr(j - 1, 4)
        Next
        brr(j, 3) = brr(i, 3): brr(j, 4) = brr(i, 4) - brr(i, 2): brr(i, 4) = arr(i, 2)
      ElseIf brr(i, 2) > brr(i, 4) Then
        a = a + 1
        For j = a To i + 2 Step -1
          brr(j, 1) = brr(j - 1, 1): brr(j, 2) = brr(j - 1, 2)
        Next
        brr(j, 1) = vbNullString: brr(j, 2) = vbNullString
      End If
    End If
  Next
  cnt = IIf(a > b, a, b)
  With [f3]
    With .Resize(2 * cnt, 4)
      .MergeCells = False
      .ClearContents
    End With
    .Resize(cnt, 4) = brr
  End With
End Sub

鄂龙蒙

一把小刀闯天下 发表于 2018-9-29 15:10
'合计、单元格合并等自己处理一下，，，

Option Explicit

再次谢谢您的帮助！
经测试大多数情况结果准确无误，
现在有一种情况下测试有误差，请您有空再帮看下。
将回收款对应到销售金额 - 副本.rar (17.52 KB, 下载次数: 26)

2018-10-1 16:20 上传

点击文件名下载附件

一把小刀闯天下

鄂龙蒙 发表于 2018-10-1 16:20
再次谢谢您的帮助！
经测试大多数情况结果准确无误，
现在有一种情况下测试有误差，请您有空再帮看下。 ...

'没有考虑连续空格，再试一下

Option Explicit

Sub test()
  Dim arr, i, j, a, b, t1, t2, sum, t, p
  arr = Range("a3:c" & Cells(Rows.Count, "a").End(xlUp).Row - 1)
  ReDim brr(1 To 10 * UBound(arr, 1), 1 To 4)
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 2)) Then a = a + 1: brr(a, 1) = arr(i, 1): brr(a, 2) = arr(i, 2)
    If Len(arr(i, 3)) Then b = b + 1: brr(b, 3) = arr(i, 1): brr(b, 4) = arr(i, 3)
  Next
  For i = 1 To UBound(brr, 1)
    If Len(brr(i, 2)) = 0 And Len(brr(i, 4)) = 0 Then Exit For
    If Len(brr(i, 2)) = 0 Then
      For j = i To UBound(brr, 1)
        If Len(brr(j, 2)) Then i = j - 1: Exit For
      Next
      sum = 0
      For j = i To 1 Step -1
        sum = sum + brr(j, 4)
        If Len(brr(j, 2)) > 0 Then p = j: Exit For
      Next
      If brr(j, 2) < sum Then
        sum = sum - brr(j, 2): t = brr(j, 2)
        For j = i - 1 To p Step -1: t = t - brr(j, 4): Next
        b = b + 1
        For j = b To i + 2 Step -1
          brr(j, 3) = brr(j - 1, 3): brr(j, 4) = brr(j - 1, 4)
        Next
        brr(j, 3) = brr(i, 3): brr(j, 4) = sum: brr(i, 4) = t
      ElseIf brr(j, 2) > sum Then
        a = a + 1
        For j = a To i + 2 Step -1
          brr(j, 1) = brr(j - 1, 1): brr(j, 2) = brr(j - 1, 2)
        Next
        brr(j, 1) = vbNullString: brr(j, 2) = vbNullString
      End If
    Else
      If brr(i, 2) < brr(i, 4) Then
        b = b + 1
        For j = b To i + 2 Step -1
          brr(j, 3) = brr(j - 1, 3): brr(j, 4) = brr(j - 1, 4)
        Next
        brr(j, 3) = brr(i, 3): brr(j, 4) = brr(i, 4) - brr(i, 2): brr(i, 4) = arr(i, 2)
      ElseIf brr(i, 2) > brr(i, 4) Then
        a = a + 1
        For j = a To i + 2 Step -1
          brr(j, 1) = brr(j - 1, 1): brr(j, 2) = brr(j - 1, 2)
        Next
        brr(j, 1) = vbNullString: brr(j, 2) = vbNullString
      End If
    End If
  Next
  a = IIf(a > b, a, b)
  With [f3]
    With .Resize(2 * a, 4)
      .MergeCells = False
      .ClearContents
    End With
    .Resize(a, 4) = brr
  End With
End Sub

鄂龙蒙

一把小刀闯天下 发表于 2018-10-1 21:40
'没有考虑连续空格，再试一下

Option Explicit

谢谢！总数好像少了。

鄂龙蒙

一把小刀闯天下 发表于 2018-10-1 21:40
'没有考虑连续空格，再试一下

Option Explicit

又来麻烦您了，第一个数都相同时出错。

将回收款对应到销售金额 - 测试.rar (17.04 KB, 下载次数: 46)

2018-10-2 15:21 上传

点击文件名下载附件

一把小刀闯天下

鄂龙蒙 发表于 2018-10-2 15:22
又来麻烦您了，第一个数都相同时出错。

数组名打错了，再试试（查找定位）
brr(i, 4) = arr(i, 2)改成：
----
brr(i, 4) = brr(i, 2)

pnzt

学习学习学习