[已解决]以下效果能不能用循环代码做出来

被禁锢的风

需要编译一段程序，中间的一段我始终编的不好，求教一下能人。

附件中A3：D44为需要处理的数据，F列至S列为处理之后的数据。

处理的要求是，达到类似于WORD中多栏一样的效果。
具体是，将数据分成三栏，每五行数据列在一栏，第二个五行列在第二栏，第三个五行列在第三栏，第四个五行列在第一栏后面的数据，以此类推。对于不同的仓库名称的数据，不管上面是列到哪里，都要重新列在第一栏，并且标上标题。
为方便理解，我给数据标注上底纹

最佳答案

月排行榜 / 总排行榜

liuguansky

2011-9-8 11:09

1. Sub justtest1()
   
2.     Dim Arr, D, i&, ArrR(1 To 60000, 1 To 14) As String, Dt, K&, iR&, iC As Byte, j As Byte
   
3.     Set D = CreateObject("scripting.dictionary")
   
4.     Arr = Range("A1").CurrentRegion.Value
   
5.     For i = 2 To UBound(Arr, 1)
   
6.         D(Arr(i, 1)) = D(Arr(i, 1)) + 1
   
7.     Next i
   
8.     s = 0
   
9.     For Each Dt In D.keys
   
10.         K = 0: K = K + 1
    
11.         For j = 1 To 4
    
12.             ArrR(s + K, j) = Arr(1, j)
    
13.         Next j
    
14.         For i = 2 To UBound(Arr, 1)
    
15.             If Arr(i, 1) = Dt Then
    
16.                 K = K + 1
    
17.                 iR = (K - 1) Mod 5 + 1 + Int((K - 1) / 15) * 5
    
18.                 iC = Int(((K - 1) Mod 15) / 5) * 5
    
19.                 For j = 1 To 4
    
20.                     ArrR(s + iR, iC + j) = Arr(i, j)
    
21.                 Next j
    
22.             End If
    
23.         Next i
    
24.         s = s + Application.RoundUp((D(Dt) + 1) / 15, 0) * 5
    
25.     Next
    
26.     Range([f1], Cells(Cells.Count)).ClearContents
    
27.     Range("f1").Resize(s, 14) = ArrR
    
28.     Set D = Nothing
    
29. End Sub
    

复制代码

这是你要的效果。 问题.rar (14.85 KB, 下载次数: 41)

2011-9-8 11:09 上传

点击文件名下载附件

跳转到最佳答案楼层

无聊的疯子

回复 被禁锢的风 的帖子

多条件统计就可以了！！

无聊的疯子

看错了，数据都是一样的，这个要不用循环的话，就手动复制嘛！！

函数也可以的，只是不方便，循环很好用的，为啥不用呢？？

被禁锢的风

回复 无聊的疯子 的帖子

这个是我程序中的一部分功能，我需要用VBA来做。就是想用循环做出来

吕?布

你先用循环把数据分在三个数组中，然后一下子填上去

被禁锢的风

回复 吕?布 的帖子

刚想了下。是不是说每一栏列在一个数组上，这样一下子填上去？这样的话，第一栏的数组好处理，后面的数组有点乱。因为有些数据可能不到五行就要重新开始了。

借用下思路，想到，我可以处理完一个仓库的数据就往表格（数组）上贴一次，再处理下一个的，处理完再贴一次。这样最外层的循环只要统计下有多少个仓库就好了。

写下代码框架如下：
我想尽量回避使用GOTO语句。
1、我在一共有三个循环，我想退出最里层的两循环，使用了EXIT +K1这个控制变量。这样可以达到效果，可总觉得代码不简洁，是不是有更好的方式跳出其中的两个循环？
2、在跳出全部循环执行下面语句的时候，如果用上面的方法可以达到效果，我这里使用了GOTO方便查看，想知道是不是有还有其他方法可以直接跳出全部循环，执行下面语句。

Sub bbb()
    Dim K1 As Boolean           '判断是否重新开始的变量
    For i1 = 1 To 10    '10个仓库
        K1 = False
        For i2 = 1 To 3    '数据分成三栏
            For i3 = 1 To 5  '数据每5行就开始换栏
                If i3 = 2 Then       '判断是否为不同的仓库，为方便理解设定I3=2的时候就为不同仓库
                    K1 = True
                    Exit For
                End If
               
                i4 = i4 + 1      '源数据的列
                For i5 = 1 To 3  '源数据为3列
                    ' …… 处理数据
                    If i4 > 20 Then   '源数据一共为20列
                        GoTo A1:
                    End If
                Next i5
            Next i3
            If K1 = True Then
                Exit For
            End If
        Next i2
    Next i1
