VBA - 将单个字符串拆分为单个单元格

Question

我将一个字符串压缩到一个单元格中。我需要将字符串的每个部分分隔到自己的单元格中，同时从同一行复制数据。

这里是我的示例数据：

 A    | B     
Row1 ABC ABD ABE ABF | CODE1 
Row2 BCA DBA EBA FBA | CODE2 
Row3 TEA BEF   | CODE3 

其结果将是：

A  B 
ABC CODE1 
ABD CODE1 
ABE CODE1 
ABF CODE1 
BCA CODE2 
DBA CODE2 
EBA CODE2 
FBA CODE2 
TEA CODE3 
BEF CODE3 

我有大约2000行，会从字面上花费30年的使用文本列函数这一点。所以我想写一个vba宏。我认为我做得比想要的要难。任何想法或推动正确的方向将不胜感激。预先感谢您的帮助。

Answer 1

下面是解我在上面的帮助下设计的。感谢您的回应！

Sub Splt() 
    Dim LR As Long, i As Long 
    Dim X As Variant 
    Application.ScreenUpdating = False 
    LR = Range("A" & Rows.Count).End(xlUp).Row 
    Columns("A").Insert 
    For i = LR To 1 Step -1 
     With Range("B" & i) 
      If InStr(.Value, " ") = 0 Then 
       .Offset(, -1).Value = .Value 
      Else 
       X = Split(.Value, " ") 
       .Offset(1).Resize(UBound(X)).EntireRow.Insert 
       .Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value =   Application.Transpose(X) 
      End If 
     End With 
    Next i 
    Columns("B").Delete 
    LR = Range("A" & Rows.Count).End(xlUp).Row 
    With Range("B1:C" & LR) 
     On Error Resume Next 
     .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" 
     On Error GoTo 0 
     .Value = .Value 
    End With 
    Application.ScreenUpdating = True 
    End Sub 

Answer 2

这是可行的，（但除非你在一个数组做它的强大的低效率......但只有2000行，你甚至不会注意到滞后）

Function SplitThis(Str as String, Delimiter as String, SerialNumber as Long) As String 
    SplitThis = Split(Str, Delimiter)(SerialNumber - 1) 
End Function 

使用它作为

= SPLITTHIS("ABC EFG HIJ", " ", 2) 

' The result will be ... 

"EFG" 

如果您需要将其用于分布式应用程序，您仍然需要进行大量额外的错误检查等，因为用户可能会输入大于“拆分元素”的值或得到分隔符错误等。

Answer 3

我喜欢在这个帖子的问题上迭代单元格。

 ' code resides on input sheet 
     Sub ParseData() 
      Dim wksOut As Worksheet 
      Dim iRowOut As Integer 
      Dim iRow As Integer 
      Dim asData() As String 
      Dim i As Integer 
      Dim s As String 

      Set wksOut = Worksheets("Sheet2") 
      iRowOut = 1 

      For iRow = 1 To UsedRange.Rows.Count 
       asData = Split(Trim(Cells(iRow, 1)), " ") 
       For i = 0 To UBound(asData) 
        s = Trim(asData(i)) 
        If Len(s) > 0 Then 
         wksOut.Cells(iRowOut, 1) = Cells(iRow, 2) 
         wksOut.Cells(iRowOut, 2) = s 
         iRowOut = iRowOut + 1 
        End If 
       Next i 
      Next iRow 

      MsgBox "done" 
     End Sub 

Answer 4

假设您的数据位于第一张纸上，则会使用格式化的数据填充第二张纸。我还假定数据是统一的，这意味着在数据结束之前每行都有相同类型的数据。我没有尝试标题行。

