I am using the code below to populate a combobox 'cbQOper3' based on the value selected in combobox 'cbQOper2'. When I change the value selected in 'cbQOper2' I receive the following error message. If I check the list of values able in 'cbQOper3' they are the appropriate according the value selected in 'cbQOper2'
Error number is : 381 Could not get the column property
Private Sub cbQOper2_Change()
Dim rngType As Range
Dim rngList As Range
Dim strSelected As String
Dim LastRow As Long
On Error GoTo errHandler:
' Populate cbQOper3 based on value selected in tbQOper2
With Me.cbQOper3
.Clear
.ColumnCount = 2
.ColumnWidths = "0;50"
.BoundColumn = 2
End With
' Check if Operation type has been select
If cbQOper2.ListIndex <> -1 Then
strSelected = cbQOper2.Value
LastRow = Sheet11.Range("B" & Rows.Count).End(xlUp).Row
Set rngList = Sheet11.Range("B6:B" & LastRow)
For Each rngType In rngList
If rngType.Value = strSelected Then
cbQOper3.AddItem rngType.Offset(0, -1)
cbQOper3.List(tbQOper3.ListCount - 1, 1) = rngType.Offset(0, 1)
End If
Next rngType
End If
' Error handler
On Error GoTo 0
Exit Sub
errHandler::
MsgBox "An Error has Occured " & vbCrLf & "The error number is : " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
Related
I keep getting this error for some code I am adapting. I have used this in other workbooks without issue as shown. The line "Me.Controls("Reg" & X).Value = findvalue" is where I am getting stuck. I use this throughout my project again without issue in other projects. Any ideas?
Private Sub lstLookup_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'Search new and existing training and return data to user controls at the bottom of the form
'declare the variables
Dim ID As String
Dim I As Integer
Dim findvalue
'error block
On Error GoTo errHandler:
'get the select value from the listbox
For I = 0 To lstLookup.ListCount - 1
If lstLookup.Selected(I) = True Then
'set the listbox column
ID = lstLookup.List(I, 8)
End If
Next I
'find the value in the range
Set findvalue = Sheet2.Range("J:J").Find(What:=ID, LookIn:=xlValues).Offset(0, -8)
'add the values to the userform controls
cNum = 9
For X = 1 To cNum
**Me.Controls("Reg" & X).Value = findvalue**
Set findvalue = findvalue.Offset(0, 1)
Next
'disable controls force user to select option
'error block
On Error GoTo 0
Exit Sub
errHandler::
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
I have code to check empty cells in a range. I need those empty cell numbers to appear in a MsgBox.
Sub IsEmptyRange()
Dim cell As Range
Dim bIsEmpty As Boolean
bIsEmpty = False
For Each cell In Range("B1:B19")
If IsEmpty(cell) = True Then
bIsEmpty = True
Exit For
End If
Next cell
If bIsEmpty = True Then
MsgBox "There are empty cells in your range"
'I NEED THE EMPTY CELLS TO APPEAR IN THE ABOVE MSGBOX
End If
End Sub
Just use:
msgbox Range("B1:B19").SpecialCells(xlCellTypeBlanks).Address
This solution adapts your code.
Dim cell As Range
Dim emptyStr As String
emptyStr = ""
For Each cell In Range("B1:B19")
If IsEmpty(cell) Then _
emptyStr = emptyStr & cell.Address(0, 0) & ", "
Next cell
If emptyStr <> "" Then MsgBox Left(emptyStr, Len(emptyStr) - 2)
If the cell is empty, it stores the address in emptyStr. The if condition can be condensed as isEmpty returns a Boolean.
Please try this code.
Sub ListEmptyCells()
Dim Rng As Range
Dim List As Variant
Dim Txt As String
Set Rng = Range("B1:B19")
On Error Resume Next
List = Rng.SpecialCells(xlCellTypeBlanks).Address(0, 0)
If Err Then
Txt = "There are no empty cells in" & vbCr & _
"the examined range."
Else
Txt = "The following cells are empty." & vbCr & _
Join(Split(List, ","), vbCr)
End If
MsgBox Txt, vbInformation, "Range " & Rng.Address(0, 0)
Err.Clear
End Sub
It uses Excel's own SpecialCells(xlCellTypeBlank), avoiding an error which must occur if this method returns nothing, and presenting the result in a legible format created by manipulating the range address if one is returned.
List blanks via dynamic arrays and spill range reference
Using the new dynamic array possibilities of Microsoft 365 (writing e.g. to target C1:C? in section b))
=$B$1:$B$19=""
and a so called â–ºspill range reference (as argument in the function Textjoin(), vers. 2019+ in section c))
C1# ' note the `#` suffix!
you could code as follows:
Sub TestSpillRange()
With Sheet1
'a) define range
Dim rng As Range
Set rng = .Range("B1:B19")
'b) check empty cell condition and enter boolean values into spill range C1#
.Range("C1").Formula2 = "=" & rng.Address & "="""""
'c) choose wanted values in spill range and connect them to result string
Dim msg As Variant
msg = Evaluate("TextJoin("","",true,if(C1#=true,""B""&row(C1#),""""))")
MsgBox msg, vbInformation, "Empty cells"
End With
End Sub
Find Blank Cells Using 'SpecialCells'
The 2nd Sub (listBlanks) is the main Sub.
The 1st Sub shows how to use the main Sub.
The 3rd Sub shows how SpecialCells works, which on one hand might be considered
unreliable or on the other hand could be used to one's advantage.
After using the 3rd Sub, one could conclude that SpecialCells 'considers' only cells at the intersection of the UsedRange and the 'supplied' range.
The Code
Option Explicit
Sub testListBlanks()
Const RangeAddress As String = "B1:B19"
Dim rng As Range: Set rng = Range(RangeAddress)
listBlanks rng
listBlanks rng, True
End Sub
Sub listBlanks(SourceRange As Range, _
Optional useList As Boolean = False)
Const proc As String = "'listBlanks'"
On Error GoTo clearError
Dim rng As Range: Set rng = SourceRange.SpecialCells(xlCellTypeBlanks)
Dim msgString As String
GoSub writeMsg
MsgBox msgString, vbInformation, "Blank Cells Found ('" & proc & "')"
Exit Sub
writeMsg:
msgString = "Blank Cells in Range '" & SourceRange.Address(False, False) _
& "'" & vbLf & vbLf & "The cells in range '" _
& rng.Address(False, False) & "' are blank."
If useList Then GoSub writeList
Return
writeList:
Dim cel As Range, i As Long, CellList As String
For Each cel In rng.Cells
CellList = CellList & vbLf & cel.Address(False, False)
Next cel
msgString = msgString & vbLf & vbLf _
& "The range contains the following " & rng.Cells.Count _
& " empty cells:" & vbLf & CellList
Return
clearError:
If Err.Number = 1004 And Err.Description = "No cells were found." Then
MsgBox "No blank cells in range '" & SourceRange.Address(False, False) _
& "' were found.", vbInformation, "No Blanks ('" & proc & "')"
Exit Sub
Else
MsgBox "An unexpected error occurred." & vbLf _
& "Run-time error '" & Err.Number & "': " & Err.Description, _
vbCritical, "Error in " & proc
End If
End Sub
Sub testUsedRangeAndSpecialCells()
Const wsName As String = "Sheet2"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
With ws
.Range("A:B").ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(1, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(2, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 3).Value = 3
Debug.Print .UsedRange.Address
.Cells(2, 3).ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 2).ClearContents
Debug.Print .Columns("B").SpecialCells(xlCellTypeBlanks).Address
Dim rng As Range: Set rng = .Columns("C")
Debug.Print rng.Address
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeBlanks)
If Err.Number <> 0 Then
MsgBox "We know that all cells are blank in range '" _
& rng.Address(False, False) & "', but 'SpecialCells' " _
& "doesn't consider them since they are not part of 'UsedRange'."
Debug.Print "No blank cells (not quite)"
Else
Debug.Print rng.Address
End If
On Error Goto 0
.Cells(3, 4).Value = 4
Set rng = rng.SpecialCells(xlCellTypeBlanks)
Debug.Print rng.Address(False, False)
End With
End Sub
The result of the 3rd Sub (testUsedRangeAndSpecialCells)
$A$1
$A$1
$A$1:$B$1
$A$1:$B$2
$A$1:$B$2
$A$1:$C$2
$A$1:$B$2
$B$1
$C:$C
No blank cells (not quite)
C1:C3
For my code, I am trying to find the difference between an objects value from two different days.
Sub GoingBack()
numberCube = InputBox("Which file are we going back to?")
numberYest = numberCube - 1
Workbooks.Open ("C:\Users\user\Downloads\file (" & numberCube & ").xlsx")
Workbooks.Open ("C:\Users\user\Downloads\file (" & numberYest & ").xlsx")
Set Work1 = Workbooks("file (" & numberCube & ").xlsx")
Set Work2 = Workbooks("file (" & numberCube - 1 & ").xlsx")
'Add the Time Difference Column (AA--27)
LastRow67 = Work1.Sheets("67").Cells(Rows.Count, 2).End(xlUp).Row
Work1.Sheets("67").Cells(1, 27).Value = "Time Clock Difference"
Work1.Sheets("67").Cells(1, 27).FormulaR1C1 = "=RC[-15]-VLOOKUP(RC[-21], '[file (" & numberYest & ").xlsx]67'!$F:$L, 7, FALSE)"
Work1.Sheets("67").Range("AA2").Select
Selection.AutoFill Destination:=Range("AA2:AA" & LastRow67)
Work1.Close savechanges:=True
Work2.Close savechanges:=True
End Sub
The line that is throwing the "Application Defined or Object Defined" error is:
Work1.Sheets("67").Cells(1, 27).FormulaR1C1 = "=RC[-15]-VLOOKUP(RC[-21], '[file (" & numberYest & ").xlsx]67'!$F:$L, 7, FALSE)"
I have tried using Range.Formula, and that threw the error as well.
Work1.Sheets("67").Range("AA2").Formula = "=L2-VLOOKUP(F2, '[file (" & numberYest & ").xlsx]67'!$F:$L, 7, FALSE)"
Any help would be appreciated. Thank you so much.
EDIT: I typed in the formula in Excel, and it works. I recorded the inputting of the formula, and the below is the result. I clicked/referenced columns F through L, so I'm not sure why it is only displaying C6:C12 below.
ActiveCell.FormulaR1C1 = "=RC[-15]-VLOOKUP(RC[-21],'[file.xlsx]67'!C6:C12,7,FALSE)"
Just because you've always done something a certain way, doesn't make it good practice. There are a lot of opportunities for improvement here.
Consider this refactor:
Option Explicit ' always!
Sub GoingBack()
' Dim all variables
Dim numberCube As Variant
Dim numberYest As Long
Dim Work1 As Workbook
Dim Work2 As Workbook
Dim LastRow67 As Long
Dim WorkSh1 As Worksheet
Dim WorkSh2 As Worksheet
Dim Pth As String
' avoid repeats of the same data
Pth = "C:\Users\user\Downloads\"
' Might be better to use FileDialog, but anyway...
' Handle user cancel and invalid entry
Do
numberCube = InputBox("Which file are we going back to?")
If numberCube = vbNullString Then
' User canceled, exit
Exit Sub
End If
If IsNumeric(numberCube) Then Exit Do
MsgBox "Enter a Number", vbCritical + vbOKOnly, "Error"
Loop
numberYest = numberCube - 1
' Handle files missing or won't open
On Error Resume Next
Set Work1 = Workbooks.Open(Pth & "file (" & numberCube & ").xlsx")
On Error GoTo 0
If Work1 Is Nothing Then
'Work1 failed to open, what now?
GoTo CleanUp
End If
On Error Resume Next
Set Work2 = Workbooks.Open(Pth & "file (" & numberYest & ").xlsx")
On Error GoTo 0
If Work2 Is Nothing Then
'Work2 failed to open, what now?
GoTo CleanUp
End If
' Set refences to worksheets and handle if missing
On Error Resume Next
Set WorkSh1 = Work1.Sheets("67")
On Error GoTo 0
If WorkSh1 Is Nothing Then
' WorkSh1 doesn't exist, what now?
GoTo CleanUp
End If
On Error Resume Next
Set WorkSh2 = Work2.Sheets("67")
On Error GoTo 0
If WorkSh2 Is Nothing Then
' WorkSh2 doesn't exist, what now?
GoTo CleanUp
End If
'Add the Time Difference Column (AA--27)
' use your references
With WorkSh1
LastRow67 = .Cells(.Rows.Count, 2).End(xlUp).Row
.Cells(1, 27).value = "Time Clock Difference"
' no need for select or Autofill
' Can't use A1 style in FormulaR1C1
.Range(.Cells(1, 27), .Cells(LastRow67, 27)).FormulaR1C1 = _
"=RC[-15]-VLOOKUP(RC[-21], " & WorkSh2.Range("F:L").Address(, , xlR1C1, True) & ", 7, FALSE)"
End With
CleanUp:
Work1.Close SaveChanges:=True
Work2.Close SaveChanges:=False ' you didn't change file 2
End Sub
New to all this but appreciate any help I can get.
Problem: I have a duty roster with initials and sometimes I want to highlight a specific person to see his/her schedule. The highlight consists of changing the font color and making it bold but I'd also like the cell color to change as well, to lets say light green. I do know that I can use the Search/Replace feature but I'd like a macro for this.
So far, I've managed to piece together an input box and I can change the font color and add 'bold' to the font (and other changes) but I haven't solved changing the cell color.
This is what I have so far:
Sub FindAndBold()
Dim sFind As String
Dim rCell As Range
Dim rng As Range
Dim lCount As Long
Dim iLen As Integer
Dim iFind As Integer
Dim iStart As Integer
On Error Resume Next
Set rng = ActiveSheet.UsedRange. _
SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo ErrHandler
If rng Is Nothing Then
MsgBox "There are no cells with text"
GoTo ExitHandler
End If
sFind = InputBox( _
Prompt:="Skriv in dina initialer", _
Title:="Dina initialer")
If sFind = "" Then
MsgBox "Du skrev inget"
GoTo ExitHandler
End If
iLen = Len(sFind)
lCount = 0
For Each rCell In rng
With rCell
iFind = InStr(.Value, sFind)
Do While iFind > 0
.Characters(iFind, iLen).Font.Bold = True
.Characters(iFind, iLen).Font.Color = RGB(255, 0, 0)
.Characters(iFind, iLen).Font.ColorIndex = 4
lCount = lCount + 1
iStart = iFind + iLen
iFind = InStr(iStart, .Value, sFind)
Loop
End With
Next
If lCount = 0 Then
MsgBox "Fanns inget" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "att markera"
ElseIf lCount = 1 Then
MsgBox "Det fanns en" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "markerades"
Else
MsgBox lCount & " hittade" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "och markerades"
End If
ExitHandler:
Set rCell = Nothing
Set rng = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
Any help would be greatly appreciated!
(The text in the prompt and response is in Swedish)
You can also do this using conditional formatting, no need for VBS.
Using a conditional format formula you can enter something like this: =AND(ISNUMBER(SEARCH($G$1;A2));$G$1<>"") - in this case field G1 would be the field used for searching (read:highlighting) all the fields containing this condition.
If you desire a VBS we can improve and include a filter for all lines matching your search:
Sub searchfilter()
Range("A11:M10000").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("A2:M13"), Unique:=False
End Sub
And to clear:
Sub clearfilter()
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
Assign both macros to a button.
Sample image where i combined both (filter was done on C15 in this case):
And sample with hidden fields shown:
Function copyHeader(inputrange As String, inputsheet As String, outputcell As String, outputsheet As String)
Sheets(inputsheet).Range(inputrange).Copy Destination:=Sheets(outputsheet).Range(outputcell)
Application.CutCopyMode = False
Cells(1, 1).Value = 4 'probably better to make this dynamic
End Function
Function copyDetail(inputrange As String, inputsheet As String, outputcell As String, outputsheet As String)
Sheets(inputsheet).Range(inputrange).Copy Destination:=Sheets(outputsheet).Range(outputcell)
Application.CutCopyMode = False
Cells(1, 1).Value = 4 'probably better to make this dynamic
End Function
Function createTab(tabname As String)
Worksheets.Add.Name = tabname
End Function
Function shtExists(shtname As String) As Boolean
Dim sht As Worksheet
On Error GoTo ErrHandler:
Set sht = Sheets(shtname)
shtExists = True
ErrHandler:
If Err.Number = 9 Then
shtExists = False
End If
End Function
Public Function lastCell(Col As String)
With ActiveSheet
lastCell = .Cells(.Rows.Count, Col).End(xlUp).Row
End With
End Function
Sub AddData()
Dim teamname As String
Dim countery As Integer
Dim teamdata As String
Dim matchcounter As String
Dim resp As Boolean
Dim maxCounter As Integer
counter = 4
maxCounter = lastCell("B")
On Error GoTo eh
For counter = 4 To maxCounter
ThisWorkbook.Sheets("DataEntry").Select
teamdata = "C" & counter & ":" & "N" & counter
teamname = ThisWorkbook.Sheets("DataEntry").Range("B" & counter).Value
resp = shtExists(teamname)
If resp = False Then
createTab (teamname)
copyHeader "C1:M3", "DataEntry", "B1", teamname
matchcounter = CStr(Sheets(teamname).Range("A1").Value)
copyDetail teamdata, "DataEntry", "B" & matchcounter, teamname
ElseIf resp = True Then
copyDetail teamdata, "DataEntry", "B" & matchcounter, teamname
End If
Next counter
Worksheets("DataEntry").Activate
Done:
Exit Sub
eh:
MsgBox "The following error occurred: " & Err.Description & " " & Err.Number & " " & Err.Source
End Sub
So When I try and Run this as you saw from the title I get an Application-defined or object-defined error: 1004. I a, trying to make it iterate through cells B4 to B9 and at each one and if there is no sheet with the name in that cell it creates it and pastes the headers that are on the data entry page (C1:M3) and the data on that row from C to I onto the newly created sheet. If it does exist it looks at A1 of the sheet with that name and pastes the data into column B and the row that A1 specifies. And it does this for B4:B9 on each cell. Any help would be appreciated.
Dim teamdata As String
stringcombine = "C" & countery & ":" & "M" & countery
teamdata = Range(stringcombine)
Here you are assigning an array (of 11 entries) to a string, hence the type mismatch.
Upon reading your code, what you meant to do was
teamdata = Range(stringcombine).Address
though it wasn't necessary to create an additional variable teamdata for the address, you already had it in stringcombine.
Looking at the copypaste function, it appears that inputRange parameter should have a string value like "C3:M3". You pass teamdata to copypaste as the inputrange parameter, so are you expecting teamdata to have a value like "C3:M3"? If so, then your line
teamdata = Range(stringcombine)
could be
teamdata = stringcombine
What the current line attempts to do is take the values from the range of cells and assign them to a string variable -- which it isn't designed to do. If stringcombine were something like "M3" it would work ok. One cell value to one string.
Error 13 generally means you're trying to assign a value to a variable that can't accept that data type, or you're trying to pass the wrong data type as an argument to a sub or function.
If I've understood your requirements, this should be able to replace your existing code:
Sub AddData_ReWrite()
Dim teamName As String
Dim i As Integer
Dim matchCounter As String
Dim dataEntry As Excel.Worksheet
matchCounter = Range("A1").Value
Set dataEntry = Sheets("DataEntry")
For i = 4 To 9
teamName = Sheets("DataEntry").Range("B" & i).Value
CreateSheetIfNotExists teamName
Sheets(teamName).Range("B" & matchCounter & ":N" & matchCounter).Value = dataEntry.Range("C" & i & ":M" & i).Value
Next
dataEntry.Activate
End Sub
Sub CreateSheetIfNotExists(ByVal sheetName As String)
Dim sht As Worksheet
On Error GoTo ErrHandler:
Set sht = Sheets(sheetName)
ErrHandler:
If (Err.Number) Then
If Err.Number = 9 Then
With Worksheets.Add
.Name = sheetName
.Range("B1:N3").Value = Sheets("DataEntry").Range("C1:M3").Value
.Range("A1").Value = 2
End With
Else
'// What if it isn't error 9?
MsgBox "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description, vbExclamation + vbOKOnly, "Error"
End If
End If
'// clear errors and reset error handler
Err.Clear
On Error GoTo 0
End Sub
I've tidied it up a bit to improve the readability and added extra error handling in your other sub routine.