Macro not working on cells with more than one character - excel

I have a spreadsheet that has 29 columns of headers in row 6. Underneath the 29 headers, there is numerical data that extends to 10000 rows. I want to select a header and then enter a minimum value and a maximum value and any data that exceeds the maximum, or is lower than the minimum for that header column, the row that violates the criteria gets deleted.
I was thinking of a user inputting a minimum and a maximum value in cell A1 and A2 then selecting a header from a drop down box then it runs and removes the rows that violate the boundary conditions. So far I have this.
Sub deleterows()
Application.ScreenUpdating = False
Dim Min As Integer
Dim Max As Integer
Dim i As Integer
Dim HeaderRange As Range
Dim matchval As Double
Dim str As String
'Finding column number for the header
'Header is selected in Row 3, headers for the data is in row 6
matchval = Application.Match(Range("A3"), Range("A6:AC6"), 0)
str = Split(Cells(, matchval).Address, "$")(1)
Set HeaderRange = Range(str & "6:" & str & Cells(6, Columns.Count).End(xlToLeft).Column).Find(What:=str, lookat:=xlWhole)
If Cells(1, 1).Value <> "" And IsNumeric(Cells(1, 1)) Then
Min = Cells(1, 1).Value
End If
If Cells(2, 1).Value <> "" And IsNumeric(Cells(2, 1)) Then
Max = Cells(2, 1).Value
End If
For i = Cells(Rows.Count, HeaderRange.Column).End(xlUp).Row To 7 Step -1
If Cells(i, HeaderRange.Column).Value > Max Or Cells(i, HeaderRange.Column).Value < Min Then
Rows(i).EntireRow.Delete
End If
Next i
End Sub
Basically, I'm finding the position of the Header and then finding the address, converting it into a string then using the Column index for that header. Then it finds any cell that violates the minimum and maximum condition and deletes it.
However, when I try running this, I run into errors when I'm trying to use headers that have more than a single character. So if I have a header called "V" it runs fine, however if I have one called "Vradial", I get an error saying "Run-time error '91': Object variable or With block variable not set" for line:
For i = Cells(Rows.Count, HeaderRange.Column).End(xlUp).Row To 7 Step -1
Any help would be greatly appreciated.
Thanks!

I found the answer for your direct question "Why only single character headers work". I also noticed that you have an unnecessary redundancy in the code (already mentioned/noticed in the comments by the user "eirikdaude")
"Why only single character headers work"
When using the Find(What:=str) in the code below, you are finding a letter only (the alphabetic column identifiers). What you should be finding/searching for, is the value (actual text) of the header that is written in the sheet
Set HeaderRange = Range(str & "6:" & str & Cells(6,
Columns.Count).End(xlToLeft).Column).Find(What:=str, lookat:=xlWhole)
You can write the line as follows: (I tested it and works)
Set HeaderRange = Range(str & "6:" & str & Cells(6,
Columns.Count).End(xlToLeft).Column).Find(What:=Range("A3"), lookat:=xlWhole)
"Unnecessary Redundancy in the Code"
The above correction while it works, is unnecessary. If I am not mistaken the code line with the issue is used to find the header column. If so, you already find the correct header column index from the code below.
matchval = Application.Match(Range("A3"), Range("A6:AC6"), 0)
'This is only the correct header column index because the match/search range starts from column "A"
Hence, you can disregard the line that is giving you trouble and write the code as follows: (And do not forget to set Application.ScreenUpdating=True at the end ;D)
Sub deleterows()
Application.ScreenUpdating = False
Dim Min As long 'if you expect the min or max to have decimals use Double or Single rather than Long
Dim Max As long
Dim i As long 'I changed from Integer to Long because 99% of the time Long is better than Integer
Dim matchval As long 'application.match returns a position in an array. Hence Long/Integer are better than Double
'Finding column number for the header
'Header is selected in Row 3, headers for the data is in row 6
matchval = Application.Match(Range("A3"), Range("A6:AC6"), 0)
If Cells(1, 1).Value <> "" And IsNumeric(Cells(1, 1)) Then
Min = Cells(1, 1).Value
End If
If Cells(2, 1).Value <> "" And IsNumeric(Cells(2, 1)) Then
Max = Cells(2, 1).Value
End If
For i = Cells(Rows.Count, matchval).End(xlUp).Row To 7 Step -1
If Cells(i, matchval).Value > Max Or Cells(i, matchval).Value < Min Then
Rows(i).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
Hope this helps you.

