VBA 提取不同数据到不同的单元格

xiashuming1

    提取不同的数据对应到不同的单无格，好像要用到2重的FOR 循环，自己只会做一点点，请您指教，数据见EXCEL附件，谢谢！

petergaod

Sub tq()
    Dim i As Long
    Dim j As Byte
    Dim k As String
    i = 2
    Do While Cells(i, 2) <> "" '执行直到是空字符为止
        k = Replace(Cells(i, 2), " ", "")
        For j = 1 To 5
            Cells(i, 5 + j) = Mid(k, j, 1)
        Next
        i = i + 1
    Loop
End Sub

凌空一羽

VBA 求助.zip (30.51 KB, 下载次数: 6)

2019-12-18 11:07 上传

点击文件名下载附件

petergaod

Sub tq2()
    Dim i As Long
    Dim j As Byte
    Dim k As String
    i = 2
    Do While Cells(i, 2) <> "" '执行直到是空字符为止
        k = Cells(i, 2)
        For j = 1 To 5
            Cells(i, 5 + j) = Mid(k, j * 2 - 1, 1)
        Next
        i = i + 1
    Loop
End Sub

xiashuming1

太棒了，非常感谢您！

kuangben8

1. =MID($B2,COLUMN(A1)*2-1,1)

复制代码

右拉下拉

kuangben8

1. Sub tq()
   
2.     Dim i As Long
   
3.     Dim k As Long
   
4.     Dim arr, brr()
   
5.     arr = Range("B2", [B2].End(xlDown))
   
6.     ReDim brr(1 To UBound(arr, 1), 1 To 5)
   
7.     For i = 1 To UBound(arr, 1)
   
8.         For k = 1 To 5
   
9.             brr(i, k) = Mid(arr(i, 1), 2 * k - 1, 1)
   
10.         Next
    
11.     Next
    
12.     Range("F2").Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    
13. End Sub

复制代码

罗达

Sub cfsj()
Dim r&, x&, y&
Dim arr, brr, crr()
With Worksheets("Excelhome")
    r = .Range("b65536").End(xlUp).Row
    arr = .Range("b2:b" & r)
    For x = 1 To r - 1
        brr = Split(arr(x, 1), " ")
        k = k + 1
        ReDim Preserve crr(1 To 5, 1 To k)
            j = j + 1
            crr(1, j) = brr(0)
            crr(2, j) = brr(1)
            crr(3, j) = brr(2)
            crr(4, j) = brr(3)
            crr(5, j) = brr(4)
        Erase brr
    Next
    .Range("d2").Resize(k, 5) = Application.Transpose(crr)
End With
End Sub

xiashuming1

罗达 发表于 2019-12-18 13:24
Sub cfsj()
Dim r&, x&, y&
Dim arr, brr, crr()

谢谢，辛苦了