两个for循环和两个if套嵌，程序一直调试不过，急，请高手帮忙。

liuxi001

期待大大们简化

1. Sub lx()
   
2.     Dim ar(1 To 1000, 1 To 6)
   
3.     xs = Sheet1.[a1].CurrentRegion
   
4.     th = Sheet2.[a1].CurrentRegion
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set dd = CreateObject("scripting.dictionary")
   
7.     For i = 2 To UBound(th)
   
8.         s = th(i, 1) & th(i, 2)
   
9.         d(s) = th(i, 3)
   
10.         dd(s) = th(i, 4)
    
11.     Next
    
12.     For i = 2 To UBound(xs)
    
13.         s = xs(i, 1) & xs(i, 3)
    
14.         If d(s) <> 0 And xs(i, 4) > d(s) Then
    
15.             c = c + 1
    
16.             ar(c, 1) = xs(i, 1)
    
17.             ar(c, 2) = xs(i, 2)
    
18.             ar(c, 3) = xs(i, 3)
    
19.             ar(c, 4) = xs(i, 4) - d(s)
    
20.             ar(c, 5) = xs(i, 5)
    
21.             ar(c, 6) = ar(c, 4) * ar(c, 5)
    
22.             c = c + 1
    
23.             ar(c, 1) = xs(i, 1)
    
24.             ar(c, 2) = "新客户"
    
25.             ar(c, 3) = xs(i, 3)
    
26.             ar(c, 4) = d(s)
    
27.             d(s) = 0
    
28.             ar(c, 5) = dd(s)
    
29.             ar(c, 6) = ar(c, 4) * ar(c, 5)
    
30.         ElseIf d(s) <> 0 And xs(i, 4) <= d(s) Then
    
31.             c = c + 1
    
32.             ar(c, 1) = xs(i, 1)
    
33.             ar(c, 2) = xs(i, 2)
    
34.             ar(c, 3) = xs(i, 3)
    
35.             ar(c, 4) = 0
    
36.             ar(c, 5) = xs(i, 5)
    
37.             ar(c, 6) = ar(c, 4) * ar(c, 5)
    
38.             c = c + 1
    
39.             ar(c, 1) = xs(i, 1)
    
40.             ar(c, 2) = "新客户"
    
41.             ar(c, 3) = xs(i, 3)
    
42.             ar(c, 4) = xs(i, 4)
    
43.             d(s) = d(s) - xs(i, 4)
    
44.             ar(c, 5) = dd(s)
    
45.             ar(c, 6) = ar(c, 4) * ar(c, 5)
    
46.         Else
    
47.             c = c + 1
    
48.             ar(c, 1) = xs(i, 1)
    
49.             ar(c, 2) = xs(i, 2)
    
50.             ar(c, 3) = xs(i, 3)
    
51.             ar(c, 4) = xs(i, 4)
    
52.             ar(c, 5) = xs(i, 5)
    
53.             ar(c, 6) = xs(i, 6)
    
54.         End If
    
55.     Next
    
56.     [a33].Resize(c, 6) = ar
    
57. End Sub

复制代码

tsgnhj

758920075 发表于 2019-1-6 20:07
楼主的问题是不是，一边插入新列，一边用单元格地址进行循环，每次插入的时候，之后行的行号就变化了，却还 ...

对，一边插入行一边循环，昨天夜里刚把我自己的代码调试通。

maqiuhua

厉害，学习的态度贼拉端正

tsgnhj

liuxi001 发表于 2019-1-6 23:25
期待大大们简化

谢谢，第5-6行知道是字典，从第8行-13行不太懂，麻烦解释一下，学习一下。

tsgnhj

1. <div>Sub danjiazhuanhuan()
   
2. Dim m As Integer
   
3. 'm为销售明细中的行号
   
4. Dim n As Integer
   
5. 'n为替换内容中的行号
   
6. Dim sysl As Integer
   
7. 'sysl为替换内容中的待分配数量减去新增数量后的差
   
8. Dim dfp As Variant
   
9. 'dfp为替换内容中的待分配数量
   