Related

Store a specific column value until next value is identified

I have very basic knowledge in VBA, I have one requirement where the data for a specific set will be available in multiple rows and it will be like Header (ex. from A to D) and lines (ex. from E:J). Header will not be there for all the line rows, so when validating the line data with Header data, I need to validate the value in for ex. col "D2" with all the lines and when the new header is available, follow the same pattern again.
Below is the sample data format, in which col "A:D" represents Header data and from col "E:J" represents line data. Through out the line validation with Header, I want col "D" value to be captured through out that iteration.
Ex. When the "ABC" value is iterated, "PO1" should be available for validation for rows "E2:J4". After this iteration and when the new value on Col A, i.e "DEF" is encountered then the value in Col "D" to be changed like "PO2" from the next 2 rows of the Header.
As I have very basic knowledge in VB, not sure how I can achieve this. Can anyone help me here please?
I tried to compare the first value with the next available value in Col A, during this iteration tried storing the Col "D" value to a global variable but it is not giving me expected results
Sample code that i tried:
Public v As Integer
Sub inv()
Dim i As Integer, j As Integer, temp As Integer, rng As Range
Dim lastRow As Integer, lastRowSheet2 As Integer
Dim sheet1 As Worksheet, Sheet2 As Worksheet
Set sheet1 = Sheets("Data")
Set Sheet2 = Sheets("res")
lrow = sheet1.Range("A1").SpecialCells(xlCellTypeLastCell).Row
For i = 2 To lrow
If sheet1.Range("A" & i).Value <> "" Then
invv = sheet1.Range("A" & i).Value
v = i
End If
If sheet1.Range("A" & i + 1).Value <> "" Then
ninv = sheet1.Range("A" & i + 1).Value
End If
If invv <> ninv And sheet1.Range("A" & i + 1).Value <> "" Then
Sheet2.Range("A" & i).Value = sheet1.Range("D" & v).Value
MsgBox "Alert -Entry in row is not equal to Previous Cell !!"
'Exit Sub
End If
Next i
End Sub
... and what about filling in those values, like I did in this example:
Select all data (Ctrl+G, Special, Current Region).
In there, select all blanks (Ctrl+G, Special, Blanks).
Copy the value from the one above (F2, fill in =A2).
Fill in for all select (blank) cells (Ctrl+ENTER)
This is what you end up with:

How to generate an alphanumeric tree changes with criteria?

