I'm having a really bad time trying to understand why I get an error which I thing should not appear.
I'm using Office 2007. I have two sheets in Excel, "Ver" and "Encargado", in "Ver" sheet I have one cell in which to put a number and then I press one button. The code inside the button is:
Private Sub CommandButton1_Click()
Dim buscar As Range
dato = Range("b2").Value
If dato = "" Then Exit Sub
Sheets("Encargado").Select
Set buscar = Range("b2:b12").Find(What:=dato, LookIn:=xlFormulas, SearchOrder:=xlByRows)
If Not buscar Is Nothing Then
buscar.Activate
ActiveCell.Offset(, -1).Copy Destination:=Ver.Cells(4, 2)
Sheets("Ver").Select
Else
Sheets("Ver").Select
MsgBox "Encargado no encontrado"
Exit Sub
End If
End Sub
In "Encargado" sheet and inside the range b2:b12 there are only numbers beetwen 101 and 111, and when I put the number 117 as an input (for example) I think it should get into the else part as it shouldn't have found any coincidence, but it gets into the if part, why? and I get an error saying "Error en el método activate de la clase Range" (As you noticed I am using Office in spanish, and programming as well with spanish variables). When I run line by line the error appears in the line "buscar.Activate". Does anyone know where is the error? In the case you want to see it, here is the file: https://www.dropbox.com/s/j1b39fqy971n7lf/Todo.xlsm Thanks.
You have not defined the sheet in find function so its referring ver sheet. Use this code.
Private Sub CommandButton1_Click()
Dim buscar As Range
'Application.ScreenUpdating = False
dato = Range("b2").Value
If dato = "" Then Exit Sub
Set buscar = Sheets("Encargado").Range("b2:b12").Find(What:=dato, LookIn:=xlValues, SearchOrder:=xlByRows)
If Not buscar Is Nothing Then
'Encargado.Cells.Find(What:=Ver.Cells(2, 2), After:=Range("b2"), LookIn:=xlFormulas, SearchOrder:=xlByRows).Select
'desplazamiento en fila, desplazamiento en columna, positivo: hacia abajo, hacia la derecha
'buscar.Activate
c = buscar.Row
Sheets("Encargado").Range("a" & c).Copy
Sheets("Ver").Range("b4").PasteSpecial
Else
Sheets("Ver").Select
MsgBox "Encargado no encontrado"
Exit Sub
End If
'Application.ScreenUpdating = True
End Sub
EDIT: As pointed out in the comments below, the Range object DOES have an .Activate method: http://msdn.microsoft.com/en-us/library/office/ff837085(v=office.15).aspx
buscar is a Range object, which does not have an Activate method. The following should get you where you're going, but out of curiosity -- have you looked into Excel's built-in =VLOOKUP functionality? It might save you from requiring VBA here...
Option Explicit
Private Sub CommandButton1_Click()
Dim TerritorioNum As Long, LastRow As Long
Dim TerritorioRange As Range, FoundRange As Range
Dim VerSheet As Worksheet, EncSheet As Worksheet
'set references up-front
Set VerSheet = ThisWorkbook.Worksheets("Ver")
Set EncSheet = ThisWorkbook.Worksheets("Encargado")
With EncSheet
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set TerritorioRange = .Range(.Cells(1, 1), .Cells(LastRow, 2))
End With
TerritorioNum = VerSheet.Cells(2, 2).Value
'find the territory number
Set FoundRange = TerritorioRange.Find(TerritorioNum)
If FoundRange Is Nothing Then
MsgBox ("Encargado no encontrado")
Exit Sub
Else
VerSheet.Cells(4, 2) = EncSheet.Cells(FoundRange.Row, FoundRange.Column - 1).Value
End If
End Sub
Related
I work for an automotive company as a logistic administrative and I want to record a macro that allows me to look for a range of cells which contain the numbers of the operations and delete the files that are related to retail clients (keeping the fleet clients ones).
Fleets operations start with 01RN92, 01RN94, 01RR, and 01RB. The other ones are for retail clients.
The part of the code that is throwing the error is the if loop in this part of the code:
Dim celda As Object
Dim rng As Range
Set rng = Range("B2:B200")
For Each celda In rng
valor = celda.Value
If valor Like "01RN92*" Or valor Like "01RN94*" Or valor Like "01RB*" Or valor Like "01RR*" Then
celda.Interior.Color = 65535
Else
celda.EntireRow.Delete
End If
Next celda
I need help. What am I missing here and how can I solve it?
Thank you very much.
Kind regards.
Formula errors in column B's values will cause this issue. The following rework would skip them:
Dim rng As Range
Set rng = Range("B2:B200")
For y = rng.Cells.Count To 1 Step -1
With rng.Cells(y)
valor = .Value
If Not (IsError(valor)) Then
If valor Like "01RN92*" Or valor Like "01RN94*" Or valor Like "01RB*" Or valor Like "01RR*" Then
.Interior.Color = VBYellow
Else
.EntireRow.Delete
End If
End If
End With
Next
Note: it's best practice to delete from the bottom up, rather than top down, in order to be sure that you delete every row that should be.
Welcome to the Stackoverflow. You are most probably getting that error because there is a formula error in one of the cells.
Here is a simple way to reproduce it and identify the culprit cell.
Sub Sample()
Dim ws As Worksheet
Dim celda As Range, rng As Range
Dim CellAddress As String
On Error GoTo Whoa
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
Set rng = .Range("B2:B200")
For Each celda In rng
valor = celda.Value
If valor Like "01RN92*" Or valor Like "01RN94*" Or valor Like "01RB*" Or valor Like "01RR*" Then
celda.Interior.Color = 65535
Else
celda.EntireRow.Delete
End If
Next celda
End With
Exit Sub
Whoa:
If Not celda Is Nothing Then
MsgBox Err.Description, vbInformation, "Check Cell " & celda.Address
Else
MsgBox Err.Description, vbInformation
End If
End Sub
As mentioned in the comments above, Step through the code and check for which cell you are getting that error. Then physically check that cell and see if there is any formula error like "#N/A" "#DIV/0!"
Ok, the problem was that some of the cells were #N/A, because the first part of the macro has some formulas on it.
Thank you very much, I'll keep improving the macro to avoid those #N/A's and make it work perfectly.
I have an activeX dropdown form on my spreadsheet which executes code on _Change. My code modifies the dropdowns list source (adding or deleting items). Whenever this happens, the _Change is called again.
I have various workarounds, all of which were some version of changing the list source, but with no success. The reason none of this has worked is because clearing or altering the .ListFillRange actually triggers the _Change event again.
How do I prevent the _Changeevent from getting called if I want to add or delete items in the .ListFillRange
UPDATE w EnableEvents set to false:
Public Sub SetRangeForDropdown()
On Error Resume Next
Application.EnableEvents = False
'Get new List of employees from Employee sheet
Dim rng1 As Range
With wsDB_employee
Set rng1 = .Range("A2:B" & .Range("A10000").End(xlUp).Row)
End With
With wsStage
.Cells.Clear
rng1.Copy .Range(.Cells(1, 1), .Cells(rng1.Rows.Count, 2))
End With
'Set range for dropdown on employee sheet
Dim rng2 As Range
Set rng2 = wsStage.Range("A1:B" & wsStage.Range("A10000").End(xlUp).Row)
'Update employee list named formula
ActiveWorkbook.Names.Add Name:="nfEmployeeList", RefersTo:=rng2
Dim str As String
str = rng2.Parent.Name & "!" & rng2.Address 'Source path for list fill range
wsMA.cmbEmployeeSelection.ListFillRange = str
Application.EnableEvents = True
End Sub
Apperantly EnableEvents does not work for ActiveX controls.
Thank you Microsoft for making life just a little bit more complicated!
Just found this: "Application.EnableEvents=False/True ONLY applies to Sheet and Workbook Events, not ActiveX Control Events" from here enter link description here
You can disable the events in the SetRangeForDropdown and then enable them back.
So, write the following at the start:
Application.EnableEvents = False
And the following at the end:
Application.EnableEvents = true
it's always a good habit to make (nearly) sure that events handling is always brought back, like follows:
Public Sub SetRangeForDropdown()
'...your code
On Error GoTo ExitSub
Application.EnableEvents = False
wsMA.cmbEmployeeSelection.ListFillRange = rng2
'Update employee list named formula
ActiveWorkbook.Names.Add name:="nfEmployeeList", RefersTo:=rng2
ExitSub:
Application.EnableEvents = True
End Sub
Furthermore, avoid On Error Resume Next unless you really need it
I have solved the problem by adding a global variable that prevents the _Change event from firing. Here is that code:
Private Sub cmbEmployeeSelection_Change()
If bNOTRUN = False Then 'Check if ActiveX event should fire or not
modEmployeeDB.SaveEmployeeData 'Save currently selected employee data
modEmployeeDB.DBSoll_To_WorkerInfo 'Get called employee data
End If
End Sub
And this is the module as modified... note the simple Boolean variable that I added:
Public Sub SetRangeForDropdown()
On Error GoTo SetRangeForDropdown_Error
bNOTRUN = True 'Global Variable that when True prevents Active X from firing
'Get new List of employees from Employee sheet
Dim rng1 As Range
With wsDB_employee
Set rng1 = .Range("A2:B" & .Range("A10000").End(xlUp).Row)
End With
With wsStage
.Cells.Clear
rng1.Copy .Range(.Cells(1, 1), .Cells(rng1.Rows.Count, 2))
End With
'Set range for dropdown on employee sheet
Dim rng2 As Range
Set rng2 = wsStage.Range("A1:B" & wsStage.Range("A10000").End(xlUp).Row)
'Update employee list named formula
ActiveWorkbook.Names.Add Name:="nfEmployeeList", RefersTo:=rng2
Dim str As String
str = rng2.Parent.Name & "!" & rng2.Address 'Source path for list fill range
wsMA.cmbEmployeeSelection.ListFillRange = str
bNOTRUN = False
On Error GoTo 0
Exit Sub
SetRangeForDropdown_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SetRangeForDropdown of Sub modEmployeeDB"
bNOTRUN = False
End Sub
I'm trying to automatically update the "Updated" column of an excel spreadsheet when any cell of that specific row changes to today's date. I was able to do this by hard-coding where the "Updated" column header would be, however, it is now necessary to search for that column header as it may move.
The code I am trying to implement works but immediately gives me the error Automation error - The object invoked has disconnected from it's clients.
Any help would be appreciated. Here is the code I have currently:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
Dim f As Range
Set f = ActiveSheet.Range("A1:DD1").Find("Updated", lookat:=xlWhole)
' f.Row = Range(Target).Row
If Not f Is Nothing Then
Range(Split(f.Address, "$")(1) & Target.Row).Value = Now
Else
MsgBox "'Updated' header not found!"
End If
End If
End Sub
You got into an endless loop.
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
Dim f As Range
Set f = ActiveSheet.Range("A1:DD1").Find("Updated", lookat:=xlWhole)
' f.Row = Range(Target).Row
If f Is Nothing Then
MsgBox "'Updated' header not found!"
ElseIf Intersect(Target, f.EntireColumn) Is Nothing Then
Intersect(Target.EntireRow, f.EntireColumn).Value = Now
' Else
' MsgBox "We entered this function again because the row above updated the Updated column", vbInformation, "False alarm"
End If
End If
End Sub
To understand what happens,
Uncomment the else and MsgBox
Put a breakpoint on the MsgBox
When you hit it, press [ctrl]-L
In a case such as this, I run into far fewer problems when I simply loop through the available cells to find the column header. Using the .Find method also works, but is less "tunable" to my needs in a custom application.
Public Function FindColumn(header As String) As Long
Dim lastCol As Long
Dim headerCol As Long
Dim i As Long
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("VTO2 Labor")
lastCol = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
headerCol = 0
For i = 1 To lastCol
If sh.Cells(1, i).Value = header Then
headerCol = i
End If
Next i
FindColumn = headerCol
End Function
It isn't clear on whether the Updated column header could be in row 1 or if it will always be in row 1, just not in the same location.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
On Error GoTo bm_SafeExit
'TURN OFF EVENTS IF YOU ARE GOING TO WRITE A VALUE INTO THE WORKSHEET!
Application.EnableEvents = False
Dim uCol As Long, f As Range
If Application.CountIf(Rows(1), "updated") Then
uCol = Application.Match("updated", Rows(1), 0)
For Each f In Intersect(Target, Range("A:DX"))
If f.Row > 1 Then _
Cells(f.Row, uCol) = Now
Next f
Else
MsgBox "'Updated' header not found!"
End If
End If
bm_SafeExit:
Application.EnableEvents = True
End Sub
That should survive multiple updates (e.g. when pasting values). The problem I see is that is the Updated column is being shifted around, presumably through inserting columns or the like, then the change routine is going to run.
I know that I could do something like..
range("C1:D1").copy destination:=range("C2:D2")
for ranges, I would like to know if I can do the same for form control buttons
Current code below copies the button if found and then adds the button to the cell where the "hash tag" was written. In this example "#Button Back To Summary#". This all works fine but I would like to change the code to not go via the clipboard, for example like the above code for a range but for a form button.
Calling Code:
On Error Resume Next
Cells.Find(What:="#Button Back To Summary#", After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
, MatchCase:=False, SearchFormat:=False).Activate
If Err.Number = 0 Then
addshapetocell ActiveCell, "BK_TO_SUMMARY"
End
DoEvents
On Error GoTo 0
addshapetocell()
Sub addshapetocell(p As Range, btn_Name As String)
Dim clLeft As Double
Dim clTop As Double
Dim cl As Range
Dim r As Integer, R1 As Integer
On Error GoTo 0
R1 = 0
r = 0
Set cl = Range(p.Address)
clLeft = cl.Left
clTop = cl.Top
cl.value = ""
retryer:
update_Working_Status
Application.CutCopyMode = False
DoEvents
If r > 5000 Or R1 > 700 Then
MsgBox "Code has attempted to copy a button 5000 times and has failed each time"
Stop
End If
Worksheets("Odds").Shapes(btn_Name).Copy
DoEvents
If Application.ClipboardFormats(1) = 0 Then
R1 = R1 + 1
Sleep (50)
GoTo retryer
End If
With ActiveSheet
On Error Resume Next
.Paste
If Err.Number = 1004 Then
On Error GoTo 0
r = r + 1
Sleep (50)
GoTo retryer
ElseIf Err.Number <> 0 Then
Stop 'unhandled error has happend
End If
On Error GoTo 0
.Shapes(btn_Name).Left = clLeft
.Shapes(btn_Name).Top = clTop
End With
End Sub
Edit: update_Working_Status updates the status bar with "Working." & "Working.." etc
I don't believe there is a way to directly copy the Shape from one Worksheet to another without using the Clipboard. There is a .Duplicate method but I'm not aware of a way to change the Shapes Parent ie. which Worksheet it belongs to.
Have you considered programmatically re-creating the Shape using your template Shape as a base? This would be, effectively, copying the Shape but with a bit more effort involved. I've written the following as an example of how you could do this which, hopefully, you can adapt to your exact needs.
Dim wb As Workbook
Set wb = Application.ActiveWorkbook
' Worksheet Receiving the Template Shape ie. the ActiveSheet.
Dim ws As Worksheet
Dim rng As Range
Dim newShape As Shape
Set ws = wb.ActiveSheet
Set rng = ws.Range("B10") ' Destination Cell.
' Worksheet containing the Template Shape.
Dim wsTemplate As Worksheet
Dim shapeToCopy As Shape
Set wsTemplate = wb.Sheets("Template") ' The Worksheet containing template button.
Set shapeToCopy = wsTemplate.shapes("#example") ' The name of template button.
' Different 'Shapes' are created via different Methods, so check the types that you want
' to support and implement the Method as appropriate.
Select Case shapeToCopy.Type
Case MsoShapeType.msoFormControl
' Create the 'new' Shape based on the type and size of the template, and the location of the receiving Cell.
Set newShape = ws.shapes.AddFormControl(shapeToCopy.FormControlType, rng.Left, rng.Top, shapeToCopy.Width, shapeToCopy.Height)
newShape.OLEFormat.Object.Text = shapeToCopy.OLEFormat.Object.Text ' Copy the template buttons caption.
Case Else
' Unsupported Shape Type
Exit Sub
End Select
' Now "Copy" the remaining shared Shape properties that we want to retain from the template.
newShape.Name = shapeToCopy.Name
newShape.AlternativeText = shapeToCopy.AlternativeText
newShape.OnAction = shapeToCopy.OnAction ' The name of the routine to run on button click
' etc...
' etc...
In sheet1 I have an invisible activeX control (Oleobject): commandbutton1
It can be placed alongside the 'hash tag' cell, using:
Sub M_snb()
With Cells.Find("hash tag").Offset(, 1)
Sheet1.CommandButton1.Top = .Top
Sheet1.CommandButton1.Left = .Left
Sheet1.CommandButton1.Visible = True
End With
End Sub
I'm running the following macro to perform a basic 'FindHighlight' function through a database in MS XL 2003
The find function works perfectly, but the issue I have is that when the 'ClearHighlight' is used (before a search is made) then I get Run-time error 91 - 'Object variable or With block variable not set'
I understand that I need to complete a search before using this function, but others using the tool may not - I was wondering if there is a way to prevent this alert coming up?
(Beginner on VBA!!)
Thank you!
Dim FoundRange As Range
Sub FindHighlight()
Dim tempCell As Range, Found As Range, sTxt As String
sTxt = InputBox("Search string")
If sTxt = "False" Then Exit Sub
Set Found = Range("A1")
Set tempCell = Cells.Find(what:=sTxt, After:=Found, SearchDirection:=xlNext, MatchCase:=False)
If tempCell Is Nothing Then
MsgBox prompt:="Not found", Title:="Finder"
Exit Sub
Else
Set Found = tempCell
Set FoundRange = Found
End If
Do
Set tempCell = Cells.FindNext(After:=Found)
If Found.Row >= tempCell.Row And Found.Column >= tempCell.Column Then Exit Do
Set Found = tempCell
Set FoundRange = Application.Union(FoundRange, Found)
Loop
FoundRange.Interior.ColorIndex = 6
FoundRange.Font.ColorIndex = 3
End Sub
Sub ClearHighlight()
FoundRange.Interior.ColorIndex = xlNone
FoundRange.Font.ColorIndex = xlAutomatic
End Sub
If FoundRange is not set it's value is Nothing so:
Sub ClearHighlight()
if FoundRange is nothing then exit sub
FoundRange.Interior.ColorIndex = xlNone
FoundRange.Font.ColorIndex = xlAutomatic
End Sub