I'm using the following sub, but it works only if I put in the array the string i want to use ( wat )
If I try to put in the array the cell where this string is (BZ6) the macro does not work.
In BZ6 I have =Sheet1!B8
In Sheet1B8 I have wat
Where is my mistake here?
Option Explicit
Sub SearchForString()
Dim a As Long, arr As Variant, fnd As Range, cpy As Range, addr As String
On Error GoTo Err_Execute
'populate the array for the outer loop
arr = Array("*" & "("BZ6")" & "*")
With Worksheets("Sheet8")
'outer loop through the array
For a = LBound(arr) To UBound(arr)
'locate first instance
Set fnd = .Columns("BT").Find(what:=arr(a), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not fnd Is Nothing Then
'record address of first find
addr = fnd.Address
'seed the cpy range object
If cpy Is Nothing Then Set cpy = fnd.EntireRow
Do
'build union
Set cpy = Union(cpy, fnd.EntireRow)
'look for another
Set fnd = .Columns("BT").FindNext(after:=fnd)
'keep finding new matches until it loops back to the first
Loop Until fnd.Address = addr
End If
Next a
End With
With Worksheets("sheet2")
'one stop copy & paste operation
cpy.Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "All matching data has been copied."
Debug.Print Now & " " & Err.Number & " - " & Err.Description
End Sub
Related
I have a list of around 200 names (on a sheet) that I need to try and filter (and delete) out of a data sheet. I'm struggling to get down how to set the list of names as an array so that I can filter that array under Range("E:E").AutoFilter Field:=1, Criteria1:=**Array Here**, _ and then later entirerow.delete.
This is my most recent attempt based off of other sources online, but it seems that most of them are lists that only contain 4-5 values, and I'm struggling to find anything that would be useful in putting all of the values in an array and filtering them based off of that, any help/workarounds are appreciated thank you!
Call myArrayRange
Dim rng As Range
Dim pos As Integer
Dim arr As String
Set arr = Worksheets("control").Range("K2:K10000")
Set sht = ws
With sht
Range("E:E").AutoFilter Field:=1, Criteria1:=Array(""), _
Operator:=xlFilterValues
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2:A" & LstRw).SpecialCells(xlCellTypeVisible)
rng.EntireRow.Delete
.AutoFilterMode = False
End With
End Sub
Sub myArrayRange()
lr = Worksheets("Control").Cells(Rows.Count, 11).End(xlUp).Row
Dim iAmount() As Variant
Dim iNum As Integer
iAmount = Range("K2:K" & lr)
For iNum = 1 To UBound(iAmount)
Debug.Print iAmount(iNum, 1)
Next iNum
End Sub```
EDIT: updated to match your actual use case.
Here's a basic example of how you can do it:
Sub Tester()
Dim arr, rngNames as range, ws As Worksheet
Set ws = ActiveSheet 'for example: the sheet with the data to filter
With ws.Parent.Worksheets("Control")
Set rngNames = .Range("K2:K" & .Cells(.Rows.Count, "K").End(xlUp))
End With
arr = RangeToArray(rngNames) 'get an array from the list of names
ws.Range("E:E").AutoFilter Field:=1, Criteria1:=arr, _
Operator:=xlFilterValues
ws.Autofilter.Range.SpecialCells(xlCellTypeVisible).EntireRow.Delete
ws.AutoFilterMode = False
End Sub
'convert a range to a zero-based 1D array
Function RangeToArray(rng As Range)
Dim r As Long, c As Long, arr, data, i
data = rng.Value 'get the source data
ReDim arr(0 To rng.Cells.Count - 1) 'size the output array
For r = 1 To UBound(data, 1) 'loop over the data from the range
For c = 1 To UBound(data, 2)
arr(i) = data(r, c)
i = i + 1
Next c
Next r
RangeToArray = arr
End Function
Delete Criteria Rows
Criteria
Table Before
Table After
The Code
Carefully adjust the values in the constants section.
Option Explicit
Sub DeleteCriteriaRows()
Const ProcName As String = "DeleteCriteriaRows"
Dim RowsDeleted As Boolean
Dim AnErrorOccurred As Boolean
On Error GoTo ClearError ' enable error-handling routine
' Criteria
Const cName As String = "Control"
Const cFirstCellAddress As String = "K2"
' Table
Const tName As String = "Data"
Const tFirstCellAddress As String = "A2"
Const tColumnIndex As Long = 5
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Criteria
' Reference the criteria worksheet.
Dim cws As Worksheet: Set cws = wb.Worksheets(cName)
' Reference the criteria (one-column) range.
Dim crg As Range: Set crg = RefColumn(cws.Range(cFirstCellAddress))
' Write the values from the criteria range
' to a 2D one-based one-column array.
Dim cData As Variant: cData = GetRange(crg)
' Write the unique valeus from the array to a dictionary
' (exclude error values and blanks).
Dim cDict As Object: Set cDict = DictColumn(cData)
Erase cData ' data is in the dictionary
' Write the values from the dictionary, converted to strings,
' to a 1D zero-based string array.
Dim csArr() As String: csArr = sArrDict(cDict)
Set cDict = Nothing ' data is in the string array
' Table
' Reference the table worksheet.
Dim tws As Worksheet: Set tws = wb.Worksheets(tName)
Application.ScreenUpdating = False
' Clear all table worksheet's filters.
If tws.FilterMode Then tws.ShowAllData
' Reference the table range (has headers).
Dim trg As Range: Set trg = RefCurrentRegion(tws.Range(tFirstCellAddress))
' Reference the table data range (no headers).
Dim tdrg As Range: Set tdrg = trg.Resize(trg.Rows.Count - 1).Offset(1)
' Apply the autofilter on the TABLE RANGE.
trg.AutoFilter tColumnIndex, csArr, xlFilterValues
' Attempt to reference the filtered rows (the visible rows
' of the TABLE DATA RANGE).
Dim tdfrg As Range
On Error Resume Next ' defer error trapping
Set tdfrg = tdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo ClearError ' re-enable error-handling routine
' Turn off the autofilter.
tws.AutoFilterMode = False
' Delete the filtered rows.
If Not tdfrg Is Nothing Then ' there are filtered rows...
tdfrg.Delete xlShiftUp ' ... delete them
RowsDeleted = True
'Else ' there are no filtered rows; do nothing
End If
ProcExit:
On Error Resume Next
If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
' Inform.
If AnErrorOccurred Then
MsgBox "An error occurred.", vbCritical, ProcName
Else
If RowsDeleted Then
MsgBox "Filtered rows deleted.", vbInformation, ProcName
Else
MsgBox "No filtered rows.", vbExclamation, ProcName
End If
End If
On Error GoTo 0
Exit Sub
ClearError: ' Error-Handling Routine
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
AnErrorOccurred = True
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range ('crg') whose first
' cell is defined by the first cell of the range ('FirstCell')
' and whose last cell is the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefColumn"
On Error GoTo ClearError
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values from a column ('ColumnIndex')
' of a 2D array ('Data') in the keys of a dictionary.
' Remarks: Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictColumn( _
ByVal Data As Variant, _
Optional ByVal ColumnIndex As Variant) _
As Object
Const ProcName As String = "DictColumn"
On Error GoTo ClearError
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case-insensitive
Dim c As Long
If IsMissing(ColumnIndex) Then
c = LBound(Data, 2) ' use first column index
Else
c = CLng(ColumnIndex)
End If
Dim Key As Variant
Dim r As Long
For r = LBound(Data, 1) To UBound(Data, 1)
Key = Data(r, c)
If Not IsError(Key) Then ' exclude error values
If Len(CStr(Key)) > 0 Then ' exclude blanks
dict(Key) = Empty
End If
End If
Next r
If dict.Count = 0 Then Exit Function ' only error values and blanks
Set DictColumn = dict
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Converts the values of the keys of a dictionary to strings
' and returns the strings in a 1D zero-based string array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function sArrDict( _
ByVal dict As Object) _
As String()
Const ProcName As String = "sArrDict"
On Error GoTo ClearError
If dict.Count > 0 Then
Dim sArr() As String: ReDim sArr(0 To dict.Count - 1)
Dim Key As Variant
Dim n As Long
For Each Key In dict.Keys
sArr(n) = CStr(Key)
n = n + 1
Next Key
sArrDict = sArr
Exit Function
End If
ProcExit:
' Ensure a 1D zero-based string array is returned (no matter what).
sArrDict = Split("") ' (LB=0, UB=-1)
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a reference to the range starting with the first cell
' of a range and ending with the last cell of the first cell's
' Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefCurrentRegion"
On Error GoTo ClearError
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1).CurrentRegion
Set RefCurrentRegion = FirstCell.Resize(.Row + .Rows.Count _
- FirstCell.Row, .Column + .Columns.Count - FirstCell.Column)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
This is a really dangerous way to delete things. You can't really recover the data so make sure that filter works.
Sub Button1_Click()
myArrayRange
End Sub
Sub myArrayRange()
Dim rng As Range
Dim pos As Integer
Dim sht As Worksheet
Set sht = ActiveSheet
With sht
'Your string array that holds names would go here VVVV (According to MS Docs)
Range("E:E").AutoFilter Field:=1, Criteria1:=Array(""), _
Operator:=xlFilterValues
LstRw = .Cells(.Rows.Count, "A").End(xlDown).Row
Set rng = .Range("A2:A" & LstRw).SpecialCells(xlCellTypeVisible)
rng.EntireRow.Delete
.AutoFilterMode = False
End With
End Sub
You'll have to find the sheet you need some way. I used the active sheet. Here's a screenshot of the data before and after.
I have this code that gets all file types.
Dim file as variant
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
Then I have to print it in the cells on a sheet.
For i = 1 To UBound(file)
lRow = Cells(Rows.count, 15).End(xlUp).Row
lRow = lRow + 1
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = CStr(file(i))
Next i
but what I want is first check the contents of the array. If the array has this file type, then I have to remove it in the arraylist. After that, a message will pop out that this files are removed.
dim arr() as string
arr = Split("ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|hta|inf|ins|isp|its|js|jse|" _
& "ksh|lnk|mad|maf|mag|mam|maq|mar|mas|mat|mau|mav|maw|mda|mdb|mde|mdt|mdw|mdz|msc|msh|msh1|msh2|" _
& "mshxml|msh1xml|msh2xml|ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|" _
& "hta|msi|msp|mst|ops|pcd|pif|plg|prf|prg|pst|reg|scf|scr|sct|shb|shs|ps1|ps1xml|ps2|ps2xml|psc1|psc2|tmp|url|vb|vbe|vbs|vsmacros|vsw|ws|wsc|wsf|wsh|xnk", "|")
I just don't know where I have to start. I have found a little bit same problem here in this post, but I just can't understand it. Thanks!
You can use a RegExp and a varaint array to do this quickly
This code looks for path... dot extension end string so it is more robust than your current array which may remove files based on the path name rather than file type
Sub B()
Dim fName As Variant
Dim objRegex As Object
Dim lngCnt As Long
Dim rng1 As Range
Set objRegex = CreateObject("vbscript.regexp")
On Error Resume Next
fName = Application.GetOpenFilename("All Files, *.*", , "Select file", , True)
If Err.Number <> 0 Then Exit Sub
On Error GoTo 0
With objRegex
.Pattern = ".*\.(ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|hta|inf|ins|isp|its|js|jse|" _
& "ksh|lnk|mad|maf|mag|mam|maq|mar|mas|mat|mau|mav|maw|mda|mdb|mde|mdt|mdw|mdz|msc|msh|msh1|msh2|" _
& "mshxml|msh1xml|msh2xml|ade|adp|app|asp|bas|bat|cer|chm|cmd|com|cpl|crt|csh|der|exe|fxp|gadget|hlp|" _
& "hta|msi|msp|mst|ops|pcd|pif|plg|prf|prg|pst|reg|scf|scr|sct|shb|shs|ps1|ps1xml|ps2|ps2xml|psc1|psc2|tmp|url|vb|vbe|vbs|vsmacros|vsw|ws|wsc|wsf|wsh|xnk)$"
`replace matching file types with blank array entries
For lngCnt = 1 To UBound(fName)
fName(lngCnt) = .Replace(fName(lngCnt), vbNullString)
Next
End With
Set rng1 = Cells(Rows.Count, 15).End(xlUp).Offset(1,0)
'dump array to sheet
rng1.Resize(UBound(fName), 1) = Application.Transpose(fName)
` remove blank entries
On Error Resume Next
rng1.SpecialCells(xlCellTypeBlanks).Delete xlUp
On Error GoTo 0
End Sub
One way would be to check that the extension it's not present in the blacklist with InStr:
Const exts = _
".ade.adp.app.asp.bas.bat.cer.chm.cmd.com.cpl.crt.csh.der.exe.fxp.gadget" & _
".hlp.hta.inf.ins.isp.its.js.jse.ksh.lnk.mad.maf.mag.mam.maq.mar.mas.mat" & _
".mau.mav.maw.mda.mdb.mde.mdt.mdw.mdz.msc.msh.msh1.msh2.mshxml.msh1xml" & _
".msh2xml.ade.adp.app.asp.bas.bat.cer.chm.cmd.com.cpl.crt.csh.der.exe.fxp" & _
".gadget.hlp.hta.msi.msp.mst.ops.pcd.pif.plg.prf.prg.pst.reg.scf.scr.sct" & _
".shb.shs.ps1.ps1xml.ps2.ps2xml.psc1.psc2.tmp.url.vb.vbe.vbs.vsmacros.vsw" & _
".ws.wsc.wsf.wsh.xnk."
Dim file As Variant
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
Dim i As Long, data(), count As Long, ext As String
ReDim data(1 To UBound(file) + 1, 1 To 1)
' filter the list
For i = LBound(file) To UBound(file)
ext = LCase(Mid(file(i), InStrRev(file(i), ".")))
If InStr(1, exts, ext & ".") = 0 Then ' if not blacklisted
count = count + 1
data(count, 1) = file(i)
End If
Next
' copy the filtered list to the next available row in column "O"
If count Then
With ThisWorkbook.Sheets("Main").Cells(Rows.count, "O").End(xlUp)
.Offset(1).Resize(count).Value = data
End With
End If
The code below break the cells in image 1 into an array pictured in image 2. The new array is moved to start at AG. After that the program looks through the array and finds the words 'hello' and 'bye'. It takes those words and moves them into a new sheet and column pictured in image 3. Where I'm having trouble is that I want to still pull the strings 'hello' and 'bye' but I want to also pull the string directly before it from the array. In my example (image 3) I would've wanted it to read 'John Hello' instead of 'hello' on its own. What function would I use to extract the string before 'hello' or 'bye' also from the array?
Sub SplitWithFormat()
Dim R As Range, C As Range
Dim i As Long, V As Variant
Dim varHorizArray As Variant
Dim rge As Range
Dim intCol As Integer
Dim s As String
Set R = Range("d1", Cells(Rows.Count, "d").End(xlUp))
For Each C In R
With C
.TextToColumns Destination:=.Range("AD1"), DataType:=xlDelimited, _
consecutivedelimiter:=True, Tab:=False, semicolon:=True, comma:=False, _
Space:=True, other:=True, Otherchar:=vbLf
Set rge = Selection
varHorizArray = rge
.Copy
Range(.Range("AD1"), Cells(.Row, Columns.Count).End(xlToLeft)).PasteSpecial xlPasteFormats
End With
Next C
Application.CutCopyMode = False
For intCol = LBound(varHorizArray, 2) To UBound(varHorizArray, 2)
Debug.Print varHorizArray(1, intCol)
Next intCol
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
varHorizArray = Array("hello", "bye")
Set NewSh = Worksheets.Add
With Sheets("Sheet2").Range("AD1:AZ100")
Rcount = 0
For i = LBound(varHorizArray) To UBound(varHorizArray)
Set Rng = .find(What:=varHorizArray(i), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount + 1
Rng.Copy NewSh.Range("A" & Rcount)
NewSh.Range("A" & Rcount).Value = Rng.Value
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next i
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Option Explicit
Sub Tester()
Dim c As Range, v As String, arr, x As Long, e
Dim d As Range
'EDIT: changed destination for results
Set d = WorkSheets("Sheet2").Range("D2") '<<results start here
For Each c In ActiveSheet.Range("A2:A10")
v = Trim(c.Value)
If Len(v) > 0 Then
'normalize other separators to spaces
v = Replace(v, vbLf, " ")
'remove double spaces
Do While InStr(v, " ") > 0
v = Replace(v, " ", " ")
Loop
'split to array
arr = Split(v, " ")
For x = LBound(arr) To UBound(arr)
e = arr(x)
'see if array element is a word of interest
If Not IsError(Application.Match(LCase(e), Array("hello", "bye"), 0)) Then
If x > LBound(arr) Then
d.Value = arr(x - 1) & " " & e 'prepend previous word
Else
d.Value = "??? " & e 'no previous word
End If
Set d = d.Offset(1, 0)
End If
Next x
End If
Next c
End Sub
Something like this?
Option Explicit
Sub strings()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim lookingForThese() As String
Set ws = ThisWorkbook.Worksheets(1)
Set rng = ws.Range(ws.Range("A1"), ws.Range("A1").End(xlDown))
ReDim lookingForThese(1 To 2)
lookingForThese(1) = "bye"
lookingForThese(2) = "hello"
For Each cell In rng
Dim i As Integer
Dim parts() As String
'Split the string in the cell
parts = Split(cell.Value, " ")
'I'm parsing the parts to a 2. worksheet and the hello/bye + the word before those on a 3.
For i = LBound(parts) To UBound(parts)
Dim j As Integer
ThisWorkbook.Worksheets(2).Cells(cell.Row, i + 1).Value = parts(i)
For j = LBound(lookingForThese) To UBound(lookingForThese)
If parts(i) = lookingForThese(j) Then
If i <> LBound(parts) Then
ThisWorkbook.Worksheets(3).Cells(cell.Row, 1).Value = parts(i - 1) & " " & parts(i)
Else
ThisWorkbook.Worksheets(3).Cells(cell.Row, 1).Value = parts(i)
End If
End If
Next j
Next i
Next cell
End Sub
I have this:
column A
row1: str1;str2;str3
row2: str4;str5;str6
row3: str7;str8;str9
....................
rown: strn;strn;strn
The code below finds ";" character into the column A:
Range("A:A").Find(What:=";", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
I want to put all rows (from column A, containing semicolon character) into an array. I tried to use SET, like this:
dim r as Variant
Set r = Range("A:A").Find(What:=rngsearch, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=_
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,MatchCase:=False _
, SearchFormat:=False).Activate
...but doesn't work. It's run-time error '13', type mismatch
I need this array (containing all the cells with semicolon) because I want to extract the strings (from str1 to strn) and separate them in different rows.
Can anyone help me? Maybe someone has another idea how I can do this?
There are probably more efficient ways to do this, I would personally prefer to avoid referring to an entire column, but this should hopefully do what you are expecting:
Sub test()
Dim ws As Worksheet
Dim rng As Range
Dim cel As Range
Dim strTmp As String
Dim arrFinal As Variant
Set ws = Sheets("Sheet1")
Set rng = ws.Range("A:A")
' Loop through all cells in column A
For Each cel In rng.Cells
' Is there a semicolon character in the cell?
If InStr(1, cel.Value, ";") > 0 Then
' Add the cell value to strTmp and add a _
semicolon at the end to separate this _
row from the next row
strTmp = strTmp & cel.Value & ";"
End If
Next cel
' Split strTmp into an array
arrFinal = Split(strTmp, ";")
End Sub
The end result Is an array called arrFinal of all strings between the semicolon characters
I was referring to something like this:
Sub GetSemicolonData()
Dim rngCell As Excel.Range
Dim asValues() As String
Dim lngCount As Long
Dim x As Long
With Range("A1").CurrentRegion.Columns(1)
.AutoFilter field:=1, Criteria1:="*;*"
lngCount = .SpecialCells(xlCellTypeVisible).Count
If lngCount > 1 Then
x = 1
' exclude header row
ReDim asValues(1 To lngCount - 1)
For Each rngCell In .SpecialCells(xlCellTypeVisible)
If rngCell.Row > 1 Then
' load value into array
asValues(x) = rngCell.Value
x = x + 1
End If
Next rngCell
End If
End With
End Sub
You could also use a variation of Dave's approach that loads all the data into an array and processes that - it should be faster than cell by cell reads.
Below VBA code is to find text and delete row. But it is searching based on the whole sheet.
How to I make it to only search "specific column" with the text array listed and delete the rows that contain text.
Based on the below code, it is search the whole sheet which I do not want.
Sub DeleteSystemMessage()
Dim varList As Variant
Dim varQP As Variant
Dim lngarrCounter As Long
Dim rngFound As Range, rngToDelete As Range
Dim strFirstAddress As String
Application.ScreenUpdating = False
'delete system message
varList = VBA.Array("XXXXXX", vbTextCompare)
For lngarrCounter = LBound(varList) To UBound(varList)
With Sheet1.UsedRange
Set rngFound = .Find( _
What:=varList(lngarrCounter), _
Lookat:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rngFound Is Nothing Then
strFirstAddress = rngFound.Address
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
If Application.Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
End If
Set rngFound = .FindNext(After:=rngFound)
Do Until rngFound.Address = strFirstAddress
If Application.Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
Set rngFound = .FindNext(After:=rngFound)
Loop
End If
End With
Next lngarrCounter
If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
If you change your search code like this it will only search in the column "A".
Set rngFound = Sheets(1).Columns("A:A").Find( _
What:=varList(lngarrCounter), _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)