【二维表与一维表互相转换】的问题！！！

zax010

>>>>>>>>>>>>>>
求二维表与一维表互相转换.rar (19.62 KB, 下载次数: 85)

2014-12-30 15:52 上传

点击文件名下载附件

361478294

继续求方法

yaozong

361478294 发表于 2014-12-30 16:24
继续求方法

1. Sub yy() ''一维转二维
   
2. Sheets("互转测试表").Activate
   
3. Dim d(1 To 2) As New dictionary, arr, ar, i&, j&, m&, n&, x$, y$
   
4. arr = [a1].CurrentRegion.Value
   
5. ReDim brr(1 To UBound(arr), 1 To 100)
   
6. n = 5
   
7. For i = 1 To UBound(arr)
   
8.    x = arr(i, 7)
   
9.    ar = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6))
   
10.    y = Join(ar, ",")
    
11.    If Not d(1).exists(x) Then
    
12.       n = n + 1: d(1)(x) = n: brr(1, n) = x
    
13.    End If
    
14.    If Not d(2).exists(y) Then
    
15.       m = m + 1: d(2)(y) = m: brr(m, 1) = m - 1
    
16.       For j = 0 To UBound(ar)
    
17.          brr(m, j + 2) = ar(j)
    
18.       Next
    
19.    End If
    
20.    If i > 1 And j > 1 Then brr(d(2)(y), d(1)(x)) = brr(d(2)(y), d(1)(x)) + arr(i, 8)
    
21. Next
    
22. [a1].CurrentRegion.Clear
    
23. Columns("B:B").NumberFormatLocal = "000000"
    
24. [a1].Resize(m, n) = brr
    
25. [a1] = "序号"
    
26. End Sub

复制代码

yaozong

361478294 发表于 2014-12-30 16:24
继续求方法

1. Sub zz() ''二维转一维
   
2. Sheets("互转测试表").Activate
   
3. Dim arr, ar, i%, j%, m&, n&, k&
   
4. arr = [a1].CurrentRegion.Value
   
5. ar = Application.Index(arr, 1, 0)
   
6. n = Application.CountA([a1].CurrentRegion.Offset(, 6))
   
7. ReDim brr(1 To n, 1 To 8)
   
8. For j = 7 To UBound(arr, 2)
   
9.    For i = 2 To UBound(arr)
   
10.       If Len(arr(i, j)) <> 0 Then
    
11.          m = m + 1
    
12.          brr(m, 1) = m
    
13.          For k = 2 To 6
    
14.             brr(m, k) = arr(i, k)
    
15.          Next
    
16.          brr(m, 7) = arr(1, j)
    
17.          brr(m, 8) = arr(i, j)
    
18.       End If
    
19.    Next
    
20. Next
    
21. [a1].CurrentRegion.Clear
    
22. [a1].Resize(1, 6) = ar
    
23. [g1] = "学校名": [h1] = "数量"
    
24. Columns("b:b").NumberFormatLocal = "000000"
    
25. [a2].Resize(m, 8) = brr
    
26. End Sub

复制代码

yaozong

参考附件。。。。。。。。。。

361478294

yaozong 发表于 2014-12-30 17:54
参考附件。。。。。。。。。。

老师  能否加上注释

yaozong

361478294 发表于 2014-12-31 08:39
老师  能否加上注释

Sub yy() ''一维转二维
Sheets("互转测试表").Activate ''激活该表
Dim d(1 To 2) As New dictionary, arr, ar, i&, j&, m&, n&, x$, y$ ''定义变量
arr = [a1].CurrentRegion.Value  ''原数据
ReDim brr(1 To UBound(arr), 1 To 100)  ''重命名数组brr
n = 5
For i = 1 To UBound(arr)  ''2至最后行循环(数组内)
   x = arr(i, 7)  ''学校名
   ar = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6)) ''基础参数
   y = Join(ar, ",") ''基础参数转字符串
   If Not d(1).exists(x) Then  ''如果字典(1)的学校名未有
      n = n + 1: d(1)(x) = n: brr(1, n) = x ''学校名进字典,进数组brr第1行的n列(第6列开始)
   End If
   If Not d(2).exists(y) Then  ''如果字典(2)的基础参数未有
      m = m + 1: d(2)(y) = m: brr(m, 1) = m - 1  ''基础参数进字典,进数组brr第1列的m行(序号m-1)
      For j = 0 To UBound(ar)
         brr(m, j + 2) = ar(j) ''基础参数进数组2至6列的对应行
      Next
   End If  ''下句:除行列标题外数量累加到对应行列
   If i > 1 And j > 1 Then brr(d(2)(y), d(1)(x)) = brr(d(2)(y), d(1)(x)) + arr(i, 8)