I'm working on excel sheet template used for SAP System and I have 2 columns looks like below:
Column C Column E
Level Element Code
3 ABCD.01.01.01
4 ABCD.01.01.01.01
4 ABCD.01.01.01.02
4 ABCD.01.01.01.03
3 ABCD.01.01.02
4 ABCD.01.01.02.01 'I Want to Restart Numbering Here
4 ABCD.01.01.02.02
4 ABCD.01.01.02.03
I succeeded in level 3 to be automated in the whole sheet by Macro as below
Sub AutoNumber3()
Dim Rng, C As Range
Dim Lrow As Long
Dim i As Integer
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Worksheets("Union").Range("C2:C" & Lrow)
i = 1
For Each C In Rng.Cells
If C.Value = 3 Then
For i = 1 To i Step 1
C.Offset(0, 2).Value = "ABCD.01.01." & i
Next i
End If
Next C
End Sub
and I used the same for level 4 as below
Sub AutoNumber4()
Dim Rng, C As Range
Dim Lrow As Long
Dim i As Integer
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Worksheets("Union").Range("C2:C" & Lrow)
i = 1
For Each C In Rng.Cells
If C.Value = 4 Then
For i = 1 To i Step 1
C.Offset(0, 2).Value = "ABCD.01.01.01" & i
Next i
End If
Next C
End sub
I want to Restart the numbering of level 4 from 1 each time the cells values in the level column = 3 by using Do Until the next C.Value = 3, I = 1 But I can not put it correctly in the Autonumber4 procedure
Your help is highly appreciated since this sheet may reach to 50000 or 100000 rows which is impossible to fill them manually
Thanks, Regards
Moheb Labib
Try this
Sub AutoNumber()
Dim rngLevels As Range, cl As Range
Dim lLastRow As Long, i As Long
Dim sElemCode As String
Dim vLevelsCounter() As Long
With ThisWorkbook.Sheets("Union")
lLastRow = Evaluate("=COUNTA(" & .Name & "!C:C)")
lLastRow = WorksheetFunction.Max(lLastRow, .Cells(Rows.count, "C").End(xlUp).Row)
Set rngLevels = .Range("C2:C" & lLastRow)
End With
For Each cl In rngLevels.Cells
' Uncomment "If" to use it on filtered data only
'If Not cl.EntireRow.Hidden Then
UpdateLevelsCounters vLevelsCounter, cl.Value
sElemCode = "ABCD"
For i = 1 To cl.Value
sElemCode = sElemCode & "." & Format(vLevelsCounter(i), "00")
Next i
cl.Offset(0, 2).Value = sElemCode
'End If
Next cl
End Sub
Function UpdateLevelsCounters(ByRef arr() As Long, lLevel As Long)
If lLevel < 1 Then Exit Function
Dim i As Long
ReDim Preserve arr(1 To lLevel)
For i = LBound(arr) To lLevel - 1
If arr(i) = 0 Then arr(i) = 1
Next i
arr(lLevel) = arr(lLevel) + 1
End Function
This should work for levels other than 3 and 4 as well (I hope)
You've not specified if your count will be always of two digits or not, and if it can be something like 01.20.99.99, but This formula can lead you in the good way (not tested with 100000 records)
=IF(C2=3;"ABCD.01.01."&TEXT(COUNTIF($C$2:C2;C2);"00");INDIRECT("E"&SUMPRODUCT(MAX(--($C$2:C2=3)*ROW($C$2:C2))))&"."&TEXT(SUMPRODUCT(--($C$2:C2=4)*--(ROW($C$2:C2)>SUMPRODUCT(MAX(--($C$2:C2=3)*ROW($C$2:C2)))));"00"))
This is how it works:
A) First, we check if cell in colum C is a 3 or 4. In case is 3, we do ;"ABCD.01.01."&TEXT(COUNTIF($C$2:C2;C2);"00"); This will count how many times does the number 3 appear in range $C$2:C2 and will concatenate to string ABCD.01.01. The trick here is using $C$2:C2, because it makes a range dynamic (but it can overload calculus times)
B) If not 3, then we do a really complext part I'm going to try to explain. Also, we use the trick of dynamic range
SUMPRODUCT(MAX(--($C$2:C2=3)*ROW($C$2:C2)))) this part is used twice. It will get the last row number of the last 3 value in column C.
Example:ROW($C$2:C6) will get an array of just row numbers, like {2;3;4;5;6}. --($C$2:C6=3) will return an array of zero/one depending if cell equals/not equals to 3, something like {1;0;0;0;1}. ($C$2:C6=3)*ROW($C$2:C6)) will multiply both arrays, so we get {1;0;0;0;1}*{2;3;4;5;6}={2;0;0;0;6}. And with MAX we get max value from that array, That 6 means the last position of a 3 value.
We use INDIRECT combined with the number of step 1 to get the text inside the cell
SUMPRODUCT(--($C$2:C2=4)*--(ROW($C$2:C2)>SUMPRODUCT(MAX(--($C$2:C2=3)*ROW($C$2:C2)))));" Everything after the > is the same logic than step 1. It will return the row number of last cell containing a 3. Part SUMPRODUCT(--($C$2:C2=4)*--(ROW($C$2:C2) will just get row numbers of those cells containing a 4 value, and which row numbers are higher than value obtained in step 1. That way you make sure how to count the cells containing 4 values, between two cells containing 3 values.
We concatenate everything to form the final string.
TEXT functions are just used to force the calculation to be 2 digits.
You can use this manually, or you can insert the formula using VBA, drag down, and then converting everything into values (I would probably would do that). Something like this could work.
Sub Macro1()
Dim LR As Long
LR = Range("C" & Rows.Count).End(xlUp).Row 'last non blank row in column c
Range("E2").FormulaR1C1 = _
"=IF(RC[-2]=3,""ABCD.01.01.""&TEXT(COUNTIF(R2C3:RC[-2],RC[-2]),""00""),INDIRECT(""E""&SUMPRODUCT(MAX(--(R2C3:RC[-2]=3)*ROW(R2C3:RC[-2]))))&"".""&TEXT(SUMPRODUCT(--(R2C3:RC[-2]=4)*--(ROW(R2C3:RC[-2])>SUMPRODUCT(MAX(--(R2C3:RC[-2]=3)*ROW(R2C3:RC[-2]))))),""00""))"
Range("E2").AutoFill Destination:=Range("E2:E" & LR), Type:=xlFillDefault
Range("E2:E" & LR) = Range("E2:E" & LR).Value 'paste into values
End Sub
NOTE: Probably you will need to adapt this depending on the results (we do not know if the count of 3 or 4 values can have 3 or 4 digits, and so on).

