Formula Or Code For Below Results In Columns B & C.

Dazzawm

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,786
Office Version
  1. 365
Platform
  1. Windows
I have column A as laid out below. I would like the results that are in column B and C please. If it is a formula a UDF would be advantageous. Thanks.

New Numbers Template.xlsx
ABC
1
231498N31498,31498N,31498R31498-OE,31498-OS
331506N31506,31506N,31506R31506-OE,31506-OS
434021N34021,34021N,34021R34021-OE,34021-OS
516324N16324,16324N,16324R16324-OE,16324-OS
630629N30629,30629N,30629R30629-OE,30629-OS
716037N16037,16037N,16037R16037-OE,16037-OS
831499N31499,31499N,31499R31499-OE,31499-OS
Sheet1
 
Sort by date Sort by votes
Fuji said:
If you like UDF,
Use in cell like
B2;
=FILTER(WA(A2:A100),A2:A100<>"")
Code: 
Function WA(r As Range)
    Dim a, i As Long, s
    a = r.Value
    ReDim Preserve a(1 To UBound(a, 1), 1 To 2)
    For i = 1 To UBound(a, 1)
        s = a(i, 1)
        If s <> "" Then
            s = Left$(s, 5)
            a(i, 1) = Join(Array(s, s & "N", s & "R"), ",")
            a(i, 2) = Join(Array(s & "-OE", s & "-OS"), ",")
        End If
    Next
    WA = a
End Function
Click to expand...
So I need to save the function as UDF and enter =FILTER(WA(A2:A100),A2:A100<>"") each time?
 
Upvote 0

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
What do you mean by "each time"?

If you want it as a sub procedure then
Select Data range and run "test"
Code: 
Sub test()
    Dim x&, a
    With Selection.Columns(1)
        .Columns("b:c").Resize(Cells.SpecialCells(11).Row).ClearContents
        a = Evaluate("filter(wa(" & .Address & ")," & .Address & "<>"""")")
        .Cells(1, 2).Resize(UBound(a, 1), 2) = a
    End With
End Sub

Function WA(r As Range)
    Dim a, i&, s$
    a = r.Value
    ReDim Preserve a(1 To UBound(a, 1), 1 To 2)
    For i = 1 To UBound(a, 1)
        s = a(i, 1)
        If s <> "" Then
            s = Left$(s, 5)
            a(i, 1) = Join(Array(s, s & "N", s & "R"), ",")
            a(i, 2) = Join(Array(s & "-OE", s & "-OS"), ",")
        End If
    Next
    WA = a
End Function
 
Upvote 0
Solution
Fuji said:
What do you mean by "each time"?

If you want it as a sub procedure then
Select Data range and run "test"
Code: 
Sub test()
    Dim x&, a
    With Selection.Columns(1)
        .Columns("b:c").Resize(Cells.SpecialCells(11).Row).ClearContents
        a = Evaluate("filter(wa(" & .Address & ")," & .Address & "<>"""")")
        .Cells(1, 2).Resize(UBound(a, 1), 2) = a
    End With
End Sub

Function WA(r As Range)
    Dim a, i&, s$
    a = r.Value
    ReDim Preserve a(1 To UBound(a, 1), 1 To 2)
    For i = 1 To UBound(a, 1)
        s = a(i, 1)
        If s <> "" Then
            s = Left$(s, 5)
            a(i, 1) = Join(Array(s, s & "N", s & "R"), ",")
            a(i, 2) = Join(Array(s & "-OE", s & "-OS"), ",")
        End If
    Next
    WA = a
End Function
Click to expand...
Perfect, much obliged to you and @Joe4
 
Upvote 0
Fuji said:
What do you mean by "each time"?

