数据转置处理

转角处的沉思

请教下如何实现将sheet1中几列数据转换成如效果一和二这2两种情况的行列数据样式。其中效果一是转换成6行10列一组数据，然后将原A列数据对应的C列数据同时生成在下一行，组间空一行。效果二其实也是转换成6行10列一组数据（只是将原A和C列组合后排布）。

taller

清风竹-

请看附件。

3190496160

Sub 转置()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br()
With Sheets("Sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数据源为空！": End
    ar = .Range("a1:c" & r)
End With
ReDim br(1 To UBound(ar) * 2, 1 To 10)
ReDim cr(1 To UBound(ar) * 2, 1 To 10)
For i = 2 To UBound(ar) Step 10
    m = m + 1
    n = n + 2
    y = 0
    k = k + 1
    For s = i To i + 9
        If s <= UBound(ar) Then
            y = y + 1
            br(n - 1, y) = ar(s, 1)
            br(n, y) = ar(s, 3)
            cr(k, y) = ar(s, 1) & "-" & ar(s, 3)
        End If
    Next s
    If m Mod 3 = 0 Then n = n + 1
    If m Mod 6 = 0 Then k = k + 1
Next i
With Sheets("效果一")
    .UsedRange = Empty
    .[a1].Resize(n, UBound(br, 2)) = br
End With
With Sheets("效果二")
    .UsedRange = Empty
    .[a1].Resize(k, UBound(cr, 2)) = cr
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

数据二次整理.rar (86.28 KB, 下载次数: 13)

2024-2-8 09:31 上传

点击文件名下载附件

转角处的沉思

taller 发表于 2024-2-8 08:39

感谢郗版主帮助，提前预祝新年快乐！

转角处的沉思

清风竹- 发表于 2024-2-8 08:59
请看附件。

感谢帮助，提前预祝新年快乐！

转角处的沉思

3190496160 发表于 2024-2-8 09:29
Sub 转置()
Application.ScreenUpdating = False
Dim ar As Variant

感谢春风化雨帮助，提前预祝新年快乐！

yynrzwh

1. Sub test()
   
2. 
   
3. ar = Sheet1.Range("a1").CurrentRegion
   
4. ReDim br(1 To UBound(ar), 1 To 10)
   
5. ReDim cr(1 To UBound(ar), 1 To 10)
   
6. r = 1: j = 1: r2 = 1
   
7.     For i = 2 To UBound(ar)
   
8.         If r Mod 13 = 0 Then r = r + 1
   
9.         If r2 Mod 7 = 0 Then r2 = r2 + 1
   
10.         
    
11.         If j <= 10 Then
    
12.             br(r, j) = ar(i, 1): br(r + 1, j) = ar(i, 3)
    
13.             cr(r2, j) = ar(i, 1) & "-" & ar(i, 3)
    
14.             j = j + 1
    
15.         Else
    
16.             j = 1: r = r + 2
    
17.             r2 = r2 + 1: i = i - 1
    
18.         End If
    
19.     Next
    
20. Sheet2.UsedRange = ""
    
21. Sheet3.UsedRange = ""
    
22. Sheet2.Range("a1").Resize(r + 1, 10) = br
    
23. Sheet3.Range("a1").Resize(r2 + 1, 10) = cr
    
24. End Sub

复制代码