WERNER SLABBERT
Board Regular
- Joined
- Mar 3, 2009
- Messages
- 107
Hi since i updated my code the error 70 "Permission Denied" keeps me from activating my search form.
VBA Code:
Const SEARCH_BLANK As String = "[BLANK]"
Sub FilterData()
Dim ws As Worksheet
Dim i As Long
Dim lastRow As Long
Dim matchCriteria As Boolean
' Change "Sheet1" to the name of your worksheet with the data
Set ws = ThisWorkbook.Worksheets("Sheet1")
' Clear previous results in the ListBox
Me.lstResults.Clear
' Find the last row with data in the worksheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
' Loop through each row to check if it meets the criteria
For i = 2 To lastRow ' Assuming row 1 has headers
matchCriteria = True
' Apply filters based on ComboBox values
If Me.cboJobNr.Value <> "" And ws.Cells(i, 1).Value <> Me.cboJobNr.Value Then
matchCriteria = False
End If
If Me.cboClient.Value <> "" And ws.Cells(i, 2).Value <> Me.cboClient.Value Then
matchCriteria = False
End If
If Me.cboModel.Value <> "" And ws.Cells(i, 3).Value <> Me.cboModel.Value Then
matchCriteria = False
End If
If Me.cboSerial.Value <> "" And ws.Cells(i, 4).Value <> Me.cboSerial.Value Then
matchCriteria = False
End If
If Me.cboQuote.Value <> "" And ws.Cells(i, 7).Value <> Me.cboQuote.Value Then
matchCriteria = False
End If
If Me.cboConfirmed.Value <> "" And ws.Cells(i, 8).Value <> Me.cboConfirmed.Value Then
matchCriteria = False
End If
If Me.cboMailed.Value <> "" And ws.Cells(i, 9).Value <> Me.cboMailed.Value Then
matchCriteria = False
End If
If Me.cboStatus.Value <> "" And ws.Cells(i, 10).Value <> Me.cboStatus.Value Then
matchCriteria = False
End If
If Me.cboComplete.Value <> "" And ws.Cells(i, 11).Value <> Me.cboComplete.Value Then
matchCriteria = False
End If
If Me.cboCollection.Value <> "" And ws.Cells(i, 12).Value <> Me.cboCollection.Value Then
matchCriteria = False
End If
' If the row matches all criteria, add it to the ListBox
If matchCriteria Then
With Me.lstResults
.AddItem
.List(.ListCount - 1, 0) = ws.Cells(i, 1).Value ' Job Nr
.List(.ListCount - 1, 1) = ws.Cells(i, 2).Value ' Client
.List(.ListCount - 1, 2) = ws.Cells(i, 3).Value ' Model
.List(.ListCount - 1, 3) = ws.Cells(i, 4).Value ' Serial
.List(.ListCount - 1, 4) = ws.Cells(i, 5).Value ' Received
.List(.ListCount - 1, 5) = ws.Cells(i, 6).Value ' Assessed
.List(.ListCount - 1, 6) = ws.Cells(i, 7).Value ' Quote
.List(.ListCount - 1, 7) = ws.Cells(i, 8).Value ' Mailed
.List(.ListCount - 1, 8) = ws.Cells(i, 9).Value ' Confirmed
.List(.ListCount - 1, 9) = ws.Cells(i, 10).Value ' Complete
.List(.ListCount - 1, 10) = ws.Cells(i, 11).Value ' Status
.List(.ListCount - 1, 11) = ws.Cells(i, 12).Value ' Collection
End With
End If
Next i
End Sub
Private Sub cmdSearch_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Current Jobs") ' Make sure sheet name matches
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
Dim row As Long
Dim matchFound As Boolean
Dim criteriaJobNr As String
Dim criteriaClient As String
Dim criteriaModel As String
Dim criteriaStatus As String
' Retrieve user inputs
criteriaJobNr = Me.cboJobNr.Value
criteriaClient = Me.cboClient.Value
criteriaModel = Me.cboModel.Value
criteriaStatus = Me.cboStatus.Value
' Clear previous ListBox results
Me.lstResults.Clear
' Loop through data rows and match criteria
For row = 2 To lastRow
matchFound = True
' Check each criterion; if empty, skip that criterion
If criteriaJobNr <> "" And criteriaJobNr <> SEARCH_BLANK Then
If ws.Cells(row, 1).Value <> criteriaJobNr Then matchFound = False
ElseIf criteriaJobNr = SEARCH_BLANK Then
If ws.Cells(row, 1).Value <> "" Then matchFound = False
End If
If criteriaClient <> "" And criteriaClient <> SEARCH_BLANK Then
If ws.Cells(row, 2).Value <> criteriaClient Then matchFound = False
ElseIf criteriaClient = SEARCH_BLANK Then
If ws.Cells(row, 2).Value <> "" Then matchFound = False
End If
If criteriaModel <> "" And criteriaModel <> SEARCH_BLANK Then
If ws.Cells(row, 3).Value <> criteriaModel Then matchFound = False
ElseIf criteriaModel = SEARCH_BLANK Then
If ws.Cells(row, 3).Value <> "" Then matchFound = False
End If
If criteriaStatus <> "" And criteriaStatus <> SEARCH_BLANK Then
If ws.Cells(row, 11).Value <> criteriaStatus Then matchFound = False
ElseIf criteriaStatus = SEARCH_BLANK Then
If ws.Cells(row, 11).Value <> "" Then matchFound = False
End If
' Add matching rows to ListBox if match found
If matchFound Then
Me.lstResults.AddItem ws.Cells(row, 1).Value & " | " & _
ws.Cells(row, 2).Value & " | " & _
ws.Cells(row, 3).Value & " | " & _
ws.Cells(row, 11).Value
End If
Next row
End Sub
Private Sub UserForm_Initialize()
' Populate combo boxes using the named ranges
' Add SEARCH_BLANK as a constant option for searching blank values
' Job Number
Me.cboJobNr.RowSource = "JobNr"
Me.cboJobNr.AddItem SEARCH_BLANK
' Client Name
Me.cboClient.RowSource = "Client"
Me.cboClient.AddItem SEARCH_BLANK
' Model
Me.cboModel.RowSource = "Model"
Me.cboModel.AddItem SEARCH_BLANK
' Serial Number
Me.cboSerial.RowSource = "Serial"
Me.cboSerial.AddItem SEARCH_BLANK
' Quote Number
Me.cboQuote.RowSource = "Quote"
Me.cboQuote.AddItem SEARCH_BLANK
' Mailed Date
Me.cboMailed.RowSource = "Mailed"
Me.cboMailed.AddItem SEARCH_BLANK
' Confirmed
Me.cboConfirmed.RowSource = "Confirmation"
Me.cboConfirmed.AddItem SEARCH_BLANK
' Status Repair
Me.cboStatusRepair.RowSource = "Status"
Me.cboStatusRepair.AddItem SEARCH_BLANK
' Status Completed
Me.cboStatusCompleted.RowSource = "Complete"
Me.cboStatusCompleted.AddItem SEARCH_BLANK
' Status Collection
Me.cboStatusCollection.RowSource = "Collection"
Me.cboStatusCollection.AddItem SEARCH_BLANK
End Sub
Private Sub PopulateComboBox(cbo As ComboBox, ws As Worksheet, colLetter As String)
Dim cell As Range
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
' Loop through the specified column, skipping the header
For Each cell In ws.Range(colLetter & "2:" & colLetter & ws.Cells(ws.Rows.Count, colLetter).End(xlUp).row)
If cell.Value <> "" Then
dict(cell.Value) = True ' Add unique values to the dictionary
End If
Next cell
' Add dictionary keys to the ComboBox
cbo.Clear
Dim key As Variant
For Each key In dict.Keys
cbo.AddItem key
Next key
End Sub
Private Sub cmdPrint_Click()
If Me.lstResults.ListCount = 0 Then
MsgBox "No results to print. Please search first.", vbExclamation
Exit Sub
End If
' Print each selected row from ListBox to the default printer
Dim i As Integer
For i = 0 To Me.lstResults.ListCount - 1
Debug.Print Me.lstResults.List(i, 0) & " " & Me.lstResults.List(i, 1) ' Customize for print formatting
Next i
MsgBox "Printing complete.", vbInformation
End Sub