求助大神，把横向格式转为纵向

摇摆不定的鱼儿

求助大神，把横向格式转为纵向，数据挺多，表挺长，有没有VBA可以实现，求！

sunya_0529

WPS里启用宏就可以——

摇摆不定的鱼儿

谢谢大佬，最近看了十多天的VBA教程，脑袋还是一个空白，看来还得努力，不过是我的版本太不对还是怎么，代码没法导出，复制出来的代码就是整齐的运行是无效字符，。

songshihai

1. Sub 整理数据()
   
2.     Dim brr(), arr, i, j, m, n
   
3.     arr = Range("a1").CurrentRegion
   
4.     For j = 5 To UBound(arr, 2) - 1 Step 2
   
5.         For i = 3 To UBound(arr)
   
6.             If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
   
7.             If arr(i, j) <> "" Then
   
8.                 n = n + 1
   
9.                 ReDim Preserve brr(1 To 8, 1 To n)
   
10.                 brr(1, n) = arr(1, 1)
    
11.                 For m = 1 To 4
    
12.                     brr(m + 1, n) = arr(i, m)
    
13.                 Next m
    
14.                 brr(6, n) = arr(i, j)
    
15.                 brr(7, n) = arr(i, 4) * arr(i, j)
    
16.                 brr(8, n) = arr(1, j)
    
17.             End If
    
18.         Next i
    
19.     Next j
    
20.     [l2].Resize(n, 8) = Application.Transpose(brr)
    
21. End Sub
    
22. 
    

复制代码

明天会更好zj

这个就是双循环，其中一个循环step 2而已

sunya_0529

摇摆不定的鱼儿 发表于 2024-9-16 15:27
谢谢大佬，最近看了十多天的VBA教程，脑袋还是一个空白，看来还得努力，不过是我的版本太不对还是怎么，代 ...

这是JSA，运行在WPS的“WPS宏编辑器”里的。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.16
   
2.     With Sheets("Sheet1")
   
3.         r = .Cells(Rows.Count, 3).End(3).Row
   
4.         arr = .[a1].Resize(r, 10)
   
5.         gx = .[a1]
   
6.     End With
   
7.     ReDim brr(1 To 10000, 1 To 8)
   
8.     For j = 5 To UBound(arr, 2) Step 2
   
9.         For i = 3 To UBound(arr)
   
10.             If arr(i, j) <> 0 Then
    
11.                 M = M + 1
    
12.                 If arr(i, 1) <> Empty Then st = arr(i, 1)
    
13.                 brr(M, 1) = gx
    
14.                 brr(M, 2) = st
    
15.                 brr(M, 3) = arr(i, 2)
    
16.                 brr(M, 4) = arr(i, 3)
    
17.                 brr(M, 5) = arr(i, 4)
    
18.                 brr(M, 6) = arr(i, j)
    
19.                 brr(M, 7) = arr(i, j + 1)
    
20.                 brr(M, 8) = arr(1, j)
    
21.             End If
    
22.         Next
    
23.     Next
    
24.     With Sheets("Sheet2")
    
25.         .UsedRange.Offset(1).Clear
    
26.         With .[a2].Resize(M, 8)
    
27.             .Value = brr
    
28.             .Borders.LineStyle = 1
    
29.             .HorizontalAlignment = xlCenter
    
30.             .VerticalAlignment = xlCenter
    
31.         End With
    
32.     End With
    
33.     MsgBox "OK！"
    
34. End Sub
    
35. 
    

复制代码

ykcbf1100

摇摆不定的鱼儿 发表于 2024-9-16 15:27
谢谢大佬，最近看了十多天的VBA教程，脑袋还是一个空白，看来还得努力，不过是我的版本太不对还是怎么，代 ...

你就看了10多天的教程就想写代码了，那得有多大的天赋啊。

cnmlgb9998

用PQ解决问题。


是这个效果吗？