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
paste the code into a module, then run ClearNumsVia1Word.
enter the name of the person to find, it will erase the numbers.
Code: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
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
ADVERTISEMENT
dear Jolivanes,Don't quote whole posts. Just a bunch of extra clutter.
Refer to a Post number if required.
Code: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
Code: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
Code: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
Can you be more specific with what you have and what you are trying to achieve?2. If the text is more than one what to use ..
ADVERTISEMENT
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,000Can you be more specific with what you have and what you are trying to achieve?
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
Range("A1").Resize(UBound(aArr)) = aArr
no error foundI 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?
VBA Code:Range("A1").Resize(UBound(aArr)) = aArr
Do you have any error values in the column?