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

Dazzawm · Jun 11, 2024

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

A

B

C

1

2

31498N

31498,31498N,31498R

31498-OE,31498-OS

3

31506N

31506,31506N,31506R

31506-OE,31506-OS

4

34021N

34021,34021N,34021R

34021-OE,34021-OS

5

16324N

16324,16324N,16324R

16324-OE,16324-OS

6

30629N

30629,30629N,30629R

30629-OE,30629-OS

7

16037N

16037,16037N,16037R

16037-OE,16037-OS

8

31499N

31499,31499N,31499R

31499-OE,31499-OS

Sheet1

Dazzawm · Jun 11, 2024

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

So I need to save the function as UDF and enter =FILTER(WA(A2:A100),A2:A100<>"") each time?

Fuji · Jun 11, 2024

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

Dazzawm · Jun 11, 2024

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

Perfect, much obliged to you and @Joe4

Dazzawm · Jun 12, 2024

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

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?

Fuji · Jun 12, 2024

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

Dazzawm · Jun 12, 2024

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

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

1

Data

2

11499N

3

12896N

4

14956N

5

21671N

6

21686N

7

21974N

8

21976N

9

21980N

10

21981N

11

21982N

12

21984N

13

21985N

14

21986N

15

21987N

16

21991N

17

21992N

18

21993N

19

21994N

20

39013N

21

39015N

22

39016N

23

39019N

24

39022N

Sheet1

Fuji · Jun 12, 2024

Here's result from your data.
Make sure that you SELECT data range A2:A24 before you run the code.



Data
11499N	11499,11499N,11499R	11499-OE,11499-OS
12896N	12896,12896N,12896R	12896-OE,12896-OS
14956N	14956,14956N,14956R	14956-OE,14956-OS
21671N	21671,21671N,21671R	21671-OE,21671-OS
21686N	21686,21686N,21686R	21686-OE,21686-OS
21974N	21974,21974N,21974R	21974-OE,21974-OS
21976N	21976,21976N,21976R	21976-OE,21976-OS
21980N	21980,21980N,21980R	21980-OE,21980-OS
21981N	21981,21981N,21981R	21981-OE,21981-OS
21982N	21982,21982N,21982R	21982-OE,21982-OS
21984N	21984,21984N,21984R	21984-OE,21984-OS
21985N	21985,21985N,21985R	21985-OE,21985-OS
21986N	21986,21986N,21986R	21986-OE,21986-OS
21987N	21987,21987N,21987R	21987-OE,21987-OS
21991N	21991,21991N,21991R	21991-OE,21991-OS
21992N	21992,21992N,21992R	21992-OE,21992-OS
21993N	21993,21993N,21993R	21993-OE,21993-OS
21994N	21994,21994N,21994R	21994-OE,21994-OS
39013N	39013,39013N,39013R	39013-OE,39013-OS
39015N	39015,39015N,39015R	39015-OE,39015-OS
39016N	39016,39016N,39016R	39016-OE,39016-OS
39019N	39019,39019N,39019R	39019-OE,39019-OS
39022N	39022,39022N,39022R	39022-OE,39022-OS

Dazzawm · Jun 12, 2024

Fuji said:
Here's result from your data.
Make sure that you SELECT data range A2:A24 before you run the code.

Data
11499N 11499,11499N,11499R 11499-OE,11499-OS
12896N 12896,12896N,12896R 12896-OE,12896-OS
14956N 14956,14956N,14956R 14956-OE,14956-OS
21671N 21671,21671N,21671R 21671-OE,21671-OS
21686N 21686,21686N,21686R 21686-OE,21686-OS
21974N 21974,21974N,21974R 21974-OE,21974-OS
21976N 21976,21976N,21976R 21976-OE,21976-OS
21980N 21980,21980N,21980R 21980-OE,21980-OS
21981N 21981,21981N,21981R 21981-OE,21981-OS
21982N 21982,21982N,21982R 21982-OE,21982-OS
21984N 21984,21984N,21984R 21984-OE,21984-OS
21985N 21985,21985N,21985R 21985-OE,21985-OS
21986N 21986,21986N,21986R 21986-OE,21986-OS
21987N 21987,21987N,21987R 21987-OE,21987-OS
21991N 21991,21991N,21991R 21991-OE,21991-OS
21992N 21992,21992N,21992R 21992-OE,21992-OS
21993N 21993,21993N,21993R 21993-OE,21993-OS
21994N 21994,21994N,21994R 21994-OE,21994-OS
39013N 39013,39013N,39013R 39013-OE,39013-OS
39015N 39015,39015N,39015R 39015-OE,39015-OS
39016N 39016,39016N,39016R 39016-OE,39016-OS
39019N 39019,39019N,39019R 39019-OE,39019-OS
39022N 39022,39022N,39022R 39022-OE,39022-OS

Thanks, I do apologise I didn't select the range. Worked now.

Fuji · Jun 12, 2024

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.

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

Dazzawm

Well-known Member

Dazzawm

Well-known Member

Excel Facts

Fuji

Active Member

Dazzawm

Well-known Member

Dazzawm

Well-known Member

Fuji

Active Member

Dazzawm

Well-known Member

Fuji

Active Member

Dazzawm

Well-known Member

Fuji

Active Member

Similar threads

Forum statistics

Share this page

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

Well-known Member

Well-known Member

Excel Facts

Active Member

Well-known Member

Well-known Member

Active Member

Well-known Member

Active Member

Well-known Member

Active Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock