Your code does excactly what you are demanding?
What seems to be the problem?
Kr
Eric
Sub splitme()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = ActiveSheet
Dim r As Range
Dim V As Variant
Dim a() As String
Dim i As Integer
Dim row As Long
Dim endRow As Long
Set r = Intersect(ws.UsedRange, ws.Range("W:W"))
row = r.row
endRow = r.row - 1 + r.Rows.Count
While row <= endRow
Set r = ws.Range("W" & row)
a = Split(r.Value, ";")
If UBound(a) > 2 Then
r.Value = a(0) & ";" & a(1)
For i = 2 To UBound(a) Step 2
V = r.EntireRow
r.EntireRow.Insert
r.EntireRow.Offset(-1) = V
'Set r = r.Offset(1)
If UBound(a) >= i + 1 Then
r.Value = a(i) & ";" & a(i + 1)
Else
r.Value = a(i)
End If
Next i
End If
row = r.row + 1
Wend
Application.ScreenUpdating = True
End Sub
Sub kTest()
Dim x, k(), ka, i As Long, n As Long, j As Long, c As Long
Const TotalCols As Long = 60
Const SplitCol As Long = 23 'W
ka = ActiveSheet.UsedRange.Resize(, TotalCols)
ReDim k(1 To UBound(ka, 1) * 15, 1 To TotalCols)
For i = 1 To UBound(ka, 1)
x = Split(ka(i, SplitCol), ";")
For j = 0 To UBound(x) Step 2
n = n + 1
For c = 1 To UBound(ka, 2)
If UBound(x) >= j + 1 Then
If c = SplitCol Then
k(n, c) = x(j) & ";" & x(j + 1)
Else
k(n, c) = ka(i, c)
End If
Else
If c <> SplitCol Then
k(n, c) = ka(i, c)
Else
k(n, c) = x(j)
End If
End If
Next
Next
Next
Range("a1").Resize(n, TotalCols).Value = k
End Sub
Title | # Comments | Views | Activity |
---|---|---|---|
Excel 2016 VBA - userform and z-Order of controls | 11 | 33 | |
AutoFilter Delete not keeping Headers? | 2 | 12 | |
Excel- VBA help on macros that size columns and rows | 7 | 21 | |
Copying and pasting pictures from Excel | 2 | 17 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
11 Experts available now in Live!