另类的转置，谢谢蓝桥玄霜、quqiyuan、cidanji、Qs18老师！

lhj323323

老师


我想把统计表的最后一行，按每3列一组，进行转置
如下
求助1.rar (17.15 KB, 下载次数: 14)

2024-7-20 12:53 上传

点击文件名下载附件

老师如有空，请帮忙看看，先谢谢了。

蓝桥玄霜

合计的例子：

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。。
Sub 合计()
   Dim myr%, myc%
   Dim arr, Arr1, Arr2, Brr, Brr2, Arr3, Brr3
   Dim i%, j%, m%
   Dim sss As Double
Application.ScreenUpdating = False

ReDim Brr(1 To 10000, 1 To 3)
With Sheet1
     myr = .[a65536].End(xlUp).Row
'此处需要另类的转置
    arr = .Range(.Cells(myr, "f"), .Cells(myr, "t"))
    For i = 1 To UBound(arr, 2) Step 3
        If arr(1, i) <> Empty Then
            n = n + 1
            Brr(n, 1) = arr(1, i)
            Brr(n, 2) = arr(1, i + 1)
            Brr(n, 3) = arr(1, i + 2)
        End If
    Next
    .[v1].CurrentRegion.Offset(1).ClearContents
    .[v2].Resize(n, 3) = Brr
End With
Application.ScreenUpdating = True
Beep
End Sub

cidanji

rysxing

function test(){
        let ar1=Range('f41:t41').Value2,ar2=[];
        ar1.forEach(v=>{for(let i=0;3*i<v.length;i++) v[3*i]!=0?ar2.push(v.slice(3*i,3*i+3)):null;})
        Range('v2').Resize(ar2.length,3).Value2=ar2;
}

Qs18

试试...........

Qs18

Sub qs()
Dim arr, brr, i
cols = 3 ' 列数固定为3
With Sheet1
    arr = .Range("f41:t41")
    ReDim brr(1 To 100, 1 To 3)
    For i = 1 To UBound(arr, 2)
    If arr(1, i) > 0 Then
      j = i Mod cols ' 计算列
      If j = 1 Then m = m + 1
      If j = 0 Then j = 3
    brr(m, j) = arr(1, i)
    End If
    Next
    .Range("v2").Resize(UBound(brr), 3) = brr
End With
End Sub

Qs18

试试..........

usedrange

1. Sub 合计()
   
2.    Dim arr, sh
   
3.    Dim i%, j%, m%
   
4. Application.ScreenUpdating = False
   
5. 
   
6. With Sheet1
   
7.     m = .[az41].End(xlToLeft).Column
   
8.     ReDim arr(1 To m, 1 To 3)
   
9.     r = 6
   
10.     For i = 6 To m Step 3
    
11.         If .Cells(41, i) <> 0 Then
    
12.             Set sh = .Cells(41, i).Resize(1, 3)
    
13.             .Range("v" & r).Resize(1, 3) = sh.Value
    
14.             r = r + 1
    
15.             Set sh = Nothing
    
16.         End If
    
17.     Next i
    
18. End With
    
19. Application.ScreenUpdating = True
    
20. End Sub

复制代码