split in same columns

[adam]

in the attached workbook column A and B data gets split in column E and F. How could I make them split in column A and B itself.

any help would be kindly appreciated.

[HansV]

Code: Select all

Sub SplitData3()
    Dim m As Long
    Dim v() As Variant
    Dim w() As Variant
    Dim a() As String
    Dim b() As String
    Dim i As Long
    Dim n As Long
    Dim k As Long
    Dim j As Long
    Dim p As Long
    m = Range("A" & Rows.Count).End(xlUp).Row
    v = Range("A2:B" & m).Value
    k = 1
    For i = 1 To UBound(v, 1)
        a = Split(v(i, 1), ",")
        b = Split(v(i, 2), ",")
        p = Application.Max(UBound(a), UBound(v)) + 1
        n = n + p
        ReDim Preserve w(1 To 2, 1 To n)
        For j = 0 To UBound(a)
            w(1, k + j) = a(j)
        Next j
        For j = 0 To UBound(b)
            w(2, k + j) = b(j)
        Next j
        k = k + p
    Next i
    Application.ScreenUpdating = False
    Range("A2").Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w)
End Sub

[DocAElstein]

The pretty way…._

Code: Select all

Sub StantiallyBeautifulb() '  http://www.eileenslounge.com/viewtopic.php?f=27&t=38331
 Range("A2").Resize((UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2, 2).Value = Application.Index(Split(Range("A2").Value & "," & Range("B2").Value, ","), 1, Evaluate("=Row(1:" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")+((Column(A:B)-1)*" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")"))
End Sub

_.... more for amusement and aesthetic value then anything else. I probably would not want to use something like this as it is difficult to debug or easilly modify/ remember what's going on later. Only sometimes it might be quicker than a more conventional looping solution, but not always



Alan

( P.S. I did notice something interesting in answering this, or rather I twigged to something obvious that I had often overlooked when providing these sort of solutions before…..
... so, I am using the typical
arrOut()= App.Index(arrIn(), Rws(), Clms())
thing....
What I twigged to, and should have realised a long time ago, is that it’s a good idea if you can arrange arrIn() to be a single “width” array ( 1 Dimension array or a two dimensional 1 “row” array, or a two dimensional 1 “column” array ), because the rest of the line reduces by almost a half. Less beautiful then perhaps, but possibly a bit more efficient
( Full story here: https://excelfox.com/forum/showthread.p ... #post16639 ) )

[adam]

Thanks a lot. The codes worked perfect.

[adam]

I've modified Hans code to split data in 4 columns.

Code: Select all

Sub Split4()
    Dim m As Long
    Dim v() As Variant
    Dim w() As Variant
    Dim a() As String
    Dim b() As String
    Dim c() As String
    Dim d() As String
    Dim i As Long
    Dim n As Long
    Dim k As Long
    Dim j As Long
    Dim p As Long
    
    Dim ws As Worksheet
    Set ws = Worksheets("data")
    
    m = ws.Range("A" & Rows.Count).End(xlUp).Row
    v = ws.Range("A2:D" & m).Value
    k = 1
    For i = 1 To UBound(v, 1)
        a = Split(v(i, 1), ",")
        b = Split(v(i, 2), ",")
        c = Split(v(i, 3), ",")
        d = Split(v(i, 4), ",")
        p = Application.Max(UBound(a), UBound(v)) + 1
        n = n + p
        ReDim Preserve w(1 To 4, 1 To n)
        For j = 0 To UBound(a)
            w(1, k + j) = a(j)
        Next j
        For j = 0 To UBound(b)
            w(2, k + j) = b(j)
        Next j
        For j = 0 To UBound(c)
            w(3, k + j) = b(j)
        Next j
        For j = 0 To UBound(d)
            w(4, k + j) = b(j)
        Next j
        k = k + p
    Next i
    Application.ScreenUpdating = False
    ws.Range("A2").Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w)
End Sub

I'm not able to change the last line of the code and so I'm not able to split columns C and D. the split data from column B gets copied to column C and D.

How could I correct this?

[adam]

I guess the mistake was in the following lines

Code: Select all

For j = 0 To UBound(a)
            w(1, k + j) = a(j)
        Next j
        For j = 0 To UBound(b)
            w(2, k + j) = b(j)
        Next j
        For j = 0 To UBound(c)
            w(3, k + j) = b(j)
        Next j
        For j = 0 To UBound(d)
            w(4, k + j) = b(j)

When I changed as follows

Code: Select all

For j = 0 To UBound(a)
            w(1, k + j) = a(j)
        Next j
        For j = 0 To UBound(b)
            w(2, k + j) = b(j)
        Next j
        For j = 0 To UBound(c)
            w(3, k + j) = c(j)
        Next j
        For j = 0 To UBound(d)
            w(4, k + j) = d(j)

It works

[DocAElstein]

Hi,
Just for completeness, future reference, and the sheer aesthetic beauty of it…._
_.... my single line solution can be made dynamic, so that it will work on as many cells as have values in them, so it will work with the original requirement of two cells , or the new requirement of 4 cells , or how ever many cells you have.

It was not as difficult as it looks: We just need to make two basic modification to the previous one line solution for 2 cells:
_(i) The entire data present is taken in and converted to a single 1 Dimensional array.
_(ii) In the previous one line solution for 2 cells, we mainly just replace the hard coded value of 2 with the dynamically obtained used cell number, ( which is just the used columns count )

My first attempt does not quite fit on one line, although it is a single code line: it does not quite fit in a single line in the VB Editor, so the line is split once. It was a close thing, so I expect if I fiddled around a bit I could get it all on one line, ( I have a feeling something redundant may have slipped into this first attempt... ) ( One immediate possibilty to shorten slightly the line that I can think of is to replace Columns.Count with some number that is just big enougth to take you outside the number of cells you are likely ever to use)

Code: Select all

 Sub PrettyDammBeautiful() '  https://eileenslounge.com/viewtopic.php?p=296482#p296482
 Range("A2").Resize((UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column, Cells(2, Columns.Count).End(xlToLeft).Column).Value = _
 Application.Index(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")+((Column(A:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & ")-1)*" & (UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")"))

End Sub

Here is the full story:
https://excelfox.com/forum/showthread.p ... #post16643
https://excelfox.com/forum/showthread.p ... #post16644


_.________________________________________________________________________

Possibly a good compromise with these things is to do a half way house, where you have the important constituent bits broken down and shown. That way you have half a chance to debug it if something goes wrong

Code: Select all

 Sub SplitDataHalfWayHouse() '  https://eileenslounge.com/viewtopic.php?p=296617#p296617
Rem 1 worksheets data info
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1")
Dim Lc As Long: Let Lc = Ws1.Cells(2, Ws1.Columns.Count).End(xlToLeft).Column: Lc = Cells(2, Columns.Count).End(xlToLeft).Column
Dim LCL As String: Let LCL = Split(Cells(1, Lc).Address, "$")(1) ' what we are doing is splitting like  $D$1  by the  $  and then taking the second element,  in the example that will be  D
Rem 2 create a 1 Dimensional array of all data
Dim arrIn() As String
 Let arrIn() = Split(Join(Application.Index(Ws1.Range("A2:" & LCL & "2").Value2, 1, 0), ","), ",")
Rem 3 get the array of indicies for the  arrOut()= App.Index(arrIn(), Rws(), Clms())  type code line
Dim Clms() As Variant
  Let Clms() = Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / Lc & ")+((Column(A:" & LCL & ")-1)*" & (UBound(arrIn()) + 1) / Lc & ")")
Rem 4 Output array
Dim arrOut() As Variant
 Let arrOut() = Application.Index(arrIn(), 1, Clms())
Rem 5 Paste out
 Let Ws1.Range("A2").Resize((UBound(arrIn()) + 1) / Lc, Lc).Value = arrOut()
End Sub

Alan

[adam]

Thankyou so much DocAElstein. This was really helpful indeed.