Macro to split, validate, concatenate and transpose

[arundharmarajan]

Hi,

Another scenario where I am completely stumped and not sure how to solve this.

The scenario is

Column A - has a list of values (one value in one cell)
Column B - Multiple values separated by , or - or even single value
Column C - All possible values that can be present in Column B.

One cell with prefix for column A
One cell with prefix for column B

When I run the macro, the output I require is a table, which is the value in column A and value of column B in each row.

Pretty sure it is confusing, therefore attaching a sample of what I require.

Thank you

 

[nemmi69]

will this do?

Option Explicit
Dim LastRowNoA As Long
Dim LastRowNoC As Long
Dim ColAloop As Long
Dim ColBloop As Long
Dim ColCloop As Long
Dim ColBString As String
Dim ColBValString As String
Dim ColBLoValString As String
Dim ColBHiValString As String
Dim ColBSearchVal As Integer
Dim RowCount As Integer


Sub FindLastColRow()
LastRowNoA = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
LastRowNoC = Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
RowCount = 2


For ColAloop = 2 To LastRowNoA
    ColBString = Worksheets("Sheet1").Range("B" & ColAloop).Value
    Do While Len(ColBString) > 0
        ColBValString = Left(ColBString, InStr(1, ColBString, ","))
        If Len(ColBValString) > 0 Then
            If InStr(1, ColBValString, "-") > 0 Then
                ColBLoValString = Left(ColBValString, Len(ColBValString) - InStr(1, ColBValString, "-") - 1)
                ColBHiValString = Right(ColBValString, Len(ColBValString) - InStr(1, ColBValString, "-"))
                ColBHiValString = Left(ColBHiValString, Len(ColBHiValString) - 1)
                For ColCloop = 2 To LastRowNoC
                    If Worksheets("Sheet1").Range("C" & ColCloop).Value >= ColBLoValString And Worksheets("Sheet1").Range("C" & ColCloop).Value <= ColBHiValString Then
                        Worksheets("Sheet1").Range("G" & RowCount).Value = Worksheets("Sheet1").Range("E2").Value & Worksheets("Sheet1").Range("A" & ColAloop).Value
                        Worksheets("Sheet1").Range("H" & RowCount).Value = Worksheets("Sheet1").Range("E5").Value & Worksheets("Sheet1").Range("C" & ColCloop).Value
                        RowCount = RowCount + 1
                    End If
                Next ColCloop
            Else
                ColBSearchVal = Left(ColBValString, Len(ColBValString) - 1)
                For ColCloop = 2 To LastRowNoC
                    If Worksheets("Sheet1").Range("C" & ColCloop).Value = ColBSearchVal Then
                        Worksheets("Sheet1").Range("G" & RowCount).Value = Worksheets("Sheet1").Range("E2").Value & Worksheets("Sheet1").Range("A" & ColAloop).Value
                        Worksheets("Sheet1").Range("H" & RowCount).Value = Worksheets("Sheet1").Range("E5").Value & ColBSearchVal
                        RowCount = RowCount + 1
                    End If
                Next ColCloop
            End If
                
            ColBString = Right(ColBString, Len(ColBString) - Len(ColBValString))
        Else
                For ColCloop = 2 To LastRowNoC
                    If Worksheets("Sheet1").Range("C" & ColCloop).Value = ColBString Then
                        Worksheets("Sheet1").Range("G" & RowCount).Value = Worksheets("Sheet1").Range("E2").Value & Worksheets("Sheet1").Range("A" & ColAloop).Value
                        Worksheets("Sheet1").Range("H" & RowCount).Value = Worksheets("Sheet1").Range("E5").Value & ColBString
                        RowCount = RowCount + 1
                    End If
                Next ColCloop
            ColBString = ""
        End If
    Loop
Next ColAloop
End Sub

 

[nemmi69]

Actually this is better as allows for something like 7000,8000-9000 ie with the values separated by a "-" on the end.

Option Explicit
Dim LastRowNoA As Long
Dim LastRowNoC As Long
Dim ColAloop As Long
Dim ColBloop As Long
Dim ColCloop As Long
Dim ColBString As String
Dim ColBValString As String
Dim ColBLoValString As String
Dim ColBHiValString As String
Dim ColBSearchVal As Integer
Dim RowCount As Integer


