Error 5 in text field change - vba

I'm updating and populating a combobox named textoControles after updating another combobox named textoCausas. The first combobox textoControles upadtes itself with its change.
Now, I'm getting error '5' in this scenario:
If I have the table ActiveSheet.Name with no data (empty) and enter data into combobox textoCausas, and then enter a character (just entering any character) on textoCausas, then the error '5' stops the macro.
But, if the table ActiveSheet.Name has any data in the first column and I enter data into textoCausas no error stops the macro.
I need some help to solve this error. Thanks!
Private Sub textoCausas_AfterUpdate()
Dim ws As Worksheet, controles As Range, planes As Range, utlimafila As Double, numeroCausa As Double, C As Range
Set ws = Worksheets(ActiveSheet.Name)
ultimafila = ws.ListObjects(ActiveSheet.Name).Range.Columns(11).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If ultimafila <> 8 Then
With Me.textoControles
.Clear
If Not IsError(Application.Match(Me.textoCausas.Value, ws.ListObjects(ActiveSheet.Name).ListColumns(1).DataBodyRange, 0)) Then
Set C = ws.ListObjects(ActiveSheet.Name).ListColumns(1).DataBodyRange.Find(textoCausas.Value, LookIn:=xlValues, lookat:=xlWhole)
index = C.Row
numeroCausa = ws.Cells(index, 11)
For Each controles In ws.ListObjects(ActiveSheet.Name).ListColumns(2).DataBodyRange
If controles.Columns(10) = numeroCausa Then
If controles.Value <> Empty Then
.AddItem controles.Value
.List(.ListCount - 1, 1) = controles.Offset(0, 1).Value
End If
End If
Next controles
End If
End With
With Me.textoPlanes
.Clear
If Not IsError(Application.Match(Me.textoCausas.Value, ws.ListObjects(ActiveSheet.Name).ListColumns(1).DataBodyRange, 0)) Then
Set C = ws.ListObjects(ActiveSheet.Name).ListColumns(1).DataBodyRange.Find(textoCausas.Value, LookIn:=xlValues, lookat:=xlWhole)
index = C.Row
numeroCausa = ws.Cells(index, 11)
For Each planes In ws.ListObjects(ActiveSheet.Name).ListColumns(6).DataBodyRange
If planes.Columns(6) = numeroCausa Then
If planes.Value <> Empty Then
.AddItem planes.Value
.List(.ListCount - 1, 1) = planes.Offset(0, 1).Value
End If
End If
Next planes
End If
End With
End If
Me.textoControles = Null
Me.textoPlanes = Null
End Sub
Private Sub textoControles_Change()
Dim ws As Worksheet, C As Range, C2 As Range
Set ws = Worksheets(ActiveSheet.Name)
Me.textoEfectividad = Null
Me.textoFrecuencia = Null
Me.textoResponsable = Null
If Trim(Me.textoControles.Value & vbNullString) = vbNullString Then
Me.textoEfectividad = Null
Me.textoFrecuencia = Null
Me.textoResponsable = Null
Exit Sub
End If
If Not IsError(Application.Match(Me.textoControles.Value, ws.ListObjects(ActiveSheet.Name).ListColumns(2).DataBodyRange, 0)) Then
Set C = ws.ListObjects(ActiveSheet.Name).ListColumns(2).DataBodyRange.Find(textoControles.Value, LookIn:=xlValues, lookat:=xlWhole)
index = C.Row
Set C2 = ws.ListObjects(ActiveSheet.Name).ListColumns(11).DataBodyRange.Find(ws.Cells(index, 11), LookIn:=xlFormulas, lookat:=xlWhole, SearchDirection:=xlPrevious) 'xlFormulas para buscar en celdas ocultas
index2 = C2.Row
For i = index To index2
If ws.Cells(i, 2) = Me.textoControles Then
Me.textoEfectividad = ws.Cells(i, 3)
Me.textoFrecuencia = ws.Cells(i, 4)
Me.textoResponsable = ws.Cells(i, 5)
Exit For
End If
Next i
End If
End Sub

It's the IsError function. In VBA it tells if a variant has the value vbError. I wanted to say this yesterday but I couldn't replicate the error. It doesn't seem to result from the Match function. Perhaps, the ListObject doesn't exist on a blank sheet causing an error to occur which doesn't assign a value of vbError to the variant resulting from the test. So, the thing to do is to assign Application.Match(Me.textoControles.Value, ws.ListObjects(ActiveSheet.Name).ListColumns(2).DataBodyRang‌​e to a temporary variable. Precede the line with On Error Resume Next and follow it with If Err Then, and your problem should go away.

