将多个数据向数组赋值

xzh_yzcn

各位老师：
我由1个数组arr0，想根据条件将数据组成新的数组，最后填入单元格。运用二维数组赋值，动态二维数组上标不可变，下标可变，此外需要转换思路将行列转置，再逐行循环赋值，赋值后的数组行为列，列为行，最后向单元格赋值时需要转置
现改用array及 join两个函数，将符合条件的数据，串成一个字符串，此处实质将二维数组变为一维数组来处理，后最后向单元格赋值时会对单元格的内容（前面运用array\join两个函数串成的字符串）作单元格分列处理，试编的代码如下：
osht.Select
orwb = osht.Cells.Find("合计").Row
arr0 = osht.Range("a7:n" & orwb - 1)
Dim jzsgfarr()
Dim azsgfarr()
m = 0: n = 0
For x = 1 To UBound(arr0, 1)
    If arr0(x, 6) = "9201010100" Then
        m = m + 1
        'ReDim Preserve jzsgfarr(1 to 3,1 To m)
        'jzsgfarr(1,m)=arr9(x,9) : jzsgfarr(2,m)=arr9(x,13) : jzsgfarr(3,m)=arr9(x,14)
       '如果数据项多，此处的代码就会较长，编码容易错
        ReDim Preserve jzsgfarr(1 To m)
       jzsgfarr(m) = Join(Array(arr0(x, 9), arr0(x, 13), arr0(x, 14)), ",")
    End If   
Next
Workbooks(jsbbwbkname).Activate
If m > 0 Then
   jsbbsht52.Select
   If m > 7 Then
        Range("a14").Resize(m - 7, 1).EntireRow.Insert CopyOrigin:=xlFormatFromRightOrBelow
        Range("c14").Resize(1, 12).Copy
        Range("c14").Resize(m - 7, 1).PasteSpecial Paste:=xlPasteAll
   End If
   Range("b7").Resize(m, 1) = Application.Transpose(jzsgfarr)
   '单元格数据分列
   Range("b7").Resize(m, 1).TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=True, Comma:=True
End If


请教各位老师，有没有更巧妙的方法，不用被注释掉的方法，后面也不涉及单元格分列
谢谢

iwangyi

转置用TRANSPOSE

xzh_yzcn

谢谢
我想如下面数据项多时容易出错的情况，有无更好的方法（目标是如何代码简洁易懂实际依据源数组给目标数组赋值
'ReDim Preserve jzsgfarr(1 to 3,1 To m)
        'jzsgfarr(1,m)=arr9(x,9) : jzsgfarr(2,m)=arr9(x,13) : jzsgfarr(3,m)=arr9(x,14)
       '如果数据项多，此处的代码就会较长，编码容易错
老师的意思是将源数组转置，再逐项给目标数组赋值

大灰狼1976

附件简单示例仅供参考。
有两个建议：
1、定义一个规则数组（附件arrRule数组），可以简化代码，也可以使今后的修改极为便利；
2、虽然不确定结果大小，但一般情况下不需要将结果数组设置为动态，输出时只输出有用部分就行了，
   除非源数据非常庞大，但结果数据可预知非常小，这个时候才考虑使用动态数组。

vba code:

1. Sub test()
   
2. Dim arrOri, arrRst, arrRule, i&, j&, r&
   
3. arrOri = [a1].CurrentRegion
   
4. arrRule = Array(3, 5, 6, 8)
   
5. ReDim arrRst(1 To UBound(arrOri), UBound(arrRule))
   
6. For i = 2 To UBound(arrOri)
   
7.   If arrOri(i, 1) = "a1" Then
   
8.     r = r + 1
   
9.     For j = 0 To UBound(arrRule)
   
10.       arrRst(r, j) = arrOri(i, arrRule(j))
    
11.     Next j
    
12.   End If
    
13. Next i
    
14. [j1].CurrentRegion = ""
    
15. [j1].Resize(r, UBound(arrRst, 2)) = arrRst
    
16. End Sub

复制代码

大灰狼1976

不好意思，以上代码少输出了一列，修改如下
[j1].Resize(r, UBound(arrRst, 2)) = arrRst
改成
[j1].Resize(r, UBound(arrRst, 2) + 1) = arrRst

microyip

http://club.excelhome.net/thread-1517858-1-1.html 用类做自定义SQL读取函数及数组转置函数，参考变通一下

xzh_yzcn

大灰狼1976 发表于 2020-1-13 12:34
附件简单示例仅供参考。
有两个建议：
1、定义一个规则数组（附件arrRule数组），可以简化代码，也可以使 ...

谢谢，感谢提供新思路