10. For n = 2 To 4 Step 1
    
11. dfp = Sheets(2).Cells(n, "c")
    
12. '给待分配赋初始值
    
13.     For m = 2 To 20
    
14.     'm上限设定为1000，主要是不确定m最后的数字可以达到多少，就假设为1000了
    
15.         If Sheets(1).Cells(m, "a") & Sheets(1).Cells(m, "c") = Sheets(2).Cells(n, "a") & Sheets(2).Cells(n, "b") And Sheets(1).Cells(m, "b") <> "新客户" Then
    
16.         sysl = dfp - Sheets(1).Cells(m, "d")
    
17.              If sysl < 0 Then
    
18.                 Sheets(1).Rows(m).Select
    
19.                 '选中待替换行
    
20.                 Selection.Copy
    
21.                 '复制待替换行
    
22.                 Sheets(1).Rows(m + 1).Select
    
23.                 '待替换行下一行选中
    
24.                 Selection.Insert shift:=xlDown
    
25.                 '待替换行下插入刚才复制的一行
    
26.                   With Sheets(1)
    
27.                        .Cells(m + 1, "b") = "新客户"
    
28.                        '新增行添加客户名称
    
29.                        .Cells(m + 1, "d") = dfp
    
30.                        '新增行添加替换的数量
    
31.                        .Cells(m + 1, "e") = Sheets(2).Cells(n, "d")
    
32.                        '新增行添加商品单价
    
33.                        .Cells(m, "d") = 0 - sysl
    
34.                        End With
    
35.                        Exit For
    
36.                        '如果待分配的数量分配完了，就跳出m循环，继续n循环
    
37.                     Else
    
38.                         Sheets(1).Rows(m).Select
    
39.                         '选中待替换行
    
40.                         Selection.Copy
    
41.                         '复制待替换行
    
42.                         Sheets(1).Rows(m + 1).Select
    
43.                         '待替换行下一行选中
    
44.                         Selection.Insert shift:=xlDown
    
45.                         '待替换行下插入刚才复制的一行
    
46.                         With Sheets(1)
    
47.                         .Cells(m + 1, "b") = "新客户"
    
48.                         '新增行添加客户名称
    
49.                         .Cells(m + 1, "e") = Sheets(2).Cells(n, "d")
    
50.                         '新增行中添加商品单价
    
51.                         .Cells(m, "d") = 0
    
52.                         '被替换单价后原来行（上一行）商品数量变为0
    
53.                         End With
    
54.                         dfp = sysl
    
55.                         '把剩余未分配的数量重量赋值给dfp
    
56.                 End If
    
57.             Else
    
58.             GoTo line1
    
59.             '在sheet(1)中循环，如果与sheet(2)中的匹配不上，或是客户名字等于“新客户”（新客户代表新增加的行），就继续下一个m循环。
    
60.             End If</div><div>line1:
    
61.     Next
    
62. Next
    
63. End Sub
    
64.    
    
65. </div>

复制代码

我用自己的笨办法把代码调通了，分享一下，也算是给自己一个鼓励。
前面三位大神回复的代码，第一位看懂20%，第二位差不多能看懂80%，第三位也差不多80%，就是那几句卡壳了。

758920075

Sub 测试()
    Dim i As Byte '中间变量
    Dim h As Integer '行号
    Dim n As Integer ' sheets2中循环变量
    Dim m As Integer '出现分配不够时的中间变量
    Dim zb(1 To 99) As Integer 's是数组的循环变量
   
    Dim s As Integer
    s = 0
    p = 1
    i = 0
    x = 1 '储存插入列的循环变量
   
    For n = 2 To 1000
        If Sheets(2).Cells(n, 2) = "" Then Exit For
      
    Set zhongjianzhi = Sheets(2).Cells(n, "b")
    Set zjz = Sheets(2).Cells(n, "c")