A:
'……处理其他数据
End Sub

liuguansky

1. Sub justtest()
   
2.     Dim Arr, D, i&, ArrR(1 To 60000, 1 To 240), j As Byte, iR&, iC As Byte, k&
   
3.     Set D = CreateObject("scripting.dictionary")
   
4.     Arr = Range("A1").CurrentRegion.Value
   
5.     For i = 2 To UBound(Arr, 1)
   
6.         If D.exists(Arr(i, 1)) Then
   
7.             D(Arr(i, 1)) = Array(D(Arr(i, 1))(0), D(Arr(i, 1))(1) + 1)
   
8.         Else
   
9.             k = D.Count * 5 + 1
   
10.             D.Add Arr(i, 1), Array(k, 1)
    
11.             For j = 1 To 4
    
12.                 ArrR(k, j) = Arr(1, j)
    
13.             Next j
    
14.         End If
    
15.         iR = (D(Arr(i, 1))(1) - 1) Mod 4 + 1
    
16.         iC = Application.RoundUp(D(Arr(i, 1))(1) / 4, 0)
    
17.         For j = 1 To 4
    
18.             ArrR(D(Arr(i, 1))(0) + iR, iC * 5 - 5 + j) = Arr(i, j)
    
19.         Next j
    
20.     Next i
    
21.     Range([f1], Cells(Cells.Count)).ClearContents
    
22.     Range("f1").Resize(D.Count * 5, 240) = ArrR
    
23.             
    
24. End Sub
    

复制代码

问题.rar (10.42 KB, 下载次数: 26)

2011-9-8 10:14 上传

点击文件名下载附件
理解错效果了,不过你的要求更容易点.你修改下吧.

liuguansky

1. Sub justtest1()
   
2.     Dim Arr, D, i&, ArrR(1 To 60000, 1 To 14) As String, Dt, K&, iR&, iC As Byte, j As Byte
   
3.     Set D = CreateObject("scripting.dictionary")
   
4.     Arr = Range("A1").CurrentRegion.Value
   
5.     For i = 2 To UBound(Arr, 1)
   
6.         D(Arr(i, 1)) = D(Arr(i, 1)) + 1
   
7.     Next i
   
8.     s = 0
   
9.     For Each Dt In D.keys
   
10.         K = 0: K = K + 1
    
11.         For j = 1 To 4
    
12.             ArrR(s + K, j) = Arr(1, j)
    
13.         Next j
    
14.         For i = 2 To UBound(Arr, 1)
    
15.             If Arr(i, 1) = Dt Then
    
16.                 K = K + 1
    
17.                 iR = (K - 1) Mod 5 + 1 + Int((K - 1) / 15) * 5
    
18.                 iC = Int(((K - 1) Mod 15) / 5) * 5
    
19.                 For j = 1 To 4
    
20.                     ArrR(s + iR, iC + j) = Arr(i, j)
    
21.                 Next j
    
22.             End If
    
23.         Next i
    
24.         s = s + Application.RoundUp((D(Dt) + 1) / 15, 0) * 5
    
25.     Next
    
26.     Range([f1], Cells(Cells.Count)).ClearContents
    
27.     Range("f1").Resize(s, 14) = ArrR
    
28.     Set D = Nothing
    
29. End Sub
    

复制代码

这是你要的效果。 问题.rar (14.85 KB, 下载次数: 41)

2011-9-8 11:09 上传

点击文件名下载附件

被禁锢的风

和我原先想的有点不一样，不过这样达到的效果是相同的。
代码还要理解下，做循环有时候也是考验数学的事。

被禁锢的风

回复 liuguansky 的帖子

iC = Int(((K - 1) Mod 15) / 5) * 5
这句代码的意思是每隔五行，数据就在0,5,10三个数据中循环，这样可以知道把数据放在哪一列中



可下面这个代码，我知道是数据放在哪一行中，可就是理解不出规律，能解释一下吗？
iR = (K - 1) Mod 5 + 1 + Int((K - 1) / 15) * 5