VBA数组中插行问题

f8b1987

数组插行问题.zip (15.35 KB, 下载次数: 16)

2024-4-24 10:12 上传

点击文件名下载附件

将左侧内容读入数组后，全程用数组完成，最后一次写入到表格中。
我附件中有代码基本能实现，但是方法比较笨，如果列数多的话，代码变得很长。


请问是否有更好的方法？如有，请帮忙写一下，谢谢

chxw68

1. Sub test2()
   
2.     Dim r%, i%, m%
   
3.     Dim xm$
   
4.     Dim arr, brr, zrr()
   
5.     With Worksheets("sheet1")
   
6.         r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
   
7.         arr = .Range("a2:c" & r)
   
8.         ReDim brr(1 To UBound(arr) * 3, 1 To UBound(arr, 2))
   
9.         m = 0
   
10.         xm = Empty
    
11.         For i = 1 To UBound(arr)
    
12.             If arr(i, 1) <> xm And i <> 1 Then
    
13.                 For q = 1 To 2
    
14.                     m = m + 1
    
15.                     brr(m, 1) = arr(i - 1, 1)
    
16.                     brr(m, 2) = "D-1"
    
17.                     brr(m, 3) = "E"
    
18.                 Next
    
19.             End If
    
20.             If i <> UBound(arr) Then
    
21.                 m = m + 1
    
22.                 For j = 1 To UBound(arr, 2)
    
23.                     brr(m, j) = arr(i, j)
    
24.                 Next
    
25.             End If
    
26.             xm = arr(i, 1)
    
27.         Next
    
28.         .Range("i2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
29. 
    
30.     End With
    
31. End Sub
    
32. 
    

复制代码

chxw68

参与一下。

3190496160

Sub 插入行()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim arr As Variant
Dim brr()
With ActiveSheet
    arr = Range("A1:C7")
    ReDim brr(1 To UBound(arr) * 3, 1 To UBound(arr, 2))
    For i = 2 To UBound(arr)
        If arr(i, 1) <> "" Then
            If Not d.exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
            d(arr(i, 1))(i) = i
        End If
    Next i
    For Each k In d.keys
        For Each kk In d(k).keys
            n = n + 1
            For j = 1 To UBound(arr, 2)
                brr(n, j) = arr(kk, j)
            Next j
        Next kk
        n = n + 2
        brr(n - 1, 1) = k
        brr(n - 1, 2) = "D-1"
        brr(n - 1, 3) = "E"
        brr(n, 1) = k
        brr(n, 2) = "D-2"
        brr(n, 3) = "E"
    Next k
    .[f1].CurrentRegion.Offset(1) = Empty
    .[f2].Resize(n, UBound(brr, 2)) = brr
End With
Set d = Nothing
MsgBox "ok!"
End Sub

3190496160

数组插行问题.rar (19.49 KB, 下载次数: 10)

2024-4-24 10:39 上传

点击文件名下载附件

f8b1987

chxw68 发表于 2024-4-24 10:34
参与一下。

没细看代码哈，不过结果是有点错的，因为插入的分D-1和D-2（非递增序号，只是模拟值)

f8b1987

3190496160 发表于 2024-4-24 10:39

谢谢，你的方法很巧妙

cidanji

1. Sub ss()
   
2. Dim r&, ar, i&, d As Object, t, x
   
3. Set d = CreateObject("scripting.dictionary")
   
4. r = Cells(Rows.Count, 1).End(3).Row
   
5. ar = Range("A1:C" & r)
   
6. For i = 2 To UBound(ar)
   
7.     d(i) = Array(ar(i, 1), ar(i, 2), ar(i, 3))
   
8.     If i < UBound(ar) Then If ar(i, 1) = ar(i + 1, 1) Then GoTo 1
   
9.     d(i & "-" & 1) = Array(ar(i, 1), "D-1", "E")
   
10.     d(i & "-" & 2) = Array(ar(i, 1), "D-2", "E")
    
11. 1:
    
12. Next
    
13. Range("F2:H" & Rows.Count).ClearContents
    
14. If d.Count Then Range("F2").Resize(d.Count, 3) = Application.Rept(d.items, 1)
    
15. End Sub

复制代码

chxw68

f8b1987 发表于 2024-4-24 10:46
没细看代码哈，不过结果是有点错的，因为插入的分D-1和D-2（非递增序号，只是模拟值)

没仔细看就放弃吧，我也是练习呢。

micch

1. Sub 插入行()
   
2. Dim arr As Variant
   
3. Dim brr()
   
4. With ActiveSheet
   
5.     arr = Range("A1:C7")
   
6.     ReDim brr(1 To UBound(arr) * 2, 1 To UBound(arr, 2))
   
7.     For i = 2 To UBound(arr)
   
8.         If arr(i, 1) <> arr(i - 1, 1) Then
   
9.                 j = j + 1
   
10.                 brr(j, 1) = arr(i, 1)
    
11.                 brr(j, 2) = "d1"
    
12.                 brr(j, 3) = "E"
    
13.                 j = j + 1
    
14.                 brr(j, 1) = arr(i, 1)
    
15.                 brr(j, 2) = "d2"
    
16.                 brr(j, 3) = "E"
    
17.         End If
    
18.     Next i
    
19.     .[f1].CurrentRegion.ClearContents
    
20.     .[f1].Resize(i - 1, UBound(brr, 2)) = arr
    
21.     .Cells(i, 6).Resize(j, 3).Value = brr
    
22.     .Range("f:h").Sort .Range("F1"), , , , , , , 1
    
23. End With
    
24. End Sub
    

复制代码