VBA (Macro) to Parse multiple Adjacent Text Columns

Taisir

New member
Joined
May 9, 2014
Messages
12
Reaction score
0
Points
0
Dear All,
I have a number of adjacent columns most of the columns contain a list of names and separated by a Semicolon “;”, some cells contains a single name without Semicolon.

I like to know if there is a VBA (Macro) that parse each column based on the Semicolon delimiter for ALL the columns at once. (if possible paste the results in a new sheet OR in the same sheet)

I have attached a sample of the Original Data set in sheet 1 and the Desired Outcome in sheet 2. In Sheet 1, I like to parse Column “C” through Column “G”

The real data set contains dozens of columns and thousands of rows.
Help is greatly appreciated.

Taisir
 

Attachments

  • Parse Adjacent Columns - Text to columns Forum1.xlsx
    14.9 KB · Views: 40

p45cal

Super Moderator
Staff member
Joined
Dec 16, 2012
Messages
2,169
Reaction score
11
Points
38
Excel Version(s)
365
the following macro seems to work on your file.
It works on the active sheet, so make sure that's the right one before you run it.
It puts the results on a new sheet:
Code:
Sub blah()
Dim DestnSht As Worksheet
Set SourceSht = ActiveSheet
Set DestnSht = Sheets.Add(After:=Sheets(Sheets.Count))
Set SourceRng = SourceSht.Range("A1").CurrentRegion
RowCount = SourceRng.Rows.Count
With DestnSht
  .Cells(1, 1).Resize(RowCount).Value = SourceRng.Columns(1).Value
  DestnColumn = 2
  For c = 3 To SourceRng.Columns.Count
    If UCase(Left(SourceRng.Columns(c).Cells(1), 4)) = "TEAM" Then
      Set DestRng = .Cells(1, DestnColumn).Resize(RowCount)
      DestRng.Value = SourceRng.Columns(c).Value
      DestRng.TextToColumns Destination:=DestRng, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Semicolon:=True
      DestnColumn = .UsedRange.Columns.Count + 1
    End If
  Next c
  .UsedRange.EntireColumn.AutoFit
  'optional for next loop to add person count in cell comment if missing or different:
  For Each rw In .UsedRange.Offset(1, 1).Resize(.UsedRange.Rows.Count - 1, .UsedRange.Columns.Count - 1).Rows
    If rw.Cells(1).Offset(, -1).Value <> Application.CountA(rw) Then rw.Cells(1).Offset(, -1).AddComment CStr(Application.CountA(rw))
  Next rw
End With
End Sub
 

Taisir

New member
Joined
May 9, 2014
Messages
12
Reaction score
0
Points
0
Dear P45cal
Many thanks for your great help. It worked fine and I am about to test it on a large datasets.
All the best Taisir
 
Top