ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 3564|回复: 12

vba数组怎么转化问题

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-3-18 14:10 | 显示全部楼层 |阅读模式
如下图所示,怎么用VBA转化数据格式?有大神在吗
啊.jpg

shuju.zip

8.71 KB, 下载次数: 7

TA的精华主题

TA的得分主题

发表于 2020-3-18 14:27 | 显示全部楼层
Sub a()
    Dim arr, brr(1 To 999, 1 To 2)
    Dim i, j, m
    arr = [a1].CurrentRegion
    For j = 2 To 5
        For i = 2 To UBound(arr)
            m = m + 1
            brr(m, 1) = arr(i, 1)
            brr(m, 2) = arr(i, j)
        Next
    Next
    [d11].Resize(m, 2) = brr
End Sub

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-3-18 14:29 | 显示全部楼层
  1. Sub test()
  2. Dim arr, arr1, i&, j&, r&
  3. arr = [a2:e7]
  4. ReDim arr1(1 To (UBound(arr, 2) - 1) * UBound(arr), 1 To 2)
  5. For j = 2 To UBound(arr, 2)
  6.   For i = 1 To UBound(arr)
  7.     r = r + 1
  8.     arr1(r, 1) = arr(i, 1)
  9.     arr1(r, 2) = arr(i, j)
  10.   Next i
  11. Next j
  12. [a11].Resize(r, 2) = arr1
  13. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-3-18 14:30 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
  1. Sub Test()
  2.     Dim sh As Worksheet, lngRow As Long, lngCol As Long
  3.     Dim arrOld As Variant, arrNew As Variant, lngID As Long
  4.    
  5.     Set sh = Sheets("Sheet1")
  6.    
  7.     arrOld = sh.Range("A2:E7")
  8.    
  9.     lngRow = UBound(arrOld) - LBound(arrOld) + 1
  10.     lngCol = UBound(arrOld, 2) - LBound(arrOld, 2) + 1
  11.    
  12.     lngRow = lngRow * (lngCol - 1)
  13.    
  14.     ReDim arrNew(1 To lngRow, 1 To 2)
  15.    
  16.     For lngCol = LBound(arrOld, 2) + 1 To UBound(arrOld, 2)
  17.         For lngRow = LBound(arrOld) To UBound(arrOld)
  18.             lngID = lngID + 1
  19.             arrNew(lngID, 1) = arrOld(lngRow, LBound(arrOld, 2))
  20.             arrNew(lngID, 2) = arrOld(lngRow, lngCol)
  21.         Next
  22.     Next
  23.    
  24.     sh.Range("A11").Resize(lngID, 2) = arrNew
  25. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2020-3-18 14:41 | 显示全部楼层
  1. Sub TEST()
  2. Dim Arr, Brr, i, j, M, N
  3. Arr = [A2:E7]
  4. M = UBound(Arr): N = UBound(Arr, 2)
  5. ReDim Brr(1 To M * (N - 1), 1 To 2)
  6. For j = 2 To N
  7.     For i = 1 To M
  8.         Brr(i + M * (j - 2), 1) = Arr(i, 1)
  9.         Brr(i + M * (j - 2), 2) = Arr(i, j)
  10.     Next
  11. Next
  12. [D11].Resize(M * (N - 1), 2) = Brr
  13. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-3-18 14:43 | 显示全部楼层
  1. Sub test()
  2. Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1) = "目标"
  3. For n = 2 To [iv2].End(xlToLeft).Column
  4.     i = Cells(Rows.Count, 1).End(xlUp).Row + 1
  5. arr = Range("a2:a7")
  6. brr = Range(Cells(2, n), Cells(7, n))
  7. Range("A" & i).Resize(UBound(arr), 1) = arr
  8. Range("B" & i).Resize(UBound(arr), 1) = brr

  9. Next
  10. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-3-18 14:44 | 显示全部楼层
++++++++++附件参考

shuju.zip

11.79 KB, 下载次数: 2

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-3-18 15:30 | 显示全部楼层
  1. Sub yy()
  2. arr = [a2:e7]
  3. a = Split(Join(Application.Transpose(Application.Index(arr, , 1)), ",") & "," & Join(Application.Transpose(Application.Index(arr, , 1)), ",") & "," & Join(Application.Transpose(Application.Index(arr, , 1)), ",") & "," & Join(Application.Transpose(Application.Index(arr, , 1)), ","), ",")
  4. b = Split(Join(Application.Transpose(Application.Index(arr, , 2)), ",") & "," & Join(Application.Transpose(Application.Index(arr, , 3)), ",") & "," & Join(Application.Transpose(Application.Index(arr, , 4)), ",") & "," & Join(Application.Transpose(Application.Index(arr, , 5)), ","), ",")
  5. [a11].Resize(UBound(arr) * 4, 1) = Application.Transpose(a)
  6. [b11].Resize(UBound(arr) * 4, 1) = Application.Transpose(b)
  7. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2020-3-18 15:31 | 显示全部楼层
。。。。。。。。。。。。。。。。。

shuju.rar

11.35 KB, 下载次数: 1

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-18 15:39 | 显示全部楼层
魂断蓝桥 发表于 2020-3-18 14:27
Sub a()
    Dim arr, brr(1 To 999, 1 To 2)
    Dim i, j, m

谢谢!我和你一样的思路,结果R代码弄习惯了没弄m = m + 1 结果一直不行,现在可以了多谢!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 23:47 , Processed in 0.049944 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表