I have a string compressed into one cell. I need to separate each part of the string into their own cell, while copying the data from the same row.
Here is my example data:
A | B Row1 ABC ABD ABE ABF | CODE1 Row2 BCA DBA EBA FBA | CODE2 Row3 TEA BEF | CODE3
The result would be:
A B ABC CODE1 ABD CODE1 ABE CODE1 ABF CODE1 BCA CODE2 DBA CODE2 EBA CODE2 FBA CODE2 TEA CODE3 BEF CODE3
I have about 2000 rows and would literally take 30 years to use the text to column function for this. So I am trying to write a vba macro. I think I am making this harder than it needs to be. Any thoughts or pushes in the right direction would be appreciated. Thanks in advance for any help.Answer1:
This will work, (but it's mighty inefficient unless you do it in an array... nevertheless for only 2000 rows, you won't even notice the lag)
Function SplitThis(Str as String, Delimiter as String, SerialNumber as Long) As String SplitThis = Split(Str, Delimiter)(SerialNumber - 1) End Function
Use it as
= SPLITTHIS("ABC EFG HIJ", " ", 2) ' The result will be ... "EFG"
You will still need to put in a whole lot of extra error checking, etc. if you need to use it for a distributed application, as the users might put in values greater than the number of 'split elements' or get delimiters wrong, etc.Answer2:
I like iterating over cells for problems like this post.
' 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 SubAnswer3:
Assuming your data is on the first sheet, this populates the second sheet with the formatted data. I also assume that the data is uniform, meaning there is the same type of data on every row until the data ends. I did not attempt the header line.
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 SubAnswer4:
Let me try as well using <em>Dictionary</em> :)
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
Above code loads all items in <em>Dictionary</em> and then return it in the same Range. HTH.Answer5:
Here is an approach using a User Defined Type, Collection and arrays. I've been using this lately and thought it might apply. It does make writing the code easier, once you get used to it.
The user defined type is set in a class module. I called the type "CodeData" and gave it two properties -- Code and Data
I assumed your data was in columns A & B starting with row 1; and I put the results on the same worksheet but in columns D & E. This can be easily changed, and put on a different worksheet if that's preferable.
First, enter the following code into a Class Module which you have renamed "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
Then put the following code into a Regular module:
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 SubAnswer6:
Here is the solution I devised with help from above. Thanks for the responses!
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