VBA Macro that splits data based of cell value ; and warp text-CodePudding

I am building a macro that splits data of based on cell value into multiple rows along with corresponding column data. Example : - cell b2 has value "G2HSB; G4ZQP" this is these are split like below in multiple row along with corresponding column values. G2HSB G4ZQP

The above is my macro output. Macro splits data based on ; within cell value.

Now I have some values were ; is not present and out put is like this which is like this

In original excel file the data is like this

They are wrap text true by default I want the macro to split these data also in multiple rows with corresponding column data how to split such cell

my original codes

Sub MsoSplit()

Dim r As Range, i As Long, ar
Set r = Worksheets("Exclusion Data").Range("B2").End(xlDown)
Do While r.Row > 1
        ar = Split(r.Value, ";")
        If UBound(ar) >= 0 Then r.Value = ar(0)
        For i = UBound(ar) To 1 Step -1
            r.EntireRow.Copy
            r.Offset(1).EntireRow.Insert
            r.Offset(1).Value = ar(i)
        Next
        Set r = r.Offset(-1)
    Loop
    
Dim cell As Range
For Each cell In ActiveWorkbook.Worksheets("Exclusion Data").UsedRange.SpecialCells(xlCellTypeConstants)
cell = WorksheetFunction.Trim(cell)
Next cell

Dim cell1 As Range
For Each cell1 In ActiveWorkbook.Worksheets("Exclusion Data").UsedRange.SpecialCells(xlCellTypeConstants)
cell1 = WorksheetFunction.Clean(cell1)
Next cell1

Worksheets("Exclusion Data").UsedRange.WrapText = False
 
End Sub

CodePudding user response：

Replace the ; with a space, use Application.Trim to removes all spaces from text except for single spaces between words, and then split on the spaces that remain.

    Dim s As String
    With Worksheets("Exclusion Data")
        Set r = .Range("B" & .Rows.Count).End(xlUp)
        Do While r.Row > 1
            s = Application.Trim(Replace(r.Value, ";", " "))
            ar = Split(s, " ")
            If UBound(ar) >= 0 Then r.Value = ar(0)
            For i = UBound(ar) To 1 Step -1
                r.EntireRow.Copy
                r.Offset(1).EntireRow.Insert
                r.Offset(1).Value = ar(i)
            Next
            Set r = r.Offset(-1)
        Loop
        .UsedRange.WrapText = False
    End With

CodePudding user response：

Please, use the next code. It returns in another sheet the processed result. In the actual code, in the next sheet, but you can set whichever sheet you want. The code uses arrays and should be very fast for a big range to be processed:

Sub splitCellValueByRows()
   Dim sh As Worksheet, shDest As Worksheet, lastR As Long, lastCol As Long, sep As String
   Dim arr, arrExist, arrFin, i As Long, nrRows As Long, j As Long, k As Long, e As Long
   
   Set sh = Worksheets("Exclusion Data")
   Set shDest = sh.Next  'Use here the sheet where to return.
                         'If keep this code, next sheet must exist and it should be empty
   lastR = sh.Range("A" & sh.rows.Count).End(xlUp).row
   lastCol = sh.cells(1, sh.Columns.Count).End(xlToLeft).Column
   
   arrExist = sh.Range("A1", sh.cells(lastR, lastCol)).Value
   sep = " ;"  'used separator for Split
               'if it is not consistent (as it can be seen), it can  be
               'solved, if you confirm that no spaces involved in the separated strings
   'calculate final number of rows, in the processed array:
   For i = 2 To UBound(arrExist)
        nrRows = nrRows   UBound(Split(arrExist(i, 2), sep))   1
   Next i
   ReDim arrFin(1 To nrRows   1, 1 To UBound(arrExist, 2)): k = 1
   
   'place the header in the final array:
   For i = 1 To UBound(arrExist, 2)
        arrFin(k, i) = arrExist(1, i)
   Next i

   k = k   1 'initialize the variable of final array rows
   For i = 2 To UBound(arrExist)
        arr = Split(arrExist(i, 2), sep)
         
        For j = 0 To UBound(arr)
            arrFin(k, 1) = arrExist(i, 1): arrFin(k, 2) = arr(j)
            For e = 3 To lastCol
                arrFin(k, e) = arrExist(i, e)
            Next
            k = k   1
        Next j
   Next i

   shDest.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
End Sub

If you like its return, you can replace the existing content with the array result. Just replace shDest with sh in the last code line.