Public Sub FixIt() 

    Dim fromSheet, toSheet As Excel.Worksheet 

    Dim fromRow, toRow, k As Integer 

    Dim code As String 

    Set fromSheet = Me.Worksheets(1) 
    Set toSheet = Me.Worksheets(2) 

    ' Ignore first row 
    fromRow = 2 

    toRow = 1 

    Dim outsideArr() As String 
    Dim insideArr() As String 

    Do While Trim(fromSheet.Cells(fromRow, 1)) <> "" 

     ' Split on the pipe 
     outsideArr = Split(fromSheet.Cells(fromRow, 1), "|") 

     ' Split left of pipe, trimmed, on space 
     insideArr = Split(Trim(outsideArr(0)), " ") 

     ' Save the code 
     code = Trim(outsideArr(UBound(outsideArr))) 

     ' Skip first element of inside array 
     For k = 1 To UBound(insideArr) 
      toSheet.Cells(toRow, 1).Value = insideArr(k) 
      toSheet.Cells(toRow, 2).Value = code 
      toRow = toRow + 1 

     Next k 

     fromRow = fromRow + 1 

    Loop 


End Sub 

Answer 5

让我试试，以及使用字典 :)

Sub Test() 
    Dim r As Range, c As Range 
    Dim ws As Worksheet 
    Dim k, lrow As Long, i As Long 

    Set ws = Sheet1 '~~> change to suit, everything else as is 
    Set r = ws.Range("B1", ws.Range("B" & ws.Rows.Count).End(xlUp)) 

    With CreateObject("Scripting.Dictionary") 
     For Each c In r 
      If Not .Exists(c.Value) Then 
       .Add c.Value, Split(Trim(c.Offset(0, -1).Value)) 
      End If 
     Next 
     ws.Range("A:B").ClearContents 
     For Each k In .Keys 
      lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row 
      If lrow = 1 Then i = 0 Else i = 1 
      ws.Range("A" & lrow).Offset(i, 0) _ 
       .Resize(UBound(.Item(k)) + 1).Value = Application.Transpose(.Item(k)) 
      ws.Range("A" & lrow).Offset(i, 1).Resize(UBound(.Item(k)) + 1).Value = k 
     Next 
    End With 
End Sub 

上面的代码加载的所有项目中字典，然后在同一范围内返回。 HTH。

Answer 6

这是一种使用用户定义类型，集合和数组的方法。我最近一直在使用它，并认为它可能适用。一旦你习惯了它，它确实使代码更容易编写。

用户定义类型在类模块中设置。我打电话给“CodeData”类型，并给了它两个属性 - 代码和数据

我假设你的数据在列A & B从第1行开始;我把结果放在同一张工作表上，但是列D & E.这可以很容易地更改，如果更好的话，可以放在不同的工作表上。

首先，输入以下代码到您已更名为“CodeData”

Option Explicit 
Private pData As String 
Private pCode As String 

Property Get Data() As String 
    Data = pData 
End Property 
Property Let Data(Value As String) 
    pData = Value 
End Property 

Property Get Code() As String 
    Code = pCode 
End Property 
Property Let Code(Value As String) 
    pCode = Value 
End Property 

然后把下面的代码放到一个普通模块类模块：

Option Explicit 
Sub ParseCodesAndData() 
    Dim cCodeData As CodeData 
    Dim colCodeData As Collection 
    Dim vSrc As Variant, vRes() As Variant 
    Dim V As Variant 
    Dim rRes As Range 
    Dim I As Long, J As Long 

'Results start here. But could be on another sheet 
Set rRes = Range("D1:E1") 

'Get Source Data 
vSrc = Range("A1", Cells(Rows.Count, "B").End(xlUp)) 

'Collect the data 
Set colCodeData = New Collection 
For I = 1 To UBound(vSrc, 1) 
    V = Split(vSrc(I, 1), " ") 
    For J = 0 To UBound(V) 
     Set cCodeData = New CodeData 
     cCodeData.Code = Trim(vSrc(I, 2)) 
     cCodeData.Data = Trim(V(J)) 
    colCodeData.Add cCodeData 
    Next J 
Next I 

'Write results to array 
ReDim vRes(1 To colCodeData.Count, 1 To 2) 
For I = 1 To UBound(vRes) 
    Set cCodeData = colCodeData(I) 
    vRes(I, 1) = cCodeData.Data 
    vRes(I, 2) = cCodeData.Code 
Next I 

'Write array to worksheet 
Application.ScreenUpdating = False 

rRes.EntireColumn.Clear 
rRes.Resize(rowsize:=UBound(vRes, 1)) = vRes 

Application.ScreenUpdating = True 

End Sub