Related

VBA Index Marco can not auto fill data if the last row of Colum A is blank

I am having a issue to auto fill data from another sheet, I am trying to enter "sku" Value in Sheet(Report), then auto fill both "Store name" & "qty" from another Sheet(SOH). However, if the last row of the "store name" (Column A, Report Sheet) = Blank, this Marco will not working properly, otherwise it is working fine. Did I miss something? Any help would be greatly appreciated!!
Sub Fill_Report()
Dim d, s As Long
Dim sQTY As Double
Dim dws, sws As Worksheet
Set dws = ThisWorkbook.Worksheets("Report") 'Destination Sheet
Set sws = ThisWorkbook.Worksheets("SOH") 'Source Sheet
dlr = dws.Cells(Rows.Count, 1).End(xlUp).Row
slr = sws.Cells(Rows.Count, 1).End(xlUp).Row
For d = 2 To dlr
For s = 2 To slr
ssku = sws.Cells(s, "A:A").Value
dsku = dws.Cells(d, "B:B").Value
'Index qty from source
sQTY = Application.IfError(Application.Index(Sheets("SOH").Range("A:Z"), _
Application.Match(ssku, Sheets("Report").Range("B:B"), 0), 2), 0)
'add title
dws.Cells(1, 1).Value = "Sotre Name"
dws.Cells(1, 2).Value = "sku"
dws.Cells(1, 3).Value = "qty"
If dsku = ssku Then
dws.Cells(d, "A").Value = "ABC"
dws.Cells(d, "C").Value = sQTY
Exit For
End If
Next s
Next d
End Sub
Collections and Dictionaries are optimized for fast lookups. Consider using them over Match and Index.
Range("A1").CurrentRegion will select the entire range of contiguous cells.
Sub Fill_Report()
Dim Quantities As New Collection
Set Quantities = getSKUQuantity
Dim Data As Variant
Data = wsReport.Range("A1").CurrentRegion.Columns("B").Offset(1)
Dim r As Long
Dim QTY As Double
For r = r To UBound(Data)
On Error Resume Next
QTY = Quantities(Data(r, 1))
If Err.Number = 0 Then
Data(r, 1) = QTY
Else
Data(r, 1) = ""
End If
On Error GoTo 0
Next
wsReport.Range("A1").CurrentRegion.Columns("C").Offset(1).Value = Data
End Sub
Function getSKUQuantity() As Collection
Dim Data As Variant
Data = wsSOH.Range("A1").CurrentRegion
Dim Quantities As New Collection
Dim r As Long
For r = 2 To UBound(Data)
On Error Resume Next
If Err.Number = 0 Then
Quantities.Add Data(r, 2), CStr(Data(r, 1))
Else
Debug.Print "Duplicate SKU: ", Data(r, 1)
End If
On Error GoTo 0
Next
Set getSKUQuantity = Quantities
End Function
Function wsSOH() As Worksheet
Set wsSOH = ThisWorkbook.Sheets("SOH")
End Function
Function wsReport() As Worksheet
Set wsReport = ThisWorkbook.Sheets("Report")
End Function

listbox.Additems from single column based on search value from multiple columns range

I am trying to add value from column D only but if search value is from D, E or F column the offset function adds item from subsequent column. Only column D value needs to be added to the listbox.
The Do loop searches fetches the value but not sure how to fetch values only from specific column.
Please help:
If Len(txtSearchItem.Value) > 3 Then
Dim rFind, rng, rngdb As Range
Dim i, j As Integer
Dim strItem As String
With ActiveWorkbook.Sheets("DB").Columns("C:F")
Set rFind = .Find(What:=Me.txtSearchItem.Value, lookat:=xlPart, MatchCase:=False, SearchFormat:=False)
Me.lstItem.Clear
If Not rFind Is Nothing Then
i = rFind.Row 'rFind.Column & ", Row: " & rFind.Row
Me.lblDBDescription = xlshdb.Cells(i, 3).Value
'Me.txtItem.Value = xlshdb.Cells(i, 4).Value
'*****Show the Item list's in list box ****
With xlshdb.Range("C:C")
Set rng = .Cells(LRow)
End With
Set rngdb = xlshdb.Range("C:F").Find(What:=Me.txtSearchItem.Value, After:=rng, LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, MatchCase:=False)
If Not rngdb Is Nothing Then
FirstAddr = rngdb.Address
Do Until rngdb Is Nothing
'Debug.Print rngdb.Address
Set rngdb = xlshdb.Range("C:F").FindNext(After:=rngdb)
Me.lstItem.AddItem rngdb.Offset(0, 1)
If rngdb.Address = FirstAddr Then
Exit Do
End If
Loop
If Me.lstItem.ListCount > 1 Then
Me.txtItem.Visible = False
Me.lstItem.Visible = True
Me.lstItem.Selected(0) = True
Else
Me.lstItem.Visible = False
Me.txtItem.Visible = True
Me.txtItem.Value = xlshdb.Cells(i, 4).Value
End If
Else
Me.lstItem.Clear
Me.lstItem.Visible = False
Me.txtItem.Visible = True
Me.txtItem.Value = xlshdb.Cells(i, 4).Value
End If
Else
Me.lstItem.Clear
Me.lstItem.Visible = False
Me.txtItem.Visible = True
Me.lblDBDescription = ""
Me.txtItem = ""
End If
End With
End if
Will just make an answer so there is one.
Simply change the line:
Me.lstItem.AddItem rngdb.Offset(0, 1)
To:
Me.lstItem.AddItem .cells(rngdb.row, 4)
We grab the row value of the found cell and use it as our row in the .Cells range.

