求助数据分列

世界客都

世界客都 发表于 2024-1-24 19:00
谢谢老师。

谢谢老师，鲜花改日送上。

世界客都

ykcbf1100 发表于 2024-1-24 19:26
附件供参考。。。

谢谢老师，鲜花改日送上。

cjc209

Sub test()
    Dim zrr(1 To 1000)
    r = Cells(Rows.Count, 2).End(3).Row
    arr = Range("b2:b" & r)
    ReDim brr(1 To UBound(arr), 1 To 3)
    For i = 1 To UBound(arr)
        If InStr(UCase(arr(i, 1)), ".JPG") Then
            st = arr(i, 1)
            For j = i + 1 To i + 100 Step 2
                If j > UBound(arr) Then
                    Exit For
                End If
                If InStr(UCase(arr(j, 1)), ".JPG") Then
                    i = j - 1
                    Exit For
                End If
                k = k + 1
                brr(k, 1) = st
                brr(k, 2) = arr(j, 1)
                brr(k, 3) = arr(j + 1, 1)
            Next
        End If
    Next
    [d2:f10000] = ""
    [d2].Resize(k, 3) = brr
    MsgBox "OK！"
End Sub