一个数据重排问题

小女孩

紧急求助.rar (182.2 KB, 下载次数: 9)

2024-1-22 10:32 上传

点击文件名下载附件

把数据重新排一下，具体见附件，谢谢帮我的老师！

ykcbf1100

附件已更新。。。

feilanga

。。。。。。。。。。。。。。。。。

feilanga

ykcbf1100 发表于 2024-1-22 11:11
附件供参考。。。

好像没有看到代码

feilanga

1. Sub tt()
   
2.     r = Sheet1.Range("a65536").End(xlUp).Row
   
3.     arr = Sheet1.Range("A1:G" & r)
   
4.     ReDim brr(1 To UBound(arr) * 2, 1 To 4)
   
5.     For i = 2 To UBound(arr)
   
6.         k = k + 1
   
7.         For j = 2 To 4
   
8.             brr(k, 1) = arr(i, 1)
   
9.             brr(k, j) = arr(i, j)
   
10.         Next
    
11.         k = k + 1
    
12.         For j = 5 To 7
    
13.             brr(k, 1) = arr(i, 1)
    
14.             brr(k, j - 3) = arr(i, j)
    
15.         Next
    
16.     Next
    
17.     Sheet2.Range("F2").Resize(UBound(brr), 4) = brr
    
18. End Sub
    

复制代码

ykcbf1100

feilanga 发表于 2024-1-22 11:20
好像没有看到代码

晕，文件没有转成xlsm文件，白写了。

2楼附件已更新。

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, k&, r&
   
    Application.ScreenUpdating = False
   
    With Sheets(1).[A1].CurrentRegion
        ar = Intersect(.Offset(), .Offset(1))
        ReDim br(1 To UBound(ar) * 2, 1 To 4)
    End With
    For i = 1 To UBound(ar)
        For k = 1 To 2
            r = r + 1
            br(r, 1) = ar(i, 1)
            For j = 2 To 4
                br(r, j) = ar(i, (k - 1) * 3 + j)
            Next j
        Next k
    Next i
   
    [f1].CurrentRegion.Offset(1).Clear
    [f2].Resize(UBound(br), 4) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。