Error when trying to cycle through Autofiltered Cells using vba

I'm using the below code to remove invalid instances of text, in this case statements starting with colons. I know all of the steps I need to take, but I'm having issues after Autofitering. I've tried iterating through the visible cells using
for x=1 to currentFilter.rows.count
and
for each x in currentFilter.rows
But regardless of how I've tried I keep receiving some sort of error when trying to get rid of the the first character (the colon) by using (basic gist):
Cell Value = Right(Cell Value, Len(Cell Value) - InStr(Cell Value, ",", vbTextCompare))
My full code is as follows:
Sub PRTCheck()
'Column AN is Production Time & Column AP is Rush Time
Dim endRange As Integer, ShipandRush As Range, CommaColons As Collection, cell, i
endRange = ActiveSheet.Cells(Rows.count, "AN").End(xlUp).Row
Set ShipandRush = Union(ActiveSheet.Range("AN2:AN" & endRange), ActiveSheet.Range("AP2:AP" & endRange))
ShipandRush.NumberFormat = "#"
Set CommaColons = FindAllMatches(ShipandRush, ",:")
If Not CommaColons Is Nothing Then
Dim times() As String
For Each cell In CommaColons
times = Split(cell.Value, ",")
For i = LBound(times) To UBound(times)
If InStr(times(i), ":") = 1 Then times(i) = ""
Next
cell.Value = Join(times, ",")
Do While InStr(cell.Value, ",,") <> 0
cell.Value = Replace(cell.Value, ",,", ",", vbTextCompare)
Loop
If InStr(cell.Value, ",") = 1 Then
cell.Value = Right(cell.Value, Len(cell.Value) - 1)
End If
If InStr(Len(cell.Value), cell.Value, ",") = Len(cell.Value) Then
cell.Value = Left(cell.Value, Len(cell.Value) - 1)
End If
Next cell
End If
Set ShipandRush = ActiveSheet.Range("AN1:AN" & endRange)
Dim currentFilter As Range, r
ShipandRush.AutoFilter Field:=1, Criteria1:=":*" 'Starts with colon
Set currentFilter = ShipandRush.Offset(1).SpecialCells(xlCellTypeVisible)
If currentFilter.Rows.count > 0 Then
For r = 1 To currentFilter.Rows.count
'-------Error occurs on the next line-------
currentFilter.Cells(r).Value = Right(currentFilter.Cells(r).Value, Len(currentFilter.Cells(r).Value) - InStr(currentFilter.Cells(r).Value, ",", vbTextCompare))
Next
End If
ActiveSheet.AutoFilterMode = False
End Sub
'Custom find and replace that circumvents 255 character find limitation
Function FindAllMatches(rng As Range, txt As String) As Collection
Dim rv As New Collection, f As Range, addr As String, txtSrch As String
Dim IsLong As Boolean
IsLong = Len(txt) > 250
txtSrch = IIf(IsLong, Left(txt, 250), txt)
Set f = rng.Find(what:=txtSrch, lookat:=xlPart, LookIn:=xlValues, MatchCase:=False)
Do While Not f Is Nothing
If f.Address(False, False) = addr Then Exit Do
If Len(addr) = 0 Then addr = f.Address(False, False)
'check for the *full* value (case-insensitive)
If InStr(1, f.Value, txt, vbTextCompare) > 0 Then rv.Add f
Set f = rng.FindNext(After:=f)
Loop
Set FindAllMatches = rv
End Function
My Question:
What am I doing wrong? How can I iterate through each value in the visible cells and perform the formula I noted above successfully?
You are really only dealing with a single column but I will try to stick with your method of looping through the rows instead of the cells which in this instance are essentially the same thing (although Range.Rows is not the same thing as Range.Cells).
Discontiguous ranges need to be cycled through by their Range.Areas property first and then the Range.Rows property within each area.
dim a as long, r as long
with currentFilter
If .Rows.count > 0 Then
for a = 1 to .Areas.count
For r = 1 To .Areas(a).Rows.count
.Areas(a).Rows(r).Cells(1).Value = _
Right(.Areas(a).Rows(r).Cells(1).Value, _
Len(.Areas(a).Rows(r).Cells(1).Value) - _
InStr(1, .Areas(a).Rows(r).Cells(1).Value, ","))
Next r
Next a
End If
end with
It may be simpler to just use a For Each ... Next.
dim cfr as range
with currentFilter
for each cfr in .Cells
cfr = Right(cfr.Value, Len(cfr.Value) - InStr(1, cfr.Value, ","))
Next cfr
end with

Add unique number to excel datasheet using VBA

I have two columns of numbers, together they will be unique (composite key). I would like to create an unique ID number (third column) similar to how MS Access would use a primary key. I would like to do this in VBA but I am stuck on how to do it.
My VBA in excel isn't very good so hopefully you can see what I've started to attempt. it may be completely wrong... I don't know?
I don't know how to make the next concatenation and I am unsure about how to go down to the next row correctly.
Sub test2()
Dim var As Integer
Dim concat As String
concat = Range("E2").Value & Range("F2").Value
var = 1
'make d2 activecell
Range("D2").Select
Do Until concat = ""
'if the concat is the same as the row before we give it the same number
If concat = concat Then
var = var
Else
var = var + 1
End If
ActiveCell.Value = var
ActiveCell.Offset(0, 1).Select
'make the new concatination of the next row?
Loop
End Sub
any help is appreciated, thanks.
Give the code below a try, I've added a loop which executes for each cell in the E Column. It checks if the concat value is the same as the concat value in the row above and then writes the id to the D cell.
Sub Test2()
Dim Part1 As Range
Dim strConcat As String
Dim i As Long
i = 1
With ThisWorkbook.Worksheets("NAME OF YOUR SHEET")
For Each Part1 In .Range(.Cells(2, 5), .Cells(2, 5).End(xlDown))
strConcat = Part1 & Part1.Offset(0, 1)
If strConcat = Part1.Offset(-1, 0) & Part1.Offset(-1, 1) Then
Part1.Offset(0, -1).Value = i
Else
i = i + 1
Part1.Offset(0, -1).Value = i
End If
Next Part1
End With
End Sub
Something like this should work, this will return a Unique GUID (Globally Unique Identifier):
Option Explicit
Sub Test()
Range("F2").Select
Do Until IsEmpty(ActiveCell)
If (ActiveCell.Value <> "") Then
ActiveCell.Offset(0, 1).Value = CreateGUID
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Public Function CreateGUID() As String
CreateGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function
If you walk down column D and examine the concatenated values from column E and F with the previous row, you should be able to accomplish your 'primary key'.
Sub priKey()
Dim dcell As Range
With Worksheets("Sheet12")
For Each dcell In .Range(.Cells(2, 4), .Cells(Rows.Count, 5).End(xlUp).Offset(0, -1))
If LCase(Join(Array(dcell.Offset(0, 1).Value2, dcell.Offset(0, 2).Value2), ChrW(8203))) = _
LCase(Join(Array(dcell.Offset(-1, 1).Value2, dcell.Offset(-1, 2).Value2), ChrW(8203))) Then
dcell = dcell.Offset(-1, 0)
Else
dcell = Application.Max(.Range(.Cells(1, 4), dcell.Offset(-1, 0))) + 1
End If
Next dcell
End With
End Sub
You could use collections as well.
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range, LstRw As Long
Dim Cell As Range
Dim vNum As Variant, c As Range, y
LstRw = Cells(Rows.Count, "E").End(xlUp).Row
Set Rng = Range("E2:E" & LstRw)
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value & Cell.Offset(, 1), CStr(Cell.Value & Cell.Offset(, 1))
Next Cell
On Error GoTo 0
y = 1
For Each vNum In cUnique
For Each c In Rng.Cells
If c & c.Offset(, 1) = vNum Then
c.Offset(, -1) = y
End If
Next c
y = y + 1
Next vNum
End Sub

Multple find requests in vba Excel (Find within a Find)

I am trying to perform a type of nested find request, the use case is that I need to look for a group on one worksheet, if found take the user ID value from a seperate column in the found row and then search for that ID in another sheet. It should then perform a bunch of actions and then find the next occurance of group in the first sheet.
The code I have is
LookupGroup = Split("GroupName1,GroupName2", ",")
For I = 0 To UBound(LookupGroup)
With Worksheets("RawData").Range("C:C")
Set C = .Find(LookupGroup(I), LookIn:=xlValues)
If Not C Is Nothing Then
FirstAddress = C.Address
Do
LookupId = Sheets("RawData").Cells(C.Row, 7).Value
IdExist = False
'Check to ensure ID does not exists on Team Members Tab
Set IdRange = Sheets("Team Members").Range("A:A").Find(LookupId, LookIn:=xlValues)
If IdRange Is Nothing Then
IdExist = True
End If
If Not IdExist Then
Highlight = True 'trigger to Set row to bold red font
If RecordsFound > 0 Then
TotalRecords = TotalRecords + RecordsFound
End If
End If
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> FirstAddress
End If
End With
Next I
This works fine the first time through, however upon reaching the Set C = .FindNext(C) the command returns 'Nothing' rather than the next occurence.
If I comment out the second find
Set IdRange = Sheets("Team Members").Range("A:A").Find(LookupId, LookIn:=xlValues)
Then the first search works fine and finds all instances
What am I doing wrong?
Easier to take the Find() logic and put it in a separate function...
Sub Tester()
Dim LookupGroup, rngGrp As Range, rngMember As Range, I
Dim g As Range, m As Range
LookupGroup = Split("GroupName1,GroupName2", ",")
For I = 0 To UBound(LookupGroup)
Set rngGrp = FindAll(Worksheets("RawData").Range("C:C"), LookupGroup(I))
If Not rngGrp Is Nothing Then
For Each g In rngGrp.Cells
Set rngMember = FindAll(Sheets("Team Members").Range("A:A"), _
g.EntireRow.Cells(7))
If Not rngMember Is Nothing Then
For Each m In rngMember.Cells
'do something with m
Next m
Else
'flag not found...
End If
Next g
End If
Next I
End Sub
'find all matching cells in a given range
Function FindAll(rngLookIn As Range, LookFor) As Range
Dim rv As Range, c As Range, FirstAddress As String
With rngLookIn
Set c = .Find(LookFor, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Set rv = c
Do
Set c = .FindNext(c)
If Not c Is Nothing Then Set rv = Application.Union(rv, c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Set FindAll = rv
End Function
I know it is an old question but it can do what you want replacing FindNext with another search but in a limited range, not the entire column "C".
First find the last row of "C" with the LastRow function and use Find with Worksheets("RawData").Range("C1:C" & LRow).
At the end, instead of using FindNext, use Find again with Range("C" & C.Row + 1 & ":C" & LRow)
Public Function LastRow(ByRef wsSheet_I As Worksheet, ByVal lColumn_I As Long) As Long
Dim LRow As Range
Set LRow = wsSheet_I.Columns(lColumn_I).Find( _
What:="*", _
LookIn:=xlFormulas, _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not LRow Is Nothing Then
LastRow = LRow.Row
Else
LastRow = 0
End If
End Function
Public Sub FindInFind()
LookupGroup = Split("GroupName1,GroupName2", ",")
For i = 0 To UBound(LookupGroup)
'new code
Dim LRow As Long
LRow = LastRow(Worksheets("RawData"), 3)
If LRow = 0 Then GoTo ErrorHandling
Dim C As Range
Set C = Worksheets("RawData").Range("C1:C" & LRow).Find(LookupGroup(i), LookIn:=xlValues)
'end new code
'With Worksheets("RawData").Range("C:C")
'Set C = .Find(LookupGroup(i), LookIn:=xlValues)
If Not C Is Nothing Then
'FirstAddress = C.Address
Do
LookupId = Sheets("RawData").Cells(C.Row, 7).Value
IdExist = False
'Check to ensure ID does not exists on Team Members Tab
Set IdRange = Sheets("Team Members").Range("A:A").Find(LookupId, LookIn:=xlValues)
If IdRange Is Nothing Then
IdExist = True
End If
If Not IdExist Then
Highlight = True 'trigger to Set row to bold red font
If RecordsFound > 0 Then
TotalRecords = TotalRecords + RecordsFound
End If
End If
'Set C = .FindNext(C)
'new code
Set C = Worksheets("RawData").Range("C" & C.Row + 1 & ":C" & LRow) _
.Find(LookupGroup(i), LookIn:=xlValues)
'end new code
Loop While Not C Is Nothing 'And C.Address <> FirstAddress
End If
End With
Next i
'new code
Exit Sub
ErrorHandling:
'do something with the error
'end new code
End Sub