求助多维转置问题

learence

不规则多维度转置，14k也可能会改变为950，0.5也可能会更改为0.3等。具体附表。

cnmlgb9998

是这个效果吗？


借楼练一下PQ。就动动鼠标，键盘碰都不用碰 就能达到你要的效果！

PQ 不香么？ 还要什么VB ？？？？？

learence

cnmlgb9998 发表于 2024-6-8 10:52
是这个效果吗？

能达到效果就好，认为只有VBA才能实现，我先试下，谢谢

LIUZHU

参与下，效果展示

飞天篮球猪

LIUZHU

JS代码，供参考

1. function 转置(){
   
2.         const arr=Range("d1:l"+ Range("l"+ Rows.Count).End(xlUp).Row).Value2;
   
3.         let res=[], regex=/\d+/, key, bt1, bt2;
   
4.         arr.slice(2).forEach(function(x){
   
5.                 for (let j=1;j<x.length;j++){
   
6.                         key=bt1[j]!=null?String(bt1[j]).match(regex)[0]:key;
   
7.                         res.push([x[0], key, bt2[j], x[j]]);
   
8.                 }
   
9.         }, [bt1=arr[0], bt2=arr[1]]);
   
10.         Range("n1").Resize(res.length, res[0].length).Value2=res;
    
11. }

复制代码

LIUZHU

附件，WPS打开测试，不能用于Excel

baofa2

1. Sub test1()
   
2.   Dim data, results()
   
3.   Dim i As Long, j As Long, cnt As Long, s As String
   
4.   data = Range("L1", Cells(Rows.Count, "D").End(xlUp)).Value
   
5.   ReDim results(1 To UBound(data) * UBound(data, 2), 1 To 4)
   
6.   For j = 2 To UBound(data, 2)
   
7.     If Len(data(1, j)) Then s = data(1, j)
   
8.     data(1, j) = s
   
9.   Next
   
10.   For i = 3 To UBound(data)
    
11.     For j = 2 To UBound(data, 2)
    
12.       cnt = cnt + 1
    
13.       results(cnt, 1) = data(i, 1)
    
14.       results(cnt, 2) = data(1, j)
    
15.       results(cnt, 3) = data(2, j)
    
16.       results(cnt, 4) = data(i, j)
    
17.     Next
    
18.   Next
    
19.   With Range("N2")
    
20.     .CurrentRegion.Clear
    
21.     With .Resize(cnt, UBound(results, 2))
    
22.       .Borders.LineStyle = xlContinuous
    
23.       .HorizontalAlignment = xlCenter
    
24.       .Value = results
    
25.     End With
    
26.   End With
    
27.   Beep
    
28. End Sub
    

复制代码

ww87725244

1. Sub aa()
   
2. Dim ar, i, k, s, ar1(1 To 10000, 1 To 4), m
   
3. With Worksheets("转置")
   
4.     ar = .Range("d1:l" & .Range("D65535").End(xlUp).Row)
   
5.     For i = 3 To UBound(ar)
   
6.         If ar(i, 1) <> "" Then
   
7.             For k = 2 To UBound(ar, 2)
   
8.                 If ar(1, k) <> "" Then
   
9.                     s = ar(1, k)
   
10.                 End If
    
11.                 If ar(i, k) <> "" Then
    
12.                     m = m + 1
    
13.                     ar1(m, 1) = ar(i, 1)
    
14.                     ar1(m, 2) = s
    
15.                     ar1(m, 3) = ar(2, k)
    
16.                     ar1(m, 4) = Round(ar(i, k), 0)
    
17.                 End If
    
18.             Next
    
19.         End If
    
20.     Next
    
21. End With
    
22. Sheet2.UsedRange.ClearContents
    
23. Sheet2.[a1].Resize(UBound(ar1), UBound(ar1, 2)) = ar1
    
24. End Sub

复制代码

learence

LIUZHU 发表于 2024-6-8 11:25
附件，WPS打开测试，不能用于Excel

非常感谢，快速便捷