I am trying to loop through an array and, when it finds a cell which is not equal a specific value, it deletes the entire row. Here is the code:
Sub DeleteTest()
Dim crr()
crr = Range("A3:A1000")
For i = LBound(crr, 1) To UBound(crr, 1)
If (crr(i, 1) <> "One" And crr(i, 1) <> "Two") Then
' Line to delete the row in which the value of the cell is not One or Two
End If
Next
End Sub
I know I can also do it with an Autofilter, but I would like to know the way to do it with the array.
Here's one way:
Sub DeleteTest()
Dim rng As Range, crr(), i As Long
Set rng = Range("A3:A1000")
crr = rng.Value
For i = UBound(crr, 1) To LBound(crr, 1) Step -1 '<<< loop backwards
If (crr(i, 1) <> "One" And crr(i, 1) <> "Two") Then
rng.Cells(i).EntireRow.Delete
End If
Next
End Sub
Try this code
Sub Test()
Dim x, r As Range
With ThisWorkbook.Sheets("Sheet1")
Set r = .Range("A3:A1000")
x = Filter(.Evaluate("TRANSPOSE(IF((" & r.Address & "=""One"")+(" & r.Address & "=""Two""),""A"" & ROW(" & r.Address & ")))"), False, False)
If UBound(x) = -1 Then Exit Sub
.Range(Join(x, ",")).EntireRow.Hidden = True
On Error Resume Next
r.SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
.Rows.Hidden = False
End With
End Sub
Related
I'm trying to simplify the following code into one loop only. How can I do that?
Dim VARIANTE as LONG
For Each cell In Sheets("Libro2").Range("C1:C30000")
If cell.Value = Sheets("Libro1").Range("AA1") Then
VARIANTE = cell.Row
Sheets("Libro2").Range("Z" & VARIANTE) = 1
End If
Next
For Each cell In Sheets("Libro2").Range("C1:C30000")
If cell.Value = Sheets("Libro1").Range("AA2") Then
VARIANTE = cell.Row
Sheets("Libro2").Range("Z" & VARIANTE) = 1
End If
Next
For Each cell In Sheets("Libro2").Range("C1:C30000")
If cell.Value = Sheets("Libro1").Range("AA3") Then
VARIANTE = cell.Row
Sheets("Libro2").Range("Z" & VARIANTE) = 1
End If
Next
[...] 'and so on, and so forth
Here is something I've tried, but it didn't work, of course. Maybe there is a solution out there, but I couldn't find it because of language issues.
For Each cell In Sheets("Libro2").Range("C1:C30000")
If cell.Value = Sheets("Libro1").Range("AA1:AA50") Then
VARIANTE = cell.Row
Sheets("Libro2").Range("Z" & VARIANTE) = 1
End If
Next
Please, try the next code:
Sub testLoopCols()
Dim sh As Worksheet, shL As Worksheet, rngAA As Range, arrC, arrZ, i As Long, mtch
Set sh = ActiveSheet 'use here the sheet you need
Set shL = Sheets("Libro1")
arrC = sh.Range("C1:C30000").value 'place the range in an array for faster iteration
arrZ = sh.Range("Z1:Z30000").value 'place the range to return (using an array)
Set rngAA = shL.Range("AA1:AA50") 'the range where to match each cell of C:C range
For i = 1 To UBound(arrC)
mtch = Application.match(arrC(i, 1), rngAA, 0) 'match in a range = much faster than in an array...
If Not IsError(mtch) Then 'if a match exists:
arrZ(i, 1) = 1 'place 1 in the final array
End If
Next i
'drop the processed array result, at once:
sh.Range("Z1:Z30000").value = arrZ
MsgBox "Ready..."
End Sub
This solution is what so brilliantly BigBen, in only one sentence, answered my question inmediately, and which I'm enterily grateful.
For Each cell In Sheets("Libro2").Range("C1:C30000")
If WorksheetFunction.CountIf(Sheets("concat").Range("AD20951:AD20956"), cell.Value) > 0 Then
VARIANTE = cell.Row
Sheets("Libro2").Range("Z" & VARIANTE) = 1
End If
Next
Previous Record and Next Record sub routine is not working. I marked with 1 and 2. These two navigation bars (1&2) works on the what is entered on WaypointId.
Say for example, if I say waypoint id=1235, then next record should appear in a data entry form. My vba code is first search the row number of waypoint id in observation sheet and then I decrease the row number by 1 for displaying previous record and increase the row number by 1 for next record. Depends on the functionality it shows data in the Data Entry Form.
My VBA code is not working for those two things. Attach workbook with name Problem-1.xlsm See Navigation Control Module.
Sub FindRecord(WyPt)
Dim Value As String
WyPtRow = 0
ReadRow = 2
Value = Cells(ReadRow, 2)
While Value <> ""
If WyPt = Value Then
WyPtRow = ReadRow
Exit Sub
End If
ReadRow = ReadRow + 1
Value = Cells(ReadRow, 2)
Wend
End Sub
Sub ViewPreviousRecord()
Set DEFrm = Sheets("DataEntryForm")
Set ObsData = Sheets("Observations")
Dim WyPt As String
WyPt = Trim(DEFrm.Cells(6, 2))
Call FindRecord(WyPt)
LastRow = WyPtRow - 1
With DEFrm
.Cells(6, 2).Value = ObsData.Cells(LastRow, 2).Value 'WaypointID
.Cells(6, 4).Value = ObsData.Cells(LastRow, 3).Value 'ObsType
.Cells(8, 2).Value = ObsData.Cells(LastRow, 4).Value 'Date
.Cells(8, 4).Value = ObsData.Cells(LastRow, 5).Value 'LoggedBy
End With
End Sub
Sub ViewNextRecord()
Set DEFrm = Sheets("DataEntryForm")
Set ObsData = Sheets("Observations")
Dim WyPt As String
WyPt = Trim(DEFrm.Cells(6, 2))
Call FindRecord(WyPt)
LastRow = WyPtRow + 1
With DEFrm
.Cells(6, 2).Value = ObsData.Cells(LastRow, 2).Value 'WaypointID
.Cells(6, 4).Value = ObsData.Cells(LastRow, 3).Value 'ObsType
.Cells(35, 10).Value = ObsData.Cells(LastRow, 115) 'Photo4Desc
End With
End Sub
This is the most important procedure in your project.
Sub DisplayRecord(ByVal Rs As Long)
' 235
Dim Arr As Variant ' Data from row Rs in database
Dim Target() As String ' Dashboard addresses matching Arr
Dim i As Long ' loop counter: Arr(Index)
' cell addresses are aligned with column numbers in database (-2)
Arr = "B6,D6,B8,D8,G6,H6,G7,H7,G8,H8,B11,C11,D11,E11,F11,G11,H11,I11"
Arr = Arr & ",B14,C14,D14,E14,F14,G14,B17,C17,D17,E17,F17,G17"
Arr = Arr & ",I14,J14,I15,J15,I16,J16,I17,J17,B20,C20,D20,E20,F20,G20"
Arr = Arr & ",B23,C23,D23,E23,F23"
Arr = Arr & ",I20,J20,K20,I21,J21,K21,I2,J22,K22,I23,J23,K23"
Arr = Arr & ",B26,C26,D26,E26,F26,G26,H26,I26,J26,K26"
Arr = Arr & ",B27,C27,D27,E27,F27,G27,H27,I27,J27,K27"
Arr = Arr & ",B28,C28,D28,E28,F28,G28,H28,I28,J28,K28"
Arr = Arr & ",B29,C29,D29,E29,F29,G29,H29,I29,J29,K29"
Arr = Arr & ",B32,H32,I32,J32,H33,I33,J33,H34,I34,J34,H35,I35,J35"
Target = Split(Arr, ",")
With Sheets("Observations")
Arr = .Range(.Cells(Rs, 1), .Cells(Rs, 115)).Value
End With
Application.ScreenUpdating = False ' speed up execution
For i = 2 To UBound(Arr, 2) ' skip first database column
Sheets("DataEntryForm").Range(Target(i - 2)).Value = Arr(1, i)
Next i
Application.ScreenUpdating = True
End Sub
It displays the data of the row Rs given to it as an argument. You already have a function that finds the row number needed by the above procedure. Below please find an improvement.
Function RecordRow(ByVal WyPt As String) As Long
' 235
' return the row number where WyP was found or 0
Dim Fnd As Range
With Worksheets("Observations")
Set Fnd = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp))
Set Fnd = Fnd.Find(WyPt, , LookIn:=xlValues, lookat:=xlWhole)
If Not Fnd Is Nothing Then
RecordRow = Fnd.Row
End If
End With
End Function
The deal is simple: you give the Waypoint ID and receive the row number where it was found. If it isn't found the function returns 0, and that is how you avoid crashes.
With these two procedures in place you can easily call up the first and the last records.
Sub ViewFirstRecord()
' 235
DisplayRecord 2
End Sub
Sub ViewLastRecord()
' 235
With Worksheets("Observations")
DisplayRecord .Cells(.Rows.Count, "A").End(xlUp).Row
End With
End Sub
The next and previous records are just a matter of finding the row number and displaying its data.
Sub ViewNextRecord()
' 235
Dim Rs As Long ' data source row
Rs = RecordRow(Trim(Cells(6, 2).Value)) + 1
If Rs > 1 Then
With Worksheets("Observations")
If Rs <= .Cells(.Rows.Count, "A").End(xlUp).Row Then
DisplayRecord Rs
Else
MsgBox "No more records to show.", vbInformation, "Last record"
End If
End With
End If
End Sub
Sub ViewPreviousRecord()
' 235
Dim Rs As Long ' data source row
Rs = RecordRow(Trim(Cells(6, 2).Value)) - 1
If Rs > 1 Then
DisplayRecord Rs
Else
MsgBox "No more records to show.", vbInformation, "First record"
End If
End Sub
If that's the whole code, you may be finding a problem with scope. It seems ViewPreviousRecord() is not able to see WyPtRow.
You can try adding
dim WyPtRow
Before the Sub FindRecord(WyPt) definition.
Another implementation would be changing the Sub for a function, and returning the WyPtRow value.
I have tried this code which works fine for a cell that only contain number:
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Range("A1").Value = Range("A1") + 1
End Sub
How can I do something similar if the cell has text and a number. For example, I have "Apple 1" and I want to "increase" the cell text to "Apple 2" and next time I run the macro I want "Apple 3".
Here's another way you could solve this problem:
Sub IncreaseCellValue()
Dim value As Variant
'Add 1 to the existing cell value
If IsNumeric(Range("A1").value) Then
Range("A1").value = Range("A1") + 1
Else
value = Split(Range("A1").value, " ")
Range("A1").value = value(0) & " " & (CInt(value(1)) + 1)
End If
End Sub
It will cover the 2 cases you presented in your question but not every scenario you could throw at it.
Try using the following function
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Range("A1").Value = Replace(Range("A1").Value2, CleanString(Range("A1")), vbNullString) & CInt(CleanString(Range("A1").Value2)) + 1
End Sub
Function CleanString(strIn As String) As String
Dim objRegex
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "[^\d]+"
CleanString = .Replace(strIn, vbNullString)
End With
End Function
please check:
Option Explicit
Sub IncreaseCellValue()
'Add 1 to the existing cell value
Dim rg As Range
Set rg = Cells(Rows.Count, "A").End(xlUp)
Range("A1" & ":" & rg.Address).AutoFill Destination:=Range("A1" & ":" & rg.Offset(1, 0).Address), Type:=xlFillDefault
End Sub
Or you may try something like this...
Function GetNumber(ByVal rng As Range) As Long
Dim i As Long
For i = Len(rng.Value) To 1 Step -1
If IsNumeric(Mid(rng.Value, i, 1)) Then
GetNumber = GetNumber & Mid(rng.Value, i, 1)
Else
Exit For
End If
Next i
End Function
Sub IncrementNumber()
Dim num As Long
num = GetNumber(Range("A1"))
Range("A1").Value = Replace(Range("A1").Value, num, num + 1)
End Sub
I am trying to build a collection and take the Count of Unique Values from that Collection but am getting an error in building a Collection itself. Can anyone suggest me where I am going wrong. Kindly Share your thoughts. Please let me know how to find out the COUNT of UNIQUE VALUES as well.
Sub trial()
Dim sampleVisualBasicColl As Collection
For i = 2 To 10
Rng = Range("M" & i).value
StartsWith = Left(Rng, 3)
If StartsWith = "Joh" Then
sampleVisualBasicColl.Add Rng
Else
End If
Next
Debug.Print (sampleVisualBasicCol1)
End Sub
Using a collection you can just add Joh to the collection and then count the items:
'Using a collection
Sub Col_test()
Dim cCol As Collection
Dim i As Long
Set cCol = New Collection
On Error GoTo Err_Handler
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Left(.Cells(i, 13), 3) = "Joh" Then
cCol.Add .Cells(i, 13).Value, .Cells(i, 13).Value
End If
Next i
End With
Debug.Print cCol.Count
On Error GoTo 0
Exit Sub
Err_Handler:
Select Case Err.Number
Case 457 'This key is already associated with an element of this collection
Err.Clear
Resume Next
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure Col_test."
Err.Clear
End Select
End Sub
If you want the count of each item (Joh, Ben... whatever else you have) then use a dictionary:
'Using a dictionary.
Sub Dic_Test()
Dim dict As Object
Dim i As Long
Dim sValue As String
Dim key As Variant
Set dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Len(.Cells(i, 13)) >= 3 Then
sValue = Left(.Cells(i, 13), 3)
If dict.exists(sValue) Then
dict(sValue) = dict(sValue) + 1
Else
dict(sValue) = 1
End If
End If
Next i
End With
For Each key In dict.keys
Debug.Print key & " = " & dict(key)
Next key
End Sub
Note: I'm using Cells within the code rather than Range. Cells(2,13) is M2 (13th column, 2nd row).
I find this link very helpful with dictionaries: https://excelmacromastery.com/vba-dictionary/
As a further update (after answer accepted) and using the lists you gave in your question here: Excel VBA - Formula Counting Unique Value error this code with dictionaries will return Joh = 4, Ian = 3
'Using a dictionary.
Sub Dic_Test()
Dim dict As Object
Dim dictFinal As Object
Dim i As Long
Dim sValue As String
Dim key As Variant
Dim keyFinal As String
Set dict = CreateObject("Scripting.Dictionary")
Set dictFinal = CreateObject("Scripting.Dictionary")
'Get the unique values from the worksheet.
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Len(.Cells(i, 13)) >= 3 Then
sValue = .Cells(i, 13).Value
If dict.exists(sValue) Then
dict(sValue) = dict(sValue) + 1
Else
dict(sValue) = 1
End If
End If
Next i
End With
'Count the unique values in dict.
For Each key In dict.keys
keyFinal = Left(key, 3)
If dictFinal.exists(keyFinal) Then
dictFinal(keyFinal) = dictFinal(keyFinal) + 1
Else
dictFinal(keyFinal) = 1
End If
Next key
For Each key In dictFinal.keys
Debug.Print key & " = " & dictFinal(key)
Next key
End Sub
You need to create the collection as well as declaring it.
Sub trial()
Dim myCol As Collection
Set myCol= New Collection ' creates the collection
For i = 2 To 10
Rng = Range("M" & i).value
StartsWith = Left(Rng, 3)
If StartsWith = "Joh" Then
myCol.Add Rng
Else
End If
Next
For each x in myCol
Debug.Print x
Next x
End Sub
Hey this code will help u since it's collecting Unique values in Listbox,,
Private Sub UserForm_Initialize()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Set sh = ThisWorkbook.Sheets("Sheet1")
Set Rng = sh.Range("A2", sh.Range("A2").Value ="John". End(xlDown))
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
Me.ListBox1.AddItem vNum
Next vNum
End Sub
You have not declared Variable Rng & i these are the most important thing to do. Meanwhile I would like to suggest this Formula,,
=Sum(if(Frequency (if(Len(B2 :B20) >0,Match(B2 :B20, B2 :B20, 0),""),if(Len(B2 :B20) >Match(B2 :B20, B2 :B20, 0),"",))>0,1))
Its Array formula so finish with Ctrl +shift +enter.
You can use this one also,
Sub CountUnique()Dim i, count, j As Integer count = 1 For i = 1 To 470 flag = False If count
1 Then For j = 1 To count If Sheet1.Cells(i,
3).Value = Sheet1.Cells(j, 11).Value Then flag
= True End If Next j Else flag = False End If If flag = False Then Sheet1.Cells(count,
11 ).Value = Sheet1.Cells(i, 3).Value count = count + 1 End IfNext i Sheet1.Cells( 1 ,
15 ).Value = count End Sub
First off thank you very much. Over the last few months (i believe) my coding has progressed drastically. Any and all criticize is always welcome (rip me apart).
Recently I started to try to use different Subs (I dont quite understand when to use functions etc, but i figure it is good structure practice for when i figure it out.
I am hitting a Run-time 424 Error with the following bit of code in Sub ownerCHECK
Sub OccupationNORMALIZATION()
Dim infoBX As String
' initialize variables
LRow = ActiveSheet.UsedRange.Rows.Count
LCol = ActiveSheet.UsedRange.Columns.Count
STATUScounter = LRow
Do While infoBX = ""
infoBX = InputBox("Enter Occupation Column", "Occupation Column")
Loop
restaurCHECK (infoBX)
Application.ScreenUpdating = True
Application.StatusBar = ""
End Sub
-
Sub restaurCHECK(infoBX As String)
Dim RestaurantS(), RestaurantDQs() As Variant
Dim i, LRow, LCol, STATUScounter As Long
Dim rRng As Range
LRow = ActiveSheet.UsedRange.Rows.Count
LCol = ActiveSheet.UsedRange.Columns.Count
STATUScounter = LRow
RestaurantS = Array("estaur", "food", "cafe", "beverage", "waiter", "waitr", _
"waitstaff", "wait staff", "grill") 'array list of target occupations
RestaurantDQs = Array("fast", "pub", "import", "packing", "processing", "packag", _
"retired", "anufact", "distrib") ' disqualifying words for Restaurante category
Set rRng = Range(infoBX & "2:" & infoBX & LRow)
Application.ScreenUpdating = False
For Each cell In rRng
ownerCHECK (cell)
For i = LBound(RestaurantS) To UBound(RestaurantS)
If InStrRev(cell.Value, UCase(RestaurantS(i))) > 0 Then
cell.Offset(, 1) = "Restaurants"
cell.Interior.Color = 52479
End If
Debug.Print cell.Value
Next
For i = LBound(RestaurantDQs) To UBound(RestaurantDQs)
If InStrRev(cell.Value, UCase(RestaurantDQs(i))) And cell.Interior.Color = 52479 Then
cell.Interior.Color = 255
cell.Offset(, 1) = ""
End If
Next
STATUScounter = STATUScounter - 1
Application.StatusBar = "REMAINING ROWS " & STATUScounter & " tristram "
Next cell
End Sub
-
Sub ownerCHECK(str_owner As Range)
Dim owner() As Variant
owner() = Array("owner", "shareholder", "owns ")
For i = LBound(owner) To UBound(owner)
If InStrRev(str_owner, UCase(owner(i))) > 0 Then
cell.Offset(, 2) = "Owner"
End If
Next
End Sub
I can see a couple of issues in ownerCHECK():
"cell" is not defined (unless it's global)
you shouldn't use "cell" as a variable name (internal VBA property)
check validity of incoming range
.
Option Explicit
Sub ownerCHECK(ByRef rngOwner As Range)
If Not rngOwner Is Nothing Then
Dim owner() As Variant
owner() = Array("OWNER", "SHAREHOLDER", "OWNS ")
For i = LBound(owner) To UBound(owner)
If InStrRev(UCase(rngOwner), owner(i)) > 0 Then
rngOwner.Offset(, 2) = "Owner"
End If
Next
End If
End Sub