Remove Everything When Numbers End To Adjacent Column

mohadin

Active Member
Joined
Mar 22, 2015
Messages
361
Office Version
2013
Platform
Windows
Sorry does not do anything.
It works now your data in A1 as the other presented
then

Code:
Sub tester()
 Dim sm As Object, a, lr, i, j, m, sm1, sm2
 lr = Cells(Rows.Count, 1).End(xlUp).Row
 a = Application.Transpose(Cells(1, 1).Resize(lr))
 ReDim b(1 To lr, 1 To 2)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "(.+?\d+)|(.?|w)+"
        For j = 1 To lr
        Set m = .Execute(a(j))
        
            Set sm1 = m(0)
            Set sm2 = m(1)
                b(j, 1) = sm1
                b(j, 2) = sm2
       
        Next
    End With
    [b1].Resize(UBound(b, 1), 2) = b
End Sub
The result in B1:C1.....B6:C6

Check
 
Last edited:

Some videos you may like

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,396
Office Version
2016
Platform
Windows
Actually I need it for columns AE and AF please.
 

mohadin

Active Member
Joined
Mar 22, 2015
Messages
361
Office Version
2013
Platform
Windows
Thanks :)
change
Code:
[a1].Resize(UBound(b, 1), 2) = b
to
Code:
[ae[B]15998[/B]].Resize(UBound(b, 1), 2) = b
 
Last edited:

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,396
Office Version
2016
Platform
Windows
This doesn't appear to work either. It removes all my data in column AE and replaces it with numbers like 1.7, 0.4, 1.6 etc..? These happen to be in column A?!
 
Last edited:

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,396
Office Version
2016
Platform
Windows
Just to recap my data starts in AE2 and would like the ends removed to column AF.
 

mohadin

Active Member
Joined
Mar 22, 2015
Messages
361
Office Version
2013
Platform
Windows
Hi just to make sure I well understand

Your data are in AE2 down to the end of column AE Ok?
Then you will need to replace your data with the first part of it (only) and for get the second part?
or you need the second part to be placed in the next column (AF)?
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
44,464
Office Version
365
Platform
Windows
Are you over-complicating :confused: :confused:

EVERY example provided by you could be returned with

=LEFT(A2,7)
@Dazzawm
What is the answer/comment/alternative sample data in response to this question?
 
Last edited:

mohadin

Active Member
Joined
Mar 22, 2015
Messages
361
Office Version
2013
Platform
Windows
Hi just to make sure I well understand

Your data are in AE2 down to the end of column AE Ok?
Then you will need to replace your data with the first part of it (only) and for get the second part?
or you need the second part to be placed in the next column (AF)?
Any way try this demo and let me know how It goes
Code:
Sub Demo()
    Dim sm As Object, a, lr, c, i, j, m, sm1, sm2
    Dim x As Range
    Set x = Application.InputBox("Type first range your DATA start from", , , , , , , 8)
    lr = Cells(Rows.Count, x.Column).End(xlUp).Row - 1
    a = Application.Transpose(x.Resize(lr))
    ReDim b(1 To lr, 1 To 2)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "(.+?\d+)|(.?|w)+"
        For j = 1 To UBound(a)
            If a(j) <> "" Then
                Set m = .Execute(a(j))
                Set sm1 = m(0)
                Set sm2 = m(1)
                b(j, 1) = sm1
                b(j, 2) = sm2
            End If
        Next
    End With
    Set x = Application.InputBox("Where to place the resule", , , , , , , 8)
    c = MsgBox("Do you want the second part to the next column", vbQuestion + vbYesNo + vbDefaultButton2, "Desision")
    If c = vbYes Then
        x = 2
    Else
        x = 1
    End If
    [x].Resize(UBound(b, 1), x) = b
End Sub
 

mohadin

Active Member
Joined
Mar 22, 2015
Messages
361
Office Version
2013
Platform
Windows
verII
Code:
Sub Demo()
    Dim sm As Object, a, lr, c, i, j, m
    Dim x As Range
    Set x = Application.InputBox("Type first range your DATA start from", , , , , , , 8)
    lr = Cells(Rows.Count, x.Column).End(xlUp).Row - 1
    a = Application.Transpose(x.Resize(lr))
    ReDim b(1 To lr, 1 To 2)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "(.+?\d+)|(.?|w)+"
        For j = 1 To UBound(a)
            If a(j) <> "" Then
                Set m = .Execute(a(j))
                b(j, 1) = m(0)
                b(j, 2) = m(1)
            End If
        Next
    End With
    Set x = Application.InputBox("Where to place the resule", , , , , , , 8)
    c = MsgBox("Do you want the second part to the next column", vbQuestion + vbYesNo + vbDefaultButton2, "Desision")
    If c = vbYes Then
        x = 2
    Else
        x = 1
    End If
    [x].Resize(UBound(b, 1), x) = b
End Sub
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
5,697
Office Version
365
Platform
Windows
@Dazzawm

Is this the pattern to the first segment of string ?

( ONE or more ) ALPHA followed (ONE or more) NUMERIC

Here is UDF that can be used in the worksheet
Code:
Function [COLOR=#008000]Get_Item[/COLOR](ByVal Text As String) As String
    With CreateObject("vbscript.regexp")
        .Global = True
        .Pattern = "[a-zA-Z]+[0-9]+"
        If .Test(Text) Then Get_Item = .Execute(Text)(0)
    End With
End Function
Or can be called in a macro like this (results in columns F & G below)
Code:
Sub CallFunction()
    Dim cel As Range, x As String
    For Each cel In ActiveSheet.Range("A2:A8")
        x = [COLOR=#008000]Get_Item[/COLOR](cel)
        cel.Offset(, 5) = x
        cel.Offset(, 6) = Replace(cel, x, "")
    Next cel
End Sub
Excel 2016 (Windows) 32 bit
A
B
C
D
E
F
G
1
OiginalResult1
(UDF)
Result2 B2 copied down C2 copied downResult1
from VBA
Result2
from VBA
2
WA11711NWA11711N =Get_Item(A2) =SUBSTITUTE(A2,B2,"")WA11711N
3
WA20293RWA20293RWA20293R
4
WA22721N-WSDWA22721N-WSDWA22721N-WSD
5
WA20563-OSWA20563-OSWA20563-OS
6
WA20700NWA20700NWA20700N
7
WA20562-OSWA20562-OSWA20562-OS
8
WA13381N-6GWA13381N-6GWA13381N-6G
Sheet: Sheet4
 

Watch MrExcel Video

Forum statistics

Threads
1,096,248
Messages
5,449,242
Members
405,560
Latest member
Jadax

This Week's Hot Topics

Top