Copy values containing part text without duplicates from range to one column

[Kra]

Hello,

I have dump of data in columns A-D. I tried to use formulas to filter them into one column, but so far no success, so I think VBA would be helpful in this situation.

I want to add a macro button in cell F2, that will:

Take all values from columns A-D that begin with:

• 9F
• 9W9
• 9W0
• 9P

and move them to one column starting from cell F3 (skip duplicates). Data needs to be pasted as values and sorted in the same order as listed above (so alphabetic rules do not apply).


Is it possible to make it using macro button?

 

[Legacy 143009]

Are values spread across the columns F to I or all going to be listed in column F?

 

[Legacy 143009]

Sorry for the mess. But it works

Sub buttonFunction()
    Dim values()    As String
    Dim lRow        As Integer
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    'Get values to an array
    Dim a           As Long
    a = 0
    For i = 1 To 4
        lRow = Cells(Rows.Count, i).End(xlUp).Row
        For ii = 1 To lRow
            ReDim Preserve values(a)
            values(a) = Cells(ii, i).Value
            a = a + 1
        Next
    Next
    'Get rid of duplicates and strings
    For i = a - 1 To 0 Step -1
        If InStr(1, values(i), "9F") + InStr(1, values(i), "9W9") + InStr(1, values(i), "9W0") + InStr(1, values(i), "9P") = 0 Then
            values(i) = ""
            i = i - 1
        End If
        For ii = i - 1 To 0 Step -1
            If values(i) = values(ii) Then
                values(ii) = ""
            End If
        Next
    Next
    'Write to Coulmn F
    ii = 4
    For i = 0 To a - 1
        If Not values(i) = "" Then
            Cells(ii, 6).Value = values(i)
            ii = ii + 1
        End If
    Next
End Sub

 

[Legacy 143009]

Please use the one below:

Sub buttonFunction()
    Dim values() As String
    Dim lRow As Integer
    'Get values to an array
    Dim a As Long
    a = 0
    For i = 1 To 4
        lRow = Cells(Rows.Count, i).End(xlUp).Row
        For ii = 1 To lRow
            ReDim Preserve values(a)
            values(a) = Cells(ii, i).Value
            a = a + 1
        Next
    Next
    'Get rid of duplicates and strings
    For i = a - 1 To 0 Step -1
        If InStr(1, values(i), "9F") + InStr(1, values(i), "9W9") + InStr(1, values(i), "9W0") + InStr(1, values(i), "9P") = 0 Then
            values(i) = ""
            GoTo NextIteration
        End If
        For ii = i - 1 To 0 Step -1
            If values(i) = values(ii) Then
                values(i) = ""
                GoTo NextIteration
            End If
        Next
NextIteration:
    Next
    'Write to Column F
    ii = 3
    For i = 0 To a - 1
        If Not values(i) = "" Then
            Cells(ii, 6).Value = values(i)
            ii = ii + 1
        End If
    Next
End Sub

 

[Kra]

Please use the one below:

Sub buttonFunction()
    Dim values() As String
    Dim lRow As Integer
    'Get values to an array
    Dim a As Long
    a = 0
    For i = 1 To 4
        lRow = Cells(Rows.Count, i).End(xlUp).Row
        For ii = 1 To lRow
            ReDim Preserve values(a)
            values(a) = Cells(ii, i).Value
            a = a + 1
        Next
    Next
    'Get rid of duplicates and strings
    For i = a - 1 To 0 Step -1
        If InStr(1, values(i), "9F") + InStr(1, values(i), "9W9") + InStr(1, values(i), "9W0") + InStr(1, values(i), "9P") = 0 Then
            values(i) = ""
            GoTo NextIteration
        End If
        For ii = i - 1 To 0 Step -1
            If values(i) = values(ii) Then
                values(i) = ""
                GoTo NextIteration
            End If
        Next
NextIteration:
    Next
    'Write to Column F
    ii = 3
    For i = 0 To a - 1
        If Not values(i) = "" Then
            Cells(ii, 6).Value = values(i)
            ii = ii + 1
        End If
    Next
End Sub

Works perfect! Thank you!

 

[Legacy 143009]

Works perfect! Thank you!

Thanks for the feedback!