For Each c In Sheets(1).Range("c2:c1000")
    If c.Value = zhongjianzhi Then
       h = c.row
       l = c.Column
       yp = Sheets(1).Cells(h, l + 1)
       Sheets(1).Cells(h, l + 1) = Sheets(1).Cells(h, l + 1) - zjz
   
                    If Sheets(1).Cells(h, l + 1).Value < 0 Then ' 不够分配的情况
                    

                    m = 0 - Sheets(1).Cells(h, l + 1).Value
                    Sheets(1).Cells(h, l + 1).Value = 0
                    Sheets(1).Cells(h + 1, l + 1).Value = Sheets(1).Cells(h + 1, l + 1).Value - m
                    Sheets(1).Cells(h + 1, l + 3) = Sheets(1).Cells(h + 1, l + 2) * Sheets(1).Cells(h + 1, l + 1)
                    
                    Sheets(4).Cells(x, 1) = "12月1日"
                    Sheets(4).Cells(x, 2) = "新客户"
                    Sheets(4).Cells(x, 3) = zhongjianzhi
                    Sheets(4).Cells(x, 4) = yp
                    Sheets(4).Cells(x, 5) = Sheets(2).Cells(n, "d")
                    Sheets(4).Cells(x, 6) = Sheets(2).Cells(n, "d") * yp
               
                    s = s + 1
                   zb(s) = h
                    x = x + 1
                    Sheets(4).Cells(x, 1) = "12月1日"
                    Sheets(4).Cells(x, 2) = "新客户"
                    Sheets(4).Cells(x, 3) = zhongjianzhi
                    Sheets(4).Cells(x, 4) = m
                    Sheets(4).Cells(x, 5) = Sheets(2).Cells(n, "d")
                    Sheets(4).Cells(x, 6) = Sheets(2).Cells(n, "d") * m
                    Sheets(1).Cells(h, l + 3) = Sheets(1).Cells(h, l + 2) * Sheets(1).Cells(h, l + 1)
                    x = x + 1
                    s = s + 1
                      zb(s) = h + 1
                    i = i + 1
                    Else   '够分配的情况
                  
                    
                  
                    Sheets(1).Cells(h, l + 3) = Sheets(1).Cells(h, l + 2) * Sheets(1).Cells(h, l + 1)
                    Sheets(4).Cells(x, 1) = "12月1日"
                    Sheets(4).Cells(x, 2) = "新客户"
                    Sheets(4).Cells(x, 3) = zhongjianzhi
                    Sheets(4).Cells(x, 4) = zjz
                    Sheets(4).Cells(x, 5) = Sheets(2).Cells(n, "d")
                    Sheets(4).Cells(x, 6) = Sheets(2).Cells(n, "d") * zjz
                    x = x + 1
                    i = i + 1
                    s = s + 1
           zb(s) = h
                    
                    End If
     End If
            If i <> 0 Then
            i = 0
            Exit For
            End If

    Next c
    Next n
k = 0    '粘贴过程中为了消除行号变化的循环变量
For u = 1 To s
Sheets(4).Activate
ActiveSheet.Rows(u).Select
Selection.Copy
Sheets(1).Activate
ActiveSheet.Rows(zb(u) + k).Select
Selection.Insert Shift:=xlUp
k = k + 1

Next u
    End Sub
我的强行完成巨丑代码，正儿八经第一次写完一个啥子，我也发一下鼓励下自己哈哈

micch

758920075 发表于 2019-1-6 19:56
借楼请教一下，谢楼主
m，同学：
arr = Sheet1.[a1].CurrentRegion '====销售明细表原内容存入数组

一段时间没来，刚看到。应该是列数

autolzg

学习一下.....

758920075

micch 发表于 2018-12-27 13:59
if判断结束退出用goto语句，只会数组循环，字典不熟练。

得到结果是覆盖源文件，还是生成新表，或者放其 ...

m同学您好，可以的话在想请教一个问题
大概问题是这样的
dim a as integer
dim b as integer
a= 1
b= 2
range (cells(a,b)).select
在上面的代码中
range (cells(a,b)).select 这个为啥是错误的呢

万分感谢

micch

cells(a,b).select

不需要range了，为什么错我就不知道了