求助数据分列

世界客都

各位老师们大家好，这有个问题想寻求大家的帮助。感激不尽。

求助.zip (199.15 KB, 下载次数: 20)

2024-1-24 17:22 上传

点击文件名下载附件

dambcer

这不和公式区的贴一样吗 那里是日期

世界客都

dambcer 发表于 2024-1-24 17:49
这不和公式区的贴一样吗 那里是日期

公式我写了，但是运行起来慢
谢谢老师的代码，简单易懂
无奈我平时很少写代码，状态很差，还劳您费时了，谢谢您。

cjc209

jsa 代码 自定义函数
function test(){
        timeStart_Z();
        var arr=maxArray_Z("b2:b2");
        var rs=[];
        var arr1=pageByRows_Z(arr,11);
        arr1.map((r,i,brr)=>{
                var r1=r.slice(1).一列转多列(2,"c");
                var crl=r.take_Z(1);
                rs=rs.concat(r1.insertCols_Z(0,crl[0][0],1,0));
        });
        rs.toRange_Z("d2");
        alert(timelog_Z());
}

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, r&, c&, iColSize&
   
    Application.ScreenUpdating = False
   
    ar = Range("B2", Cells(Rows.Count, "B").End(xlUp)).Value
    ReDim br(1 To UBound(ar), 1 To UBound(ar))
    For i = 1 To UBound(ar)
        If InStr(ar(i, 1), "jpg") Then
            r = r + 1: c = 1
            br(r, 1) = ar(i, 1)
        Else
            c = c + 1
            br(r, c) = ar(i, 1)
            If c > iColSize Then iColSize = c
        End If
    Next i
   
    [D1].CurrentRegion.Offset(1).Clear
    [D2].Resize(r, iColSize) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

世界客都

gwjkkkkk 发表于 2024-1-24 18:56
参与一下。。。

谢谢老师。

cjc209

要全展开就更简单
function test(){
        var arr=maxArray_Z("b2");
        var rs=[]
        var arr1=pageByRows_Z(arr,11);
        arr1.map((r)=>{
                rs=rs.concat(r.transpose_Z());
        });
        rs.toRange_Z("d2");
}

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.24
   
2.     Dim zrr(1 To 1000)
   
3.     Application.ScreenUpdating = False
   
4.     Sheets("教学").Activate
   
5.     r = Cells(Rows.Count, 2).End(3).Row
   
6.     arr = Range("b1:b" & r)
   
7.     ReDim brr(1 To UBound(arr), 1 To 3)
   
8.     On Error Resume Next
   
9.     For i = 2 To UBound(arr) + 1
   
10.         If i = r Then zrr(m)(1) = r
    
11.         If InStr(UCase(arr(i, 1)), ".JPG") Then
    
12.             m = m + 1
    
13.             zrr(m) = Array(i + 1, i)
    
14.         End If
    
15.         If InStr(UCase(arr(i + 1, 1)), ".JPG") Then zrr(m)(1) = i
    
16.     Next
    
17.     For x = 1 To m - 1
    
18.         st = arr(zrr(x)(0) - 1, 1)
    
19.         For i = zrr(x)(0) To zrr(x)(1) Step 2
    
20.             k = k + 1
    
21.             brr(k, 1) = st
    
22.             brr(k, 2) = arr(i, 1)
    
23.             brr(k, 3) = arr(i + 1, 1)
    
24.         Next
    
25.     Next
    
26.     [d2:f10000] = ""
    
27.     [d2].Resize(k, 3) = brr
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "OK！"
    
30. End Sub

复制代码

ykcbf1100

附件供参考。。。