插入组数据的问题

杨小妹

附件 插入组数据附件.rar (7.13 KB, 下载次数: 7)

2024-3-4 22:42 上传

点击文件名下载附件

谢谢老师！

shiruiqiang

shiruiqiang

Sub test()
Dim arr(1 To 1000, 1 To 1)
With Sheets(1)
For x = 1 To 99 Step 3
n = n + 1
arr(n, 1) = .Cells(x, 1)
n = n + 1
arr(n, 1) = .Cells(x + 1, 1)
n = n + 2
arr(n, 1) = .Cells(x, 4)
n = n + 1
arr(n, 1) = .Cells(x + 1, 4)
Next
End With

Sheets(1).[j1].Resize(n, 1) = arr
End Sub

杨小妹

shiruiqiang 发表于 2024-3-4 22:51
Sub test()
Dim arr(1 To 1000, 1 To 1)
With Sheets(1)

老师你好，谢谢帮助。试了一下，结果连在一起的。
应如图中M列中的结果，是一组隔一行。

shiruiqiang

Sub test()
Dim arr(1 To 1000, 1 To 1)
With Sheets(1)
For x = 1 To 99 Step 3
n = n + 1
arr(n, 1) = .Cells(x, 1)
n = n + 1
arr(n, 1) = .Cells(x + 1, 1)
n = n + 2
arr(n, 1) = .Cells(x, 4)
n = n + 1
arr(n, 1) = .Cells(x + 1, 4)
n=n+1
Next
End With

Sheets(1).[j1].Resize(n, 1) = arr
End Sub

shiruiqiang

杨小妹 发表于 2024-3-5 07:36
老师你好，谢谢帮助。试了一下，结果连在一起的。
应如图中M列中的结果，是一组隔一行。

fzxba

Sub test0()
  Dim ar, br()
  Dim i As Long, j As Long, y As Long, r As Long
  ar = Range("A1:D" & Range("A:D").Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1)
  ReDim br(1 To UBound(ar) * 3, 0)
  For i = 1 To UBound(ar) Step 3
    For j = 1 To 4 Step 3
      For y = i To i + 2
        r = r + 1
        br(r, 0) = ar(y, j)
      Next
    Next
  Next
  Range("F1").Resize(r) = br
End Sub

saghj

。。。。。