VBA ARRAY CODE HELP

[roykana]

Dear all master,
Please help for vba array code remove numbers based on specific contents of cell.

ORIIGINAL

RESULT

So remove the numbers based on the contents of the word "KANA".


Thanks

roykana

 

[ranman256]

paste the code into a module, then run ClearNumsVia1Word.
enter the name of the person to find, it will erase the numbers.

Sub ClearNumsVia1Word()
Dim vWord, vChr
Dim i As Integer
Dim vCellVal
vWord = InputBox("Enter name to find", "Remove # from name")
If vWord = "" Then Exit Sub
vWord = UCase(vWord)
Range("A1").Select
While ActiveCell.Value <> ""
   vCellVal = UCase(ActiveCell.Value)
   If InStr(vCellVal, vWord) > 0 Then
     
      'MsgBox vCellVal, , "found"
      For i = Len(vCellVal) To 1 Step -1
          If Not IsNumeric(Mid(vCellVal, i, 1)) Then
            ActiveCell.Value = Left(vCellVal, i)
            GoTo skipNext
          End If
         
      Next
   End If
   
skipNext:
   ActiveCell.Offset(1, 0).Select  'next row
Wend
End Sub

 

[roykana]

paste the code into a module, then run ClearNumsVia1Word.
enter the name of the person to find, it will erase the numbers.

Sub ClearNumsVia1Word()
Dim vWord, vChr
Dim i As Integer
Dim vCellVal
vWord = InputBox("Enter name to find", "Remove # from name")
If vWord = "" Then Exit Sub
vWord = UCase(vWord)
Range("A1").Select
While ActiveCell.Value <> ""
   vCellVal = UCase(ActiveCell.Value)
   If InStr(vCellVal, vWord) > 0 Then
    
      'MsgBox vCellVal, , "found"
      For i = Len(vCellVal) To 1 Step -1
          If Not IsNumeric(Mid(vCellVal, i, 1)) Then
            ActiveCell.Value = Left(vCellVal, i)
            GoTo skipNext
          End If
        
      Next
   End If
  
skipNext:
   ActiveCell.Offset(1, 0).Select  'next row
Wend
End Sub

Thank you for your reply. I want to immediately set the name in the code and I try 5000 records running very slowly. if you make a vba array code it might be faster

 

[jolivanes]

Don't quote whole posts. Just a bunch of extra clutter.
Refer to a Post number if required.

Sub Maybe_So()
Dim c As Range
    For Each c In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        If Left(c, 4) = "KANA" Then c.Value = Left(c, InStrRev(c, " ") - 1)
    Next c
End Sub

Sub Or_Maybe_So()
Dim aArr, i As Long
aArr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    For i = LBound(aArr) To UBound(aArr)
        If Left(aArr(i, 1), 4) = "KANA" Then aArr(i, 1) = Left(aArr(i, 1), InStrRev(aArr(i, 1), " ") - 1)
    Next i
Range("A1").Resize(UBound(aArr)) = Application.Index(aArr, , 1)
End Sub

Sub Or_Maybe_Even_So()
Const strCol = "A" ' column
Const strText = "KANA" ' text to look for
Dim lngLast As Long, c As Range
lngLast = Range(strCol & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
    With Range(strCol & "1:" & strCol & lngLast)
        .AutoFilter Field:=1, Criteria1:=strText & "*"
            For Each c In Range("A2:A" & lngLast).SpecialCells(12)    'strCol & "1:" & strCol & lngLast).Offset(1).SpecialCells(12)
                c.Value = Left(c, InStrRev(c, " ") - 1)
            Next c
        .AutoFilter
    End With
Application.ScreenUpdating = True
End Sub

 

[roykana]

Don't quote whole posts. Just a bunch of extra clutter.
Refer to a Post number if required.

Sub Maybe_So()
Dim c As Range
    For Each c In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        If Left(c, 4) = "KANA" Then c.Value = Left(c, InStrRev(c, " ") - 1)
    Next c
End Sub

Sub Or_Maybe_So()
Dim aArr, i As Long
aArr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    For i = LBound(aArr) To UBound(aArr)
        If Left(aArr(i, 1), 4) = "KANA" Then aArr(i, 1) = Left(aArr(i, 1), InStrRev(aArr(i, 1), " ") - 1)
    Next i
Range("A1").Resize(UBound(aArr)) = Application.Index(aArr, , 1)
End Sub

Sub Or_Maybe_Even_So()
Const strCol = "A" ' column
Const strText = "KANA" ' text to look for
Dim lngLast As Long, c As Range
lngLast = Range(strCol & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
    With Range(strCol & "1:" & strCol & lngLast)
        .AutoFilter Field:=1, Criteria1:=strText & "*"
            For Each c In Range("A2:A" & lngLast).SpecialCells(12)    'strCol & "1:" & strCol & lngLast).Offset(1).SpecialCells(12)
                c.Value = Left(c, InStrRev(c, " ") - 1)
            Next c
        .AutoFilter
    End With
Application.ScreenUpdating = True
End Sub

dear Jolivanes,
sorry I'm late to reply to you. thank you very much for your reply
of the three codes running perfectly. There is a little problem I want to ask you.
1. If I use the text "kana" with 100,000 records, the error is in the "Sub Or_Maybe_So()" code, which is run time error 13.
What is the cause and what is the solution?.
2. If the text is more than one what to use code like "Sub toCall() Call Call call End Sub" or any other solution from you.

Thanks
roykama

 

[Peter_SSs]

2. If the text is more than one what to use ..

Can you be more specific with what you have and what you are trying to achieve?

Also, when you get a code error, please give the full error message and identify which line of the code gives the error.

 

[roykana]

Can you be more specific with what you have and what you are trying to achieve?

it means that the text criteria are more than one example I use text"kana","budi","joko" so what is the solution in the code. whether to call each sub code for each text or is there another solution. And I just want the process to be fast for many records. from the code that jolivanes gave it was perfect, there was only an error in one of the codes because 100,000
the record. the code below:

Sub Or_Maybe_So()
Dim aArr, i As Long
aArr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    For i = LBound(aArr) To UBound(aArr)
        If Left(aArr(i, 1), 4) = "KANA" Then aArr(i, 1) = Left(aArr(i, 1), InStrRev(aArr(i, 1), " ") - 1)
    Next i
Range("A1").Resize(UBound(aArr)) = Application.Index(aArr, , 1) 'error in this line
End Sub

Thanks
roykana

 

[Peter_SSs]

I have not been able to reproduce that error on that line of the code, even with 1000,000 rows.

Does it make any difference if you change that marked line to this?

Range("A1").Resize(UBound(aArr)) = aArr

Do you have any error values in the column?

 

[roykana]

I have not been able to reproduce that error on that line of the code, even with 1000,000 rows.

Does it make any difference if you change that marked line to this?

Range("A1").Resize(UBound(aArr)) = aArr

Do you have any error values in the column?

no error found

 

[jolivanes]

Any good reason why the 20+ lines of code from Post #2 are repeated in Post #3?
Any good reason why the 30+ lines of code from Post #4 are repeated in Post #5?
Just read the very first line of Post #4 again.