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

Dazzawm

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,783
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

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
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
N
  • Solved
Help with formula consolidating Data
2
Replies
12
Views
397
Fluff
Fluff
B
  • Solved
Ignore Blank values not working correctly using TEXTJOIN function
Replies
5
Views
207
Bombdiggity
B
E
  • Solved
Looking for a spilled formula returning the value in a table matching 3 conditions
Replies
5
Views
137
ED38
E
D
  • Solved
Return Multiple Values From Two Columns In Two Separate Workbooks
2
Replies
13
Views
267
Fluff
Fluff

Forum statistics

Threads
1,223,238
Messages
6,170,939
Members
452,368
Latest member
jayp2104

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