VBA is stepping around my for loop without executing it

I'm trying to make a unique ID for each sample in a variable length data set. to do this I want to use part of two strings of data called the Name and Sample Type. I want i to go down each row in the column and take the pieces of each string and put them together, however when I step through the loop it never goes into my loop, only around it. can someone tell me why?
Sheets("Data").Activate
setlastrow = Sheets("Data").Range("b5000").End(xlUp).Row
setlastcol = Sheets("Data").Cells(5, Columns.Count).End(xlToLeft).Column 'this is still assuming that row 5 has the header in it
colname = Rows(5).Find("Name", LookAt:=xlWhole).Column ' this can be repeated for any other columns we want to asign values to. These variables will make the rest of this much easier
colSampleText = Rows(5).Find("Sample Text", LookAt:=xlWhole).Column
For i = 6 To lastrow
Sheets("Data").Range(Cells(i, 1)) = workbookfunction.if(workbookfunction.CountIf(Range(Cells(6, colname), Cells(i, colname)), Cells(i, colname)) < 10, "0", "") & workbookfunction.CountIf(Range(Cells(6, colname), Cells(i, colname)), Cells(i, colname) & "-" & Left(Cells(i, colSampleText), 5))
'this should find the unique identifying infomation for each sample and analyte
Next i
There are two major errors in your code - plus a minor one. One is structural. You declare non of the variables you use. It's like saying, "Since I don't know how to drive I might as well close my eyes as we speed along". It's not without logic but does little toward getting you to where you want to go.
The other is in the mix-up between the worksheet function you want VBA to execute and the one you wish to assign to a cell to be executed by Excel. Writing a complex formula to a cell is more difficult than getting VBA to calculate a complex formula. For the method, if you want to create a formula in VBA you should assign it to a string first, like MyFormula = "=COUNTIF(D6:D12, "MyName")" and then, after testing it, assign that string to the cell's Formula property, like Cells(R, ClmName).Formula = MyFormula". In the code below I chose to let VBA do the calculating. Since it isn't entirely clear what you want (faulty code is never a good way to show what you intend!) please revise it. It's easier in VBA than in a worksheet function.
Private Sub Test()
Dim LastRow As Long
Dim LastClm As Long
Dim ClmName As Long ' R use "col" for color, "clm" for column
Dim ClmSampleText As Long
Dim CountRng As Range
Dim Output As Variant
Dim R As Long ' R use R for row, C for column
Sheets("Data").Activate
LastRow = Sheets("Data").Range("b5000").End(xlUp).Row
' this is still assuming that row 5 has the header in it
LastClm = Sheets("Data").Cells(5, Columns.Count).End(xlToLeft).Column
' this can be repeated for any other columns we want to asign values to.
' These variables will make the rest of this much easier
ClmName = Rows(5).Find("Name", LookAt:=xlWhole).Column
ClmSampleText = Rows(5).Find("Sample Text", LookAt:=xlWhole).Column
For R = 6 To LastRow
'this should find the unique identifying infomation for each sample and analyte
Set CountRng = Range(Cells(6, ClmName), Cells(R, ClmName))
Output = WorksheetFunction.CountIf(CountRng, Cells(R, ClmName).Value)
If Output < 10 Then Output = 0
Cells(R, 1).Value = CStr(Output) & "-" & Left(Cells(R, ClmSampleText).Value, 5)
Next R
End Sub
The "minor" mistake stems from your lack of understanding of the Cell object. A cell is a Range. It has many properties, like Cell.Row and Cell.Column or Cell.Address, and other properties like Cell.Value or Cell.Formula. The Value property is the default. Therefore Cell is the same as Cell.Value BUT not always. In this example, by not thinking of Cell.Value you also overlooked Cell.Formula, and by placing Cell into a WorksheetFunction you confused VBA as to what you meant, Cell the Value or Cell the Range. With all participants confused the outcome was predictable.
The recommendation is to always write Cell.Value when you mean the cell's value and use Cell alone only if you mean the range.
You have an error with the end part of your For...Next statement.
From the code you have posted, LastRow is not explicitly declared anywhere, so when you run your code, LastRow is created as Type Variant with a default Empty value.
Consider this code:
Sub LoopTest()
Dim DeclaredVariable As Long
Dim i As Long
DeclaredVariable = 10
For i = 1 To UnDeclaredVariable
Debug.Print i & " UnDeclaredVariable"
Next i
For i = 1 To DeclaredVariable
Debug.Print i & " DeclaredVariable"
Next i
End Sub
The output in the immidiate window would be:
1 DeclaredVariable
2 DeclaredVariable
3 DeclaredVariable
4 DeclaredVariable
5 DeclaredVariable
6 DeclaredVariable
7 DeclaredVariable
8 DeclaredVariable
9 DeclaredVariable
10 DeclaredVariable
This shows us that the loop for the UnDeclaredVariable has not been entered - AND this is due to the fact the end part of the For...Next loop is Empty (The default value of a Variant data type) so there is no defined end for the loop to iterate to.
NB To be more precise, the issue is that the UnDeclaredVariable has no (numeric) value assigned to it - if you assign a value to a variable that is undeclared it becomes a data type Variant/<Type of data you assigned to it> for example UnDeclaredVariable = 10 makes it a Variant/Intigertype .
The reason why it steps over the loop and doesn't throw an error is because you don't have Option Explicit at the top of your code module (or Tools > Options > "Require Variable Declaration" checked) which means the code can still run with undeclared variables (this includes if you spell a declared variable incorrectly).
If you add Option Explicit to the top of your code module:
Option Explicit
Sub LoopTest()
Dim DeclaredVariable As Long
Dim i As Long
DeclaredVariable = 10
For i = 1 To UnDeclaredVariable
Debug.Print i & " UnDeclaredVariable"
Next i
For i = 1 To DeclaredVariable
Debug.Print i & " DeclaredVariable"
Next i
End Sub
You would get the following error:
Compile Error:
Variable not defined
This is a fantastic example of why Option Explicit is an important declaration to make in all code modules.
Here is a variation of your code; I've modified your code to set your two columns using Find, loop through each cel in the range(using the current row), set varcnt to count the number of matches, defined the first 5 letters of value in the Sample Text column as str, and used a basic If statement to write the combined the unique ID into the first column.
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Data")
Dim lRow As Long: lRow = ws.Range("b5000").End(xlUp).Row
Dim dataCol As Long: dataCol = ws.Range("A5:J5").Find(What:="Name", LookIn:=xlValues, lookat:=xlWhole).Column
Dim smplTextCol As Long: smplTextCol = ws.Range("A5:J5").Find(What:="Sample Text", LookIn:=xlValues, lookat:=xlWhole).Column
For Each cel In ws.Range(ws.Cells(6, dataCol), ws.Cells(lRow, dataCol))
Dim varcnt As Long: varcnt = Application.WorksheetFunction.CountIf(ws.Range(ws.Cells(6, dataCol), ws.Cells(cel.Row, dataCol)), ws.Cells(cel.Row, dataCol).Value)
Dim str As String: str = Left(ws.Cells(cel.Row, smplTextCol).Value, 5)
If varcnt < "4" Then
ws.Cells(cel.Row, 1).Value = "0" & "-" & str
Else
ws.Cells(cel.Row, 1).Value = "" & "-" & str
End If
Next cel

