VBA clean up conditional duplication of rows

Question

I have a data set in which there is an id field and a number of other fields.

The id field at times has a second id. In this case, I need to create a new duplicated record and put a single id in each of the records. There is an additional condition in which each of the ids may be followed by a number which is a percentage. In all cases, I need to display the correct percentage as a decimal value in a field on the record.

id examples:

AJ01-25/ST01-75
AJ01/LM03
RICH01

Correct representation of ids and percentages:

id      percent
AJ01    .25
ST01    .75
AJ01    .5
LM03    .5
RICH01  1.0

I used the following code to create a new record and parse any percentages into a new field whenever a "/" is detected, but I'd very much like to have something cleaner. Sort order does not matter (my script places new records at the end). Thoughts?

Sub breakemup()
Dim wb As Workbook
Dim ws As Worksheet
Dim id As String
Dim rng As Range
Dim ar() As String

Set wb = ThisWorkbook
Set ws = wb.Worksheets("data")

Dim currentRow As Integer
Dim finalRow As Integer
finalRow = ws.UsedRange.Rows.Count
For currentRow = 2 To finalRow
    ar() = Split(ws.Range("a" & currentRow).Value, "/")
    If UBound(ar) = 1 Then
        ws.Rows(currentRow).Copy Destination:=ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
        If UBound(Split(ar(1), "-")) = 1 Then
            ws.Range("A" & Rows.Count).End(xlUp).Value = Split(ar(1), "-")(0)
            ws.Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = CDbl(Split(ar(1), "-")(1)) / 100#
            ws.Range("A" & currentRow).Value = Split(ar(0), "-")(0)
            ws.Range("A" & currentRow).Offset(0, 1).Value = CDbl(Split(ar(0), "-")(1)) / 100#
        Else
            ws.Range("A" & Rows.Count).End(xlUp).Value = ar(1)
            ws.Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = 50 / 100#
            ws.Range("A" & currentRow).Value = ar(0)
            ws.Range("A" & currentRow).Offset(0, 1).Value = 50 / 100#
        End If
    Else
        ws.Range("A" & currentRow).Offset(0, 1).Value = 1#

    End If
Next

End Sub

VBA clean up conditional duplication of rows

Answers (1)

Related Questions