34045

VBA - Split string into individual cells

Question:

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 Sub

Answer3:

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 Sub

Answer4:

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 Sub

Answer6:

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

Recommend

  • Hang in mergeChangesFromContextDidSaveNotification (and merge conflicts)
  • JqGrid's Row selected by default
  • C# NPOI set cell style to Text / string 1-19 is formatted as a date / disable any formating
  • Copy a range of cells and only select cells with data and just the value not the formulas
  • Exporting data from Excel to Outlook
  • Drush commands not executing using Paramiko
  • Trying to get index of active cell from textField inside custom cell of UITableView in iOS
  • Property file in java
  • Bullet-Proof ACL using AngularJS
  • How can I configure a Tkinter widget from a separate class?
  • Deliberately simplifying fractional exponents
  • How are 32 bit JavaScript numbers resulting from a bit-wise operation converted back to 64 bit numbe
  • JsonMappingException: Can not deserialize instance of java.lang.Integer out of START_OBJECT token
  • VB.Net Double comparison after some additions
  • Upper limits for fibonnacci
  • Smack 4.1.0 android Roster not displaying
  • Responsive Form on top of Responsive Image? - Bootstrap
  • How to open html table in xls on click of a button
  • Need code translation from VB to C#
  • Z3: Convert between FP and BitVector?
  • How can I set a binding to a Combox in a UserControl?
  • Excel's Macro-Recorder usage
  • Does it make sense to call System.gc() and Thread.sleep() when working on Bitmaps?
  • Date Conversion from yyyy-mm-dd to dd-mm-yyyy
  • Java Scanner input dilemma. Automatically inputs without allowing user to type
  • Problems to linebreak with an int in JLabel
  • Counter field in MS Access, how to generate?
  • Excel - Autoshape get it's name from cell (value)
  • vba code to select only visible cells in specific column except heading
  • Convert array of 8 bytes to signed long in C++
  • what is the difference between the asp.net mvc application and asp.net web application
  • Data Validation Drop Down Box Arrow Disappearing
  • Matrix multiplication with MKL
  • How to CLICK on IE download dialog box i.e.(Open, Save, Save As…)
  • Memory offsets in inline assembly
  • Turn off referential integrity in Derby? is it possible?
  • How can I remove ASP.NET Designer.cs files?
  • Binding checkboxes to object values in AngularJs
  • java string with new operator and a literal
  • jQuery Masonry / Isotope and fluid images: Momentary overlap on window resize