从表一中提取冒号后的内容，填入表二中的相应单元格

pingpinggao

求助各位大神，需要从表一中提取冒号后的内容，填入表二的对应单元格中，不知道是否能VBA实现自动写入，因为表一的数据会非常多，附件中只是一小部分数据，谢谢！！！

liulang0808

Sub 按钮1_Click()
    arr = Sheets(1).UsedRange
    With Sheets(2)
        r = .Cells(Rows.Count, 1).End(3).Row
        For j = 1 To UBound(arr) Step 10
            If Len(arr(j, 2)) > 0 Then
                r = r + 1
                .Cells(r, 1) = arr(j, 2)
                .Cells(r, 2) = Split(arr(j, 3), "：")(1)
                .Cells(r, 3) = Split(arr(j, 4), "：")(1)
                For i = 1 To 9
                    .Cells(r, 3 + i) = Split(arr(j + i, 4) & arr(j + i, 5), "：")(1)
                Next i
            End If
        Next j
    End With
End Sub

liulang0808

供参考。。。。。。

hongshan2019

split

pingpinggao

liulang0808 发表于 2021-3-8 13:37
供参考。。。。。。

哇噢，好厉害，我试试能不能应用到我到大表谢谢！！！

xiangbaoan

'上帖附件答案，等我做起，但要255的权限查看

Option Explicit

Sub 太耗电了() '改一处为 立本的商务核心
  Dim ar, i As Long, j As Long, k As Long, Ran As Range, Cel As Range, r As Long, s As String
  ar = Sheet2.Range("A1").CurrentRegion.Resize(10, 49)
  ReDim br(1 To 8000, 1 To UBound(ar, 2))
  For j = 2 To UBound(ar, 2)
    For i = 2 To UBound(ar)
      If Len(ar(i, j)) = 0 Then ar(i, j) = ar(i - 1, j)
    Next
  Next
  For j = 2 To UBound(ar, 2)
    ar(10, j) = Replace(ar(10, j), "~", "~~")
  Next
  With Sheet1
    For i = 1 To .Range("B1000").End(xlUp).Row
      s = .Cells(i, 2).Value
      If Len(s) Then
        k = k + 1
        br(k, 1) = s
        r = .Cells(i, 2).MergeArea.Rows.Count
        Set Ran = .Rows(i).Resize(r)
        For j = 2 To UBound(ar, 2)
          Set Cel = Ran.Find(ar(10, j) & "*", , , , 2, 1 - (ar(10, j) = "地点"))
          If Not Cel Is Nothing Then
            If ar(10, j) = "客户跟进情况状态/情况" Then
              br(k, j) = Cel.Offset(, 1).Value '此处与模拟不完全同，自己看
            Else
              s = Replace(Cel.Value, ar(10, j), "")
              If InStr(s, "：") Then br(k, j) = Split(s, "：")(1) Else br(k, j) = s
            End If
          End If
          Set Cel = Nothing
        Next
        Set Ran = Nothing
      End If
    Next
  End With
  Sheet2.Range("a16").Resize(k, UBound(br, 2)) = br
End Sub

xiangbaoan

上帖附件要255的权限太不厚道了.rar (29.37 KB, 下载次数: 18)

2021-3-8 14:25 上传

点击文件名下载附件

做了就发一下

pingpinggao

xiangbaoan 发表于 2021-3-8 14:25
做了就发一下

大神，因为那个贴说的不清楚，我本来想删除的，但是删不掉，感谢，厉害啦！！！

xiangbaoan

pingpinggao 发表于 2021-3-8 14:36
大神，因为那个贴说的不清楚，我本来想删除的，但是删不掉，感谢，厉害啦！！！

若我答的靠谱，那就说明你说清楚了……

笨鸟飞不高

Sub AwTest()
    Dim i&, r&, j%, c%, n%, xm$, arr
    arr = Sheet1.[a1].CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To 20)
    For i = 1 To UBound(arr)
        If Len(arr(i, 2)) Then xm = arr(i, 2): r = r + 1: c = 1: brr(r, c) = xm
        For j = 3 To UBound(arr, 2)
            If InStr(arr(i, j), "：") Then
                c = c + 1: n = IIf(n > c, n, c)
                brr(r, c) = Split(arr(i, j), "：")(1)
            End If
        Next
    Next
    Sheet2.Activate
    [2:5000].ClearContents
    [a2].Resize(r, c) = brr
End Sub