If you want it as a sub procedure then
Select Data range and run "test"
Code: 
Sub test()
    Dim x&, a
    With Selection.Columns(1)
        .Columns("b:c").Resize(Cells.SpecialCells(11).Row).ClearContents
        a = Evaluate("filter(wa(" & .Address & ")," & .Address & "<>"""")")
        .Cells(1, 2).Resize(UBound(a, 1), 2) = a
    End With
End Sub

Function WA(r As Range)
    Dim a, i&, s$
    a = r.Value
    ReDim Preserve a(1 To UBound(a, 1), 1 To 2)
    For i = 1 To UBound(a, 1)
        s = a(i, 1)
        If s <> "" Then
            s = Left$(s, 5)
            a(i, 1) = Join(Array(s, s & "N", s & "R"), ",")
            a(i, 2) = Join(Array(s & "-OE", s & "-OS"), ",")
        End If
    Next
    WA = a
End Function
Click to expand...
For some reason today I am having a type mismatch pointing here

.Cells(1, 2).Resize(UBound(a, 1), 2) = a

I have it exactly layed out as my example?
 
Upvote 0
Can not replicate such issue...

However, I found a bug as a Sub Procedure, i.e. when only returns one row of data as a result, it put in rows, not columns.
Code: 
Sub test()
    Dim x&, a
    With Selection.Columns(1)
        .Columns("b:c").Resize(Cells.SpecialCells(11).Row).ClearContents
        a = WA(.Cells)
        If IsArray(a) Then
            If Is1DArray(a) Then
                .Cells(1, 2).Resize(, UBound(a)) = a
            Else
                .Cells(1, 2).Resize(UBound(a, 1), 2) = a
            End If
        End If
    End With
End Sub

Function WA(r As Range)
    Dim a, b, i&, s$, n&
    a = r.Resize(, 2).Value
    ReDim b(1 To 2, 1 To 1000)
    For i = 1 To UBound(a, 1)
        s = a(i, 1)
        If s <> "" Then
            n = n + 1
            If n > UBound(b, 2) Then
                ReDim Preserve b(1 To 3, 1 To UBound(b, 2) + 1000)
            End If
            s = Left$(s, 5)
            b(1, n) = Join(Array(s, s & "N", s & "R"), ",")
            b(2, n) = Join(Array(s & "-OE", s & "-OS"), ",")
        End If
    Next
    If n Then
        ReDim Preserve b(1 To 2, 1 To n)
        WA = Application.Transpose(b)
    End If
End Function

Function Is1DArray(a) As Boolean
    Dim x As Long
    On Error Resume Next
    x = UBound(a, 2)
    On Error GoTo 0
    Is1DArray = x = 0
End Function
 
Upvote 0
Fuji said:
Can not replicate such issue...

However, I found a bug as a Sub Procedure, i.e. when only returns one row of data as a result, it put in rows, not columns.
Code: 
Sub test()
    Dim x&, a
    With Selection.Columns(1)
        .Columns("b:c").Resize(Cells.SpecialCells(11).Row).ClearContents
        a = WA(.Cells)
        If IsArray(a) Then
            If Is1DArray(a) Then
                .Cells(1, 2).Resize(, UBound(a)) = a
            Else
                .Cells(1, 2).Resize(UBound(a, 1), 2) = a
            End If
        End If
    End With
End Sub

Function WA(r As Range)
    Dim a, b, i&, s$, n&
    a = r.Resize(, 2).Value
    ReDim b(1 To 2, 1 To 1000)
    For i = 1 To UBound(a, 1)
        s = a(i, 1)
        If s <> "" Then
            n = n + 1
            If n > UBound(b, 2) Then
                ReDim Preserve b(1 To 3, 1 To UBound(b, 2) + 1000)
            End If
            s = Left$(s, 5)
            b(1, n) = Join(Array(s, s & "N", s & "R"), ",")
            b(2, n) = Join(Array(s & "-OE", s & "-OS"), ",")
        End If
    Next
    If n Then
        ReDim Preserve b(1 To 2, 1 To n)
        WA = Application.Transpose(b)
    End If
End Function

Function Is1DArray(a) As Boolean
    Dim x As Long
    On Error Resume Next
    x = UBound(a, 2)
    On Error GoTo 0
    Is1DArray = x = 0
End Function
Click to expand...
Sorry nothing happened at all when I run the new code. Below is the data I am running it on.

New Numbers Template.xlsx
A
1Data
211499N
312896N
414956N
521671N
621686N
721974N
821976N
921980N
1021981N
1121982N
1221984N
1321985N
1421986N
1521987N
1621991N
1721992N
1821993N
1921994N
2039013N
2139015N
2239016N
2339019N
2439022N
Sheet1
 
Upvote 0
Here's result from your data.
Make sure that you SELECT data range A2:A24 before you run the code.

Data
11499N11499,11499N,11499R11499-OE,11499-OS
12896N12896,12896N,12896R12896-OE,12896-OS
14956N14956,14956N,14956R14956-OE,14956-OS
21671N21671,21671N,21671R21671-OE,21671-OS
21686N21686,21686N,21686R21686-OE,21686-OS
21974N21974,21974N,21974R21974-OE,21974-OS
21976N21976,21976N,21976R21976-OE,21976-OS
21980N21980,21980N,21980R21980-OE,21980-OS
21981N21981,21981N,21981R21981-OE,21981-OS
21982N21982,21982N,21982R21982-OE,21982-OS
21984N21984,21984N,21984R21984-OE,21984-OS
21985N21985,21985N,21985R21985-OE,21985-OS
21986N21986,21986N,21986R21986-OE,21986-OS
21987N21987,21987N,21987R21987-OE,21987-OS
21991N21991,21991N,21991R21991-OE,21991-OS
21992N21992,21992N,21992R21992-OE,21992-OS
21993N21993,21993N,21993R21993-OE,21993-OS
21994N21994,21994N,21994R21994-OE,21994-OS
39013N39013,39013N,39013R39013-OE,39013-OS
39015N39015,39015N,39015R39015-OE,39015-OS
39016N39016,39016N,39016R39016-OE,39016-OS
39019N39019,39019N,39019R39019-OE,39019-OS
39022N39022,39022N,39022R39022-OE,39022-OS
 
Upvote 0
Fuji said:
Here's result from your data.
Make sure that you SELECT data range A2:A24 before you run the code.

Data
11499N11499,11499N,11499R11499-OE,11499-OS
12896N12896,12896N,12896R12896-OE,12896-OS
14956N14956,14956N,14956R14956-OE,14956-OS
21671N21671,21671N,21671R21671-OE,21671-OS
21686N21686,21686N,21686R21686-OE,21686-OS
21974N21974,21974N,21974R21974-OE,21974-OS
21976N21976,21976N,21976R21976-OE,21976-OS
21980N21980,21980N,21980R21980-OE,21980-OS
21981N21981,21981N,21981R21981-OE,21981-OS
21982N21982,21982N,21982R21982-OE,21982-OS
21984N21984,21984N,21984R21984-OE,21984-OS
21985N21985,21985N,21985R21985-OE,21985-OS
21986N21986,21986N,21986R21986-OE,21986-OS
21987N21987,21987N,21987R21987-OE,21987-OS
21991N21991,21991N,21991R21991-OE,21991-OS
21992N21992,21992N,21992R21992-OE,21992-OS
21993N21993,21993N,21993R21993-OE,21993-OS
21994N21994,21994N,21994R21994-OE,21994-OS
39013N39013,39013N,39013R39013-OE,39013-OS
39015N39015,39015N,39015R39015-OE,39015-OS
39016N39016,39016N,39016R39016-OE,39016-OS
39019N39019,39019N,39019R39019-OE,39019-OS
39022N39022,39022N,39022R39022-OE,39022-OS
Click to expand...
Thanks, I do apologise I didn't select the range. Worked now.
 
Upvote 0
If you always set the data in A2:Ax,
change
Code: 
    With Selection.Columns(1)
to
Code: 
    With Range("a2", Range("a" & Rows.Count).End(xlUp))
Then no need to SELECT the data range.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Dazzawm
  • Solved
Code To Highlight Rows When Data Is Missing In Column AA
2 3 4
Replies
30
Views
2K
Dazzawm
Dazzawm
Dazzawm
  • Solved
Formula To Remove Last Letter Of Data In Column C To Column D
Replies
4
Views
146
Dazzawm
Dazzawm
H
  • Solved
Return and rank top 3 results (including ties) from VSTACK, FILTER, CHOOSECOLS, and SORT formula
Replies
8
Views
207
Peter_SSs
Peter_SSs
A
  • Solved
COUNT multiple SUM COUNTIFS
Replies
6
Views
361
Peter_SSs
Peter_SSs
D
  • Solved
Formula for column for (sort of) running count
Replies
7
Views
124
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top