• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro to cut data where multiple values exist and add a row for that extra data

fitz68

New Member
I have a worksheet of data that looks something like this:

A B C D

Sean11 11 141 BEC

Mike22 12 323 DEC

Kate54 13 412 BRD

Kyle99 14,15 844,767 DAE,BCV


I would like a MACRO that takes any line that has multiple values (i.e. Kyle99 has both 14 and 15 in col B) and inserts a new row below it and cuts and pastes the extra value, while keeping the Kyle99 in row A. Essentially creating a new row and ensuring every row only has one value for col B, C and D.


Any help would be much appreciated!
 
Hi, fitz68!


Put this code in a module or in the related worksheet VBA pane.


-----

[pre]
Code:
Option Explicit

Sub X()
' constants
Const ksComma = ","
' declarations
Dim I As Integer, J As Integer, K As Integer
Dim A As String, B As String, C As String
' start
' process
With ActiveSheet
I = 2
Do Until .Cells(I, 1).Value = ""
K = 0
For J = 2 To 4
K = InStr(.Cells(I, J).Value, ksComma)
If K > 0 Then Exit For
Next J
If K > 0 Then
' duplicate
.Rows(I).EntireRow.Copy
.Rows(I + 1).Insert Shift:=xlDown
' split values
For J = 2 To 4
A = .Cells(I, J).Value
K = InStr(A, ksComma)
If K = 0 Then
B = A
C = A
Else
B = Left$(A, K - 1)
C = Right$(A, Len(A) - K)
End If
.Cells(I, J).Value = B
.Cells(I + 1, J).Value = C
Next J
I = I + 1
End If
I = I + 1
Loop
End With
Application.CutCopyMode = False
' end
Range("A2").Select
End Sub
[/pre]
-----


Then press Alt-F8 and run the macro X.


Regards!
 
Hi, fitz68!

Glad you solved it. Thanks for your feedback and for your kind words too. Welcome back whenever needed or wanted.

Regards!
 
Back
Top