VBA – 将string拆分成单独的单元格

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

这是我的示例数据：

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

结果将是：

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

我有大约2000行，并将从字面上需要30年使用文本列function为此。 所以我想写一个vbamacros。 我觉得我做得比想要的要难。 任何想法或推动正确的方向将不胜感激。 在此先感谢您的帮助。

Answer 1

这将起作用，（但是，除非你在一个数组中进行操作，否则它是无效的……但是只有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" 

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

Answer 2

我喜欢迭代单元格来解决这个问题。

  ' 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 3

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

 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 4

让我试试使用字典 🙂

 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 

以上代码加载Dictionary中的所有项目，然后在相同的范围内返回。 HTH。

Answer 5

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

用户定义的types被设置在一个类模块中。 我调用了“CodeData”types，并给了它两个属性 – 代码和数据

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

首先，将以下代码input到已更名为“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 

Answer 6

这是我在上面的帮助下devise的解决scheme。 感谢您的回应！

 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