按需求将数据进行拆分

x-xx-xx

抹不去の回忆

cidanji 发表于 2024-1-3 16:35

自己鼓捣出来了··思路跟您差不多··我用的split

抹不去の回忆

Sub ss()
Dim ar, i&, d As Object, x, xx, pj&, n&, a, b, c, an&, bn&, cn&
Set d = CreateObject("scripting.dictionary")
'取数
With Sheets("数据源")
    ar = .Range("A1:D" & .Cells(.Rows.Count, 1).End(3).Row)
End With
ReDim a(1 To UBound(ar), 1 To 4)
b = a
c = a
'数据置入字典
For i = 2 To UBound(ar)
    x = ar(i, 1)
    If Not d.exists(x) Then Set d(x) = CreateObject("scripting.dictionary")
    d(x)(ar(i, 2)) = ar(i, 3) & "-" & ar(i, 4)
Next
'分配至数组
For Each x In d.keys
    pj = Int(d(x).Count / 3) '平均数
    n = 0
    For Each xx In d(x).keys
        n = n + 1
        Select Case n
        Case Is <= pj
            an = an + 1
            a(an, 1) = x
            a(an, 2) = xx
            a(an, 3) = Split(d(x)(xx), "-")(0)
            a(an, 4) = Split(d(x)(xx), "-")(1)
        Case Is <= pj * 2
            bn = bn + 1
            b(bn, 1) = x
            b(bn, 2) = xx
            b(bn, 3) = Split(d(x)(xx), "-")(0)
            b(bn, 4) = Split(d(x)(xx), "-")(1)
           
        Case Else
            cn = cn + 1
            c(cn, 1) = x
            c(cn, 2) = xx
            c(cn, 3) = Split(d(x)(xx), "-")(0)
            c(cn, 4) = Split(d(x)(xx), "-")(1)
        End Select
    Next
Next
'写入分表
Sheet2.Range("A2:d" & Rows.Count).ClearContents
Sheet3.Range("A2:d" & Rows.Count).ClearContents
Sheet4.Range("A2:d" & Rows.Count).ClearContents
Sheet2.[A2].Resize(UBound(a), 4) = a
Sheet3.[A2].Resize(UBound(b), 4) = b
Sheet4.[A2].Resize(UBound(c), 4) = c
MsgBox "完成"
End Sub

抹不去の回忆

1. Sub ss()
   
2. Dim ar, i&, d As Object, x, xx, pj&, n&, a, b, c, an&, bn&, cn&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. '取数
   
5. With Sheets("数据源")
   
6.     ar = .Range("A1:D" & .Cells(.Rows.Count, 1).End(3).Row)
   
7. End With
   
8. ReDim a(1 To UBound(ar), 1 To 4)
   
9. b = a
   
10. c = a
    
11. '数据置入字典
    
12. For i = 2 To UBound(ar)
    
13.     x = ar(i, 1)
    
14.     If Not d.exists(x) Then Set d(x) = CreateObject("scripting.dictionary")
    
15.     d(x)(ar(i, 2)) = ar(i, 3) & "-" & ar(i, 4)
    
16. Next
    
17. '分配至数组
    
18. For Each x In d.keys
    
19.     pj = Int(d(x).Count / 3) '平均数
    
20.     n = 0
    
21.     For Each xx In d(x).keys
    
22.         n = n + 1
    
23.         Select Case n
    
24.         Case Is <= pj
    
25.             an = an + 1
    
26.             a(an, 1) = x
    
27.             a(an, 2) = xx
    
28.             a(an, 3) = Split(d(x)(xx), "-")(0)
    
29.             a(an, 4) = Split(d(x)(xx), "-")(1)
    
30.         Case Is <= pj * 2
    
31.             bn = bn + 1
    
32.             b(bn, 1) = x
    
33.             b(bn, 2) = xx
    
34.             b(bn, 3) = Split(d(x)(xx), "-")(0)
    
35.             b(bn, 4) = Split(d(x)(xx), "-")(1)
    
36.            
    
37.         Case Else
    
38.             cn = cn + 1
    
39.             c(cn, 1) = x
    
40.             c(cn, 2) = xx
    
41.             c(cn, 3) = Split(d(x)(xx), "-")(0)
    
42.             c(cn, 4) = Split(d(x)(xx), "-")(1)
    
43.         End Select
    
44.     Next
    
45. Next
    
46. '写入分表
    
47. Sheet2.Range("A2:d" & Rows.Count).ClearContents
    
48. Sheet3.Range("A2:d" & Rows.Count).ClearContents
    
49. Sheet4.Range("A2:d" & Rows.Count).ClearContents
    
50. Sheet2.[A2].Resize(UBound(a), 4) = a
    
51. Sheet3.[A2].Resize(UBound(b), 4) = b
    
52. Sheet4.[A2].Resize(UBound(c), 4) = c
    
53. MsgBox "完成"
    
54. End Sub
    

复制代码

cidanji

抹不去の回忆 发表于 2024-1-3 18:14
自己鼓捣出来了··思路跟您差不多··我用的split

也可以实现。
先连接再split一般用在key上，item一般原型装数组里直接用就可以，不需要先连再分动作

抹不去の回忆

修改后的分享出来，有需要拿去用，感谢cidanji原代码提供的思路

抹不去の回忆

cidanji 发表于 2024-1-3 18:25
也可以实现。
先连接再split一般用在key上，item一般原型装数组里直接用就可以，不需要先连再分动作

我有多组数据需要放进字典的值中，原表是我虚拟的，所有才需要先链接起来再用split拆分出来使用

titi012

参与一下。
这个做法可以折分成N个表，从1到单个门店的数据的最小值。修改里面的N就可以了。

1. Sub text()
   
2. 
   
3. Dim x&, y&, i&, j&, N&, M&, H&, R&
   
4. Dim Arr, Drr, Brr(), Nrr() As Long, Mrr() As Long, d As Object
   
5. 
   
6. N = 1  '// N 为须折分的工作表数量，可以修改。最小可为1，最大可以是单个门店的数据的最小值。
   
7. Set d = CreateObject("scripting.dictionary")
   
8. With Sheets("数据源")
   
9.     Arr = .Range("a2:c" & .Cells(Rows.Count, 1).End(xlUp).Row)
   
10. End With
    
11. ReDim Mrr(1 To UBound(Arr))
    
12. ReDim Nrr(1 To UBound(Arr), 1 To N + 1)
    
13. 
    
14. For x = 1 To UBound(Arr)
    
15.     d(Arr(x, 1)) = 1 + d(Arr(x, 1))
    
16.     Mrr(x) = d(Arr(x, 1))
    
17. Next x
    
18. 
    
19. For x = 1 To UBound(Arr)
    
20.     For y = 1 To N
    
21.         Nrr(x, y + 1) = Int(d(Arr(x, 1)) / N) * y
    
22.     Next y
    
23.     Nrr(x, N + 1) = Nrr(x, N + 1) + (d(Arr(x, 1)) Mod N)
    
24. Next x
    
25. 
    
26. H = Int(UBound(Arr) / N) + d.Count * (N - 1)
    
27. For i = 1 To N
    
28.     ReDim Brr(1 To H, 1 To 3)
    
29.     R = 0
    
30.     For x = 1 To UBound(Arr)
    
31.         If Mrr(x) > Nrr(x, i) And Mrr(x) <= Nrr(x, i + 1) Then
    
32.             R = R + 1
    
33.             For y = 1 To 3
    
34.                 Brr(R, y) = Arr(x, y)
    
35.             Next y
    
36.         End If
    
37.     Next x
    
38.     With Sheets("分表" & i)
    
39.         .Range("a2:c59999").ClearContents
    
40.         .Range("a2").Resize(H, 3) = Brr
    
41.     End With
    
42. Next i
    
43. 
    
44. End Sub
    

复制代码