Next
[a1].CurrentRegion.Clear ''删除原数据
Columns("B:B").NumberFormatLocal = "000000" ''B列的数字格式(邮政编码)
[a1].Resize(m, n) = brr ''结果数据
[a1] = "序号"
End Sub

yaozong

361478294 发表于 2014-12-31 08:39
老师  能否加上注释

Sub zz() ''二维转一维
Sheets("互转测试表").Activate      ''激活该表
Dim arr, ar, i%, j%, m&, n&, k&    ''定义变量
arr = [a1].CurrentRegion.Value     ''原数据
ar = Application.Index(arr, 1, 0)  ''原数据(第1行)
n = Application.CountA([a1].CurrentRegion.Offset(, 6)) ''各类\校 数量格个数
ReDim brr(1 To n, 1 To 8)    ''重命名数组brr
For j = 7 To UBound(arr, 2)  ''G至最后列循环
   For i = 2 To UBound(arr)  ''2至最后行循环(数组内)
      If Len(arr(i, j)) <> 0 Then ''数量格不为空
         m = m + 1                ''累加
         brr(m, 1) = m            ''序号
         For k = 2 To 6
            brr(m, k) = arr(i, k) ''B至F列参数
         Next
         brr(m, 7) = arr(1, j)    ''学校名称
         brr(m, 8) = arr(i, j)    ''数量
      End If
   Next
Next
[a1].CurrentRegion.Clear ''删除原数据
[a1].Resize(1, 6) = ar   ''[A1:F1]引用原数据(标题)
[g1] = "学校名": [h1] = "数量"  ''加上标题名称
Columns("b:b").NumberFormatLocal = "000000"  ''B列的数字格式(邮政编码)
[a2].Resize(m, 8) = brr  ''结果数据
End Sub

361478294

yaozong 发表于 2014-12-31 11:16
Sub zz() ''二维转一维
Sheets("互转测试表").Activate      ''激活该表
Dim arr, ar, i%, j%, m&, n&, ...

一维二维表式互转.zip (16.75 KB, 下载次数: 66)

2015-8-24 10:42 上传

点击文件名下载附件

老师您好, 这个二维公式很好用, 但是现在有个新问题, 就是想在学校名后面加一列备注,请问老师该怎么操作

yaozong

361478294 发表于 2015-8-24 10:47
老师您好, 这个二维公式很好用, 但是现在有个新问题, 就是想在学校名后面加一列备注,请问老师该怎么操 ...

Sub yz() ''二维转一维
'''Sheets("互转测试表").Activate
Dim d, arr, ar, i%, j%, m&, n&, k&
Set d = CreateObject("Scripting.Dictionary")
arr = Sheets("互转测试表").[a1].CurrentRegion.Value
ar = Application.Index(arr, 1, 0)
'''n = Application.CountA([a1].CurrentRegion.Offset(, 6))
ReDim brr(1 To 10000, 1 To 9)
For j = 7 To UBound(arr, 2) Step 2
   For i = 2 To UBound(arr)
      If Len(arr(i, j)) <> 0 Then
         m = m + 1
         brr(m, 1) = m
         For k = 2 To 6
            brr(m, k) = arr(i, k)
         Next
         brr(m, 7) = arr(1, j)
         brr(m, 8) = arr(i, j)
         brr(m, 9) = arr(i, j + 1)
      End If
   Next
Next
With Sheets("结果")
    .[a1].CurrentRegion.Clear
    .[a1].Resize(1, 9) = ar
    .[g1] = "学校名": [h1] = "数量": [I1] = "备注"
    .Columns("b:b").NumberFormatLocal = "000000"
    .[a2].Resize(m, 9) = brr
End With
End Sub