Sub FindLastColRow()
LastRowNoA = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
LastRowNoC = Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
RowCount = 2


For ColAloop = 2 To LastRowNoA
    ColBString = Worksheets("Sheet1").Range("B" & ColAloop).Value
    Do While Len(ColBString) > 0
        ColBValString = Left(ColBString, InStr(1, ColBString, ","))
        If Len(ColBValString) > 0 Then
            If InStr(1, ColBValString, "-") > 0 Then
                ColBLoValString = Left(ColBValString, Len(ColBValString) - InStr(1, ColBValString, "-") - 1)
                ColBHiValString = Right(ColBValString, Len(ColBValString) - InStr(1, ColBValString, "-"))
                ColBHiValString = Left(ColBHiValString, Len(ColBHiValString) - 1)
                For ColCloop = 2 To LastRowNoC
                    If Worksheets("Sheet1").Range("C" & ColCloop).Value >= ColBLoValString And Worksheets("Sheet1").Range("C" & ColCloop).Value <= ColBHiValString Then
                        Worksheets("Sheet1").Range("G" & RowCount).Value = Worksheets("Sheet1").Range("E2").Value & Worksheets("Sheet1").Range("A" & ColAloop).Value
                        Worksheets("Sheet1").Range("H" & RowCount).Value = Worksheets("Sheet1").Range("E5").Value & Worksheets("Sheet1").Range("C" & ColCloop).Value
                        RowCount = RowCount + 1
                    End If
                Next ColCloop
            Else
                ColBSearchVal = Left(ColBValString, Len(ColBValString) - 1)
                For ColCloop = 2 To LastRowNoC
                    If Worksheets("Sheet1").Range("C" & ColCloop).Value = ColBSearchVal Then
                        Worksheets("Sheet1").Range("G" & RowCount).Value = Worksheets("Sheet1").Range("E2").Value & Worksheets("Sheet1").Range("A" & ColAloop).Value
                        Worksheets("Sheet1").Range("H" & RowCount).Value = Worksheets("Sheet1").Range("E5").Value & ColBSearchVal
                        RowCount = RowCount + 1
                    End If
                Next ColCloop
            End If
                
            ColBString = Right(ColBString, Len(ColBString) - Len(ColBValString))
        Else
             If InStr(1, ColBString, "-") > 0 Then
                ColBLoValString = Left(ColBString, InStr(1, ColBString, "-") - 1)
                ColBHiValString = Right(ColBString, Len(ColBString) - InStr(1, ColBString, "-"))
                For ColCloop = 2 To LastRowNoC
                    If Worksheets("Sheet1").Range("C" & ColCloop).Value >= ColBLoValString And Worksheets("Sheet1").Range("C" & ColCloop).Value <= ColBHiValString Then
                        Worksheets("Sheet1").Range("G" & RowCount).Value = Worksheets("Sheet1").Range("E2").Value & Worksheets("Sheet1").Range("A" & ColAloop).Value
                        Worksheets("Sheet1").Range("H" & RowCount).Value = Worksheets("Sheet1").Range("E5").Value & Worksheets("Sheet1").Range("C" & ColCloop).Value
                        RowCount = RowCount + 1
                    End If
                Next ColCloop
            Else
               For ColCloop = 2 To LastRowNoC
                    If Worksheets("Sheet1").Range("C" & ColCloop).Value = ColBString Then
                        Worksheets("Sheet1").Range("G" & RowCount).Value = Worksheets("Sheet1").Range("E2").Value & Worksheets("Sheet1").Range("A" & ColAloop).Value
                        Worksheets("Sheet1").Range("H" & RowCount).Value = Worksheets("Sheet1").Range("E5").Value & ColBString
                        RowCount = RowCount + 1
                    End If
                Next ColCloop
            End If
            ColBString = ""
        End If
    Loop
Next ColAloop
End Sub

 

[arundharmarajan]

Actually this is better as allows for something like 7000,8000-9000 ie with the values separated by a "-" on the end.

THE SUPER AWESOME CODE!!!

Works like a charm. Thank you so much!!!