关于对单元格内容的分裂，提取，求教

itmwdtn

某单元格有多行内容，我需要将其分裂开来，详见附件

一把小刀闯天下

'自己设置一下日期列等格式

Option Explicit

Sub test()
  Dim arr, i, j, k, m, t
  arr = [a1].CurrentRegion
  ReDim brr(1 To UBound(arr, 1) * 10, 1 To UBound(arr, 2))
  For i = 2 To UBound(arr, 1)
    If InStr(arr(i, 5), vbLf) Then
      t = Split(arr(i, 5), vbLf)
      For j = 0 To UBound(t)
        m = m + 1
        For k = 1 To UBound(arr, 2) - 1: brr(m, k) = arr(i, k): Next
        brr(m, k) = t(j)
      Next
    Else
      m = m + 1
      For j = 1 To UBound(arr, 2): brr(m, j) = arr(i, j): Next
    End If
  Next
  [g2].Resize(m, UBound(brr, 2)) = brr
End Sub

itmwdtn

一把小刀闯天下 发表于 2018-10-6 22:45
'自己设置一下日期列等格式

Option Explicit

感谢，完美的解决

itmwdtn

一把小刀闯天下 发表于 2018-10-6 22:45
'自己设置一下日期列等格式

Option Explicit

兄台我又想到，它的逆过程，代码有吗？也就是将分裂好的数据，再重新做到1个单元格里面

一把小刀闯天下

'1楼附件。假设前4列是有序的，如果无序手工排下序或者采用字典来重写

Option Explicit

Sub test()
  Dim arr, i, j, k, m, p
  arr = Range("f6:j" & Cells(Rows.Count, "f").End(xlUp).Row + 1)
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      For k = 1 To UBound(arr, 2) - 1
        If arr(j, k) <> arr(j + 1, k) Then Exit For
      Next
      If k < UBound(arr, 2) Then
        m = m + 1: p = UBound(arr, 2)
        For k = 1 To UBound(arr, 2): arr(m, k) = arr(i, k): Next
        For k = i + 1 To j: arr(m, p) = arr(m, p) & vbNewLine & arr(k, p): Next
        i = j: Exit For
      End If
  Next j, i
  With [a1]
    .Resize(Rows.Count, UBound(arr, 2)).ClearContents
    .Resize(m, UBound(arr, 2)) = arr
  End With
End Sub