一行中有多行文本，拆成实际多行，单行文本补齐，

jd23qq

1一行中有多行文本，拆成实际多行，单行文本补齐2如果B=C和D=E，则在Y列标识直达，否为中转

苏小亓

加QQ群我告诉你简单的方法。

一把小刀闯天下

'设置一下输出表格格式

Option Explicit

Sub test()
  Dim arr, i, j, k, m, t
  arr = [a2:u2]
  ReDim brr(1 To UBound(arr, 1) * 18, 1 To UBound(arr, 2))
  For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
      If InStr(arr(i, j), Chr(10)) Then
        t = Split(arr(i, j), Chr(10))
        For k = 0 To UBound(t)
          brr(m + k + 1, j) = t(k)
        Next
      Else
        For k = 1 To 18
          brr(m + k, j) = arr(i, j)
        Next
      End If
    Next
    m = m + 18
  Next
  [a25].Resize(m, UBound(brr, 2)) = brr
End Sub

jd23qq

一把小刀闯天下 发表于 2018-7-6 10:47
'设置一下输出表格格式

Option Explicit

'设置一下输出表格格式

Option Explicit

Sub test()
  Dim arr, i, j, k, m, t
   arr = Sheets("sheet1").Range("a2").CurrentRegion
  ReDim brr(1 To UBound(arr, 1) * 50, 1 To UBound(arr, 2))
  For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
      If InStr(arr(i, j), Chr(10)) Then
        t = Split(arr(i, j), Chr(10))
        For k = 0 To UBound(t)
          brr(m + k + 1, j) = t(k)
        Next
      Else
        For k = 1 To 50
          brr(m + k, j) = arr(i, j)
        Next
      End If
    Next
    m = m + 50
  Next
Sheets("sheet2").Range("a1").Resize(m, UBound(brr, 2)) = brr
End Sub

行数是不固定的，我这里更改为50行，并生成的表2，但是出现很多多余的行

jd23qq

一把小刀闯天下 发表于 2018-7-6 10:47
'设置一下输出表格格式

Option Explicit

'设置一下输出表格格式

Option Explicit

Sub test()
  Dim arr, i, j, k, m, t
   arr = Sheets("sheet1").Range("a2").CurrentRegion
  ReDim brr(1 To UBound(arr, 1) * 50, 1 To UBound(arr, 2))
  For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
      If InStr(arr(i, j), Chr(10)) Then
        t = Split(arr(i, j), Chr(10))
        For k = 0 To UBound(t)
          brr(m + k + 1, j) = t(k)
        Next
      Else
        For k = 1 To 50
          brr(m + k, j) = arr(i, j)
        Next
      End If
    Next
    m = m + 50
  Next
Sheets("sheet2").Range("a1").Resize(m, UBound(brr, 2)) = brr
End Sub

行数是不固定的，我这里更改为50行，并生成的表2，但是出现很多多余的行

一把小刀闯天下

jd23qq 发表于 2018-7-6 11:26
'设置一下输出表格格式

Option Explicit

'如果有4万行最终输出要有1440万个单元格，输出数组我不能确定是否会溢出

Option Explicit

Sub test()
  Dim arr, i As Long, j As Long, k As Long, m As Long, t
  With Sheets("sheet1")
    arr = .Range("a2:t" & .Cells(Rows.Count, "b").End(xlUp).Row)
  End With
  ReDim brr(1 To UBound(arr, 1) * 18, 1 To UBound(arr, 2))
  For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
      If InStr(arr(i, j), Chr(10)) Then
        t = Split(arr(i, j), Chr(10))
        For k = 0 To UBound(t): brr(m + k + 1, j) = t(k): Next
      Else
        For k = 1 To 18: brr(m + k, j) = arr(i, j): Next
      End If
    Next
    m = m + 18
  Next
  With Sheets("sheet2").[a2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    .Resize(m, UBound(brr, 2)) = brr
  End With
End Sub

jd23qq

一把小刀闯天下 发表于 2018-7-6 19:41
'如果有4万行最终输出要有1440万个单元格，输出数组我不能确定是否会溢出

Option Explicit

谢谢，拆分200行不是问题