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

361478294 · 发表于 2014-12-30 14:11

论坛关于二维表的例子很多，但是局限性很大，利用透视表把二维表转成一维表并不能达到目的。
这个是两个表，数据都是一样的，一维表，二维表各一个，求互相转换的方法。

yaozong · 发表于 2014-12-31 11:16

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

yaozong · 发表于 2015-8-24 12:01

附件

150824-一维二维表式互转.rar (16.35 KB, 下载次数: 237)

361478294 · 发表于 2014-12-30 14:41

二维表通过按条件列拆分然后再合并能达到目的
但是一维表转二维表就不知道咋弄了。

chxw68 · 发表于 2014-12-30 14:50

Sub 一转二()
Dim d As New Dictionary
Dim d1 As New Dictionary
Dim r%, i%, c%, j%
Dim arr, brr
With Worksheets("一维表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:h" & r)
End With
m = 6
s = 0
For i = 1 To UBound(arr)
If Not d1.Exists(arr(i, 7)) Then
m = m + 1
d1(arr(i, 7)) = m
End If
xm = arr(i, 2) & "+" & arr(i, 3) & "+" & arr(i, 4) & "+" & arr(i, 5) & "+" & arr(i, 6)
If Not d.Exists(xm) Then
s = s + 1
ReDim brr(1 To 50)
brr(1) = s
For j = 2 To 6
brr(j) = arr(i, j)
Next
Else
brr = d(xm)
End If
n = d1(arr(i, 7))
brr(n) = brr(n) + arr(i, 8)
d(xm) = brr
Next
With Worksheets("sheet1")
.Range("g1").Resize(1, d1.Count) = d1.Keys
.Columns("b:b").NumberFormatLocal = "0000000000000"
.Range("a2").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.Items))
End With
End Sub

复制代码

chxw68 · 发表于 2014-12-30 14:51

只做了一维转二维的，但结果与楼主的不一样，请楼主检查一下附件中的模拟结果是否正确。

361478294 · 发表于 2014-12-30 14:59

chxw68 发表于 2014-12-30 14:51
只做了一维转二维的，但结果与楼主的不一样，请楼主检查一下附件中的模拟结果是否正确。

老师您好，结果是一样的。谢谢。
请问二维表转一维表是否有简便方法

361478294 · 发表于 2014-12-30 15:05

chxw68 发表于 2014-12-30 14:51
只做了一维转二维的，但结果与楼主的不一样，请楼主检查一下附件中的模拟结果是否正确。

而且，还有一个问题啊老师
有时候列数据不止6列，改代码有点费劲。。。

361478294 · 发表于 2014-12-30 15:12

再求个简便方法

chxw68 · 发表于 2014-12-30 15:15

Sub 二转一()
Dim r%, i%, c%, j%
Dim arr, brr
With Worksheets("二维表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
End With
ReDim brr(1 To (r - 1) * (c - 6), 1 To 8)
m = 0
For j = 7 To UBound(arr, 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)
End If
Next
Next
With Worksheets("一维表")
.UsedRange.Offset(1, 0).Clear
.Columns("b:b").NumberFormatLocal = "0000000000000"
.Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
r = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("a1").Resize(r, 8).Borders.LineStyle = xlContinuous
End With
End Sub

复制代码

chxw68 · 发表于 2014-12-30 15:16

两问都做好了。二转一相对要简单一些。

zax010 · 发表于 2014-12-30 15:43

Sub zz()
Dim d1 As New Dictionary, d2 As New Dictionary, d3 As New Dictionary, arr
arr = Sheet4.Range("A1").CurrentRegion
For i = 2 To UBound(arr)
      d1(arr(i, 7)) = ""
      d2(arr(i, 2)) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6))
      d3(arr(i, 2) & arr(i, 7)) = d3(arr(i, 2) & arr(i, 7)) + arr(i, 8)
Next
With Sheet1
      .[g1].Resize(1, d1.Count) = d1.keys
      .[b2].Resize(d2.Count, 5) = Application.Rept(d2.items, 1)
      For i = 2 To d2.Count + 1
         For j = 7 To d1.Count + 6
            .Cells(i, j) = d3(.Cells(i, 2).Value & .Cells(1, j).Value)
         Next
      Next
End With
End Sub

		自动登录	找回密码
密码			免费注册

[求助] 【二维表与一维表互相转换】的问题！！！

评分

评分

评分

点评

评分