Copying rows to a wksheet based on the value in a specific column isn't applying to my whole spreadsheet

I'm looping over values in Column B of the current worksheet. If the value's length is 8 characters, copy the WHOLE row to another sheet.
It is kind of working, but I'm missing around a hundred rows that should have been copied.
I guess it's to do with the format of the cell values in Column B. There are some that are just Text headers which will definitely not meet the criteria. The ones that it should copy are all in this format (Column B):
6008571X
60088242
....
The rows I'm interested in have 8 characters in Column B. The problem is that some of them might be formatted as numbers some as text (or perhaps preceded by ').
Sub aims()
Dim i As Long
'Get the address of the first non blank cell in Row B from the bottom
MyFirstBlankAddress = Range("B1048576").End(xlUp).Offset(1, 0).Address
'Extract the number from the address to get the row number
MyRowNumber = Split(MyFirstBlankAddress, "$")(2)
For i = 1 To MyRowNumber
With Range("B" & i)
If Len(.Value) = 8 Then .EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End With
Next i
End Sub
I was expecting 410 rows copied, while only 276 got copied.
EDIT: I have been reading your answers/suggestions and testing stuff. I've found out that the problem lies elsewhere. My original code identifies the rows in a correct way, it's something to do with copying.
If I change my code to just highlight the matching rows, it matches all the right rows:
If Len(.Value) = 8 Then .EntireRow.Interior.Color = 5296274
I'm sure there is a better way to do the copy/paste, which is where your issue is, but the below works.
Sub aims()
Dim i As Long
Dim vLastRow As Long
Dim s2 As Long
'find last row in sheet, or you could change to find last row in specified column
'Example: Cells = Columns(column number or letter), Cells(1, 1) = Cells(1, column number)
vLastRow = Cells.Find(what:="*", after:=Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row
s2 = 1
Application.ScreenUpdating = False
For i = 1 To vLastRow
If Trim(Len(CStr(Cells(i, 2)))) = 8 Then
Rows(i).EntireRow.Copy Destination:=Sheets(2).Range(Cells(s2, 1).Address)
s2 = s2 + 1
End If
Next i
Application.ScreenUpdating = True
End Sub
You can try something like this. The below code attempts to copy everything at once instead of having many instances of copy/paste. The two tests are seeing if the trimmed value has a character length of 8 OR if the trimmed value has a character length of 9 but the last character is the apostrophe. If either of these criteria are met, we will add that cell to a Union.
Once the code has looped through all rows, it will copy the entire union at all once
Option Explicit
Sub shooter()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update
Dim LR As Long, i As Long, Add As Boolean, CopyMe As Range
Dim x As Range
LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For Each x In ws.Range("B2:B" & LR)
Add = False
If Len(Trim(x)) = 8 Then
Add = True
ElseIf Len(Trim(x)) = 9 And Right(Trim(x), 1) = "'" Then
Add = True
End If
If Add Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, x)
Else
Set CopyMe = x
End If
End If
Next x
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy Destination:=Sheets(2).Range(“A1”)
End If
End Sub

Excel VBA - Find a set of characters and set as string

I have a set of descriptions that contain ID numbers arranged into a column. For example:
Column A
This is a description with the ID number in it ID12345.
This is a description ID66666 with the ID number in it.
This is ID99999 a description with the ID number in it.
The Id numbers are always in the format "IDXXXXX" I'd like to somehow trim away all the text in each of these cells and leave just that ID number.
My thoughts:
Can this be somehow done by finding a string like "ID?????" and setting that to a variable, then replacing the contents of the cell with that variable? Or by erasing all characters in a cell -except- for "ID?????"
Any help would be appreciated, thanks.
This code I wrote for you will iterate through all items in Column A. It will split all the words in each cell into an array. If the word is 7 or 8 characters long then it could potentially be an IDxxxxx. It will perform a few checks to see if it really matches an IDxxxxx syntax. In case it does it will replace the contents of the cell with just the ID dropping all the remaining text.
Sub ReplaceContentWithIDs()
Dim ws As Worksheet
Set ws = Sheets("Sheet1") ' or your sheet name
Dim rng As Range
Dim i&, lr&, j&
Dim arr
Dim str$
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
' starting from 1 - if you have headers change to 2
For i = 1 To lr
Set rng = ws.Range("A" & i)
arr = Split(CStr(rng.Value), " ")
For j = LBound(arr) To UBound(arr)
str = arr(j)
If (Len(str) = 7) Or (Len(str) = 8) Then
If (StrComp(Left(str, 2), "ID", vbTextCompare) = 0) And _
IsNumeric(Right(Left(str, 7), 5)) Then
' found it
If Len(str) = 8 Then
rng.Value = Left(str, 7)
ElseIf Len(str) = 7 Then
rng.Value = str
End If
End If
End If
Next j
Set rng = Nothing
Next i
End Sub
I took this as a challenge to my intellect, and given that it is the end of the day, after seeing the formulas by Aladdin and pgc01 on Mr Excel forums I did a little work and came up with this CSE (Array formula):
=IF(ISNUMBER(LOOKUP(9.99999999999999E+307,SEARCH({"ID0","ID2","ID3","ID4","ID5","ID6","ID7","ID8","ID9"},A1))),MID(A1,LOOKUP(9.99999999999999E+307,SEARCH({"ID0","ID2","ID3","ID4","ID5","ID6","ID7","ID8","ID9"},A1)),7),"")
I also had some luck with this CSE Array formula:
=IF(ISNUMBER(SEARCH("ID"&{1,2,3,4,5,6,7,8,9},$A$1)),MID(A$1,SEARCH("ID"&{1,2,3,4,5,6,7,8,9},$A$1),7))

Resources