[已解决]数组转换格式

张雄友

数组转换格式，怎么下标越界，求指点。

1. Sub 纵向转换横向()
   
2. Dim arr1, arr2()
   
3. Dim Rnum As Long, Cnum As Long, Tnum As Long
   
4. Dim i As Long, j As Long, k As Long
   
5. Rnum = [A65536].End(xlUp).Row '最大行号
   
6. Cnum = 3 '最大列号
   
7. Tnum = Rnum * Cnum '总数，避免太大
   
8. Range("J2:L" & Tnum).ClearContents
   
9. arr1 = Range("A1:C" & Rnum) '源数组
   
10. ReDim arr2(1 To Tnum, 1 To 20)
    
11. For i = 2 To Rnum
    
12.     For j = 2 To Cnum
    
13.         If arr1(i, j) <> "" Then '忽略空值
    
14.             k = k + 1:
    
15.             arr2(k, 1) = arr1(i, 1)
    
16.             arr2(1, k) = arr1(1, 2)
    
17.             arr2(k, 3) = arr1(i, j)
    
18.         End If
    
19.     Next
    
20. Next
    
21. Range("G20").Resize(k, UBound(arr2, 2)) = arr2
    
22. End Sub
    
23. 
    
24. 
    

复制代码

最佳答案

月排行榜 / 总排行榜

爱疯

2015-5-28 09:11

Sub test7()
    On Error Resume Next
    Application.AddCustomList Array("M", "L", "XL", "2XL", "3XL", "4XL")    '用了数组，就可以不用辅助区
    On Error GoTo 0

    Sheets.Add after:=Sheets(Sheets.Count)
    With ActiveSheet.PivotTableWizard(xlDatabase, Sheets(1).[a1].CurrentRegion)
        .PivotFields("货号").Orientation = xlRowField
        .PivotFields("尺寸").Orientation = xlColumnField
        .PivotFields("数量").Orientation = xlDataField
    End With

    Dim A
    A = Range("a1").CurrentRegion.Offset(1, 0)
    Cells.Clear
    Range("a1").Resize(UBound(A), UBound(A, 2)).Value = A
    Range("a1").CurrentRegion.Borders.LineStyle = 1
    ActiveWindow.DisplayGridlines = False
    Application.DeleteCustomList Application.CustomListCount    '删除最后一条（也就是本过程添加的）自定义序列
End Sub



说明：
绿色部分执行后，excel中新增加一条自定义序列。
执行其它操作，...
蓝色部分执行后，由绿色部分增加的自定义序列便删除了。也就是说，没有'后遗症'。

跳转到最佳答案楼层

张雄友

排序方式是：M        L        XL        2XL        3XL        4XL    ......数字XL  

dsmch

Sub Macro1()
Dim arr, brr, d, i&, s&
Set d = CreateObject("scripting.dictionary")
w = Array("M", "L", "XL", "2XL", "3XL", "4XL")
arr = Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To UBound(w) + 2)
For i = 0 To UBound(w)
    d(w(i)) = i + 2
Next
For i = 2 To UBound(arr)
    If Not d.exists(arr(i, 1)) Then
        s = s + 1
        d(arr(i, 1)) = s
        brr(s, 1) = arr(i, 1)
        brr(s, d(arr(i, 2))) = arr(i, 3)
    Else
        n = d(arr(i, 1))
        brr(n, d(arr(i, 2))) = brr(n, d(arr(i, 2))) + arr(i, 3)
    End If
Next
Range("g19").Resize(s, UBound(brr, 2)) = brr
End Sub

爱疯

'用数据透视表向导来创建
Sub test2()
    Dim pt As PivotTable
    Sheets.Add after:=Sheets(Sheets.Count)
    Set pt = ActiveSheet.PivotTableWizard(xlDatabase, Sheets(1).[a1].CurrentRegion)
    With pt
        .PivotFields("货号").Orientation = xlRowField
        .PivotFields("尺寸").Orientation = xlColumnField
        .PivotFields("数量").Orientation = xlDataField
        .PivotFields("尺寸").PivotItems("M").Position = 1
    End With
End Sub

数组转换格式2.rar (11.49 KB, 下载次数: 5)

2015-5-26 09:40 上传

点击文件名下载附件



用数据透视表，可不担心尺寸的变化。
加总计，看起来好些，不喜欢也可不要。

神隐汀渚

1. 这个ID好熟悉 哪里见过

复制代码

grf1973

1. Sub grf()
   
2.     Dim arr, brr, d, d1, i&, w()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     w = Array("货号", "M", "L", "XL", "2XL", "3XL", "4XL")
   
6.     arr = Range("a1").CurrentRegion
   
7.     For i = 2 To UBound(arr)
   
8.         d(arr(i, 1)) = ""
   
9.         x = arr(i, 1) & arr(i, 2)
   
10.         d1(x) = d1(x) + arr(i, 3)
    
11.     Next
    
12.     [g1].Resize(1, UBound(w) + 1) = w
    
13.     [g2].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
14.     brr = [g1].CurrentRegion
    
15.     For i = 2 To UBound(brr)
    
16.         For j = 2 To UBound(brr, 2)
    
17.             brr(i, j) = d1(brr(i, 1) & brr(1, j))
    
18.         Next
    
19.     Next
    
20.     [g1].CurrentRegion = brr
    
21. End Sub
    

复制代码

grf1973

用公式最简单

1. Sub grf()
   
2.     Dim arr, brr, d, d1, i&, w()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     w = Array("货号", "M", "L", "XL", "2XL", "3XL", "4XL")
   
5.     arr = Range("a1").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         d(arr(i, 1)) = ""
   
8.     Next
   
9.     [g1].Resize(1, UBound(w) + 1) = w
   
10.     [g2].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
11.     [h2].Formula = "=SUMIFS($C:$C,$A:$A,$G2,$B:$B,H$1)"
    
12.     [h2].Copy [h2].Resize(d.Count, UBound(w))
    
13. End Sub

复制代码

张雄友

dsmch 发表于 2015-5-26 08:40
Sub Macro1()
Dim arr, brr, d, i&, s&
Set d = CreateObject("scripting.dictionary")

如果尺码不止4xl，能否自动向右增加！

张雄友

神隐汀渚 发表于 2015-5-26 10:30

制衣厂就这些多……

张雄友

grf1973 发表于 2015-5-26 10:55

如果尺码还有很多能否适应向右增加？？