I would like to select only rows with the value unchecked but I am getting an error due to type mismatch. Please advise
Sub Hide_Rows()
If Range("D3:F100").Value = "Checked" Then
Rows("3:100").EntireRow.Hidden = True
ElseIf Range("D3:F100").Value = "Unchecked" Then
Rows("3:").EntireRow.Hidden = False
End If
End Sub
You cannot test an array of values to one value:
If Range("D3:F100").Value = "Checked" Then
will always error. You need to loop and check each value individually:
This will un-hide the row if any of the values in Columns D,E,F are Unchecked All others will be hidden.
Sub Hide_Rows()
ActiveSheet.Range("3:100").EntireRow.Hidden = True
Dim i As Long
For i = 3 To 100
Dim j As Long
For j = 4 To 6
If ActiveSheet.Cells(i, j) = "Unchecked" Then
Dim UnRng As Range
If UnRng Is Nothing Then
Set UnRng = ActiveSheet.Rows(i)
Else
Set UnRng = Union(UnRng, ActiveSheet.Rows(i))
End If
Exit For
End If
Next j
Next i
UnRng.EntireRow.Hidden = False
End Sub
Related
When applying this code I am running into the issue that the top most filtered Item isn't being counted.
IE: When trying to delete the data within a Table if i have 1 entry TestEmptyTable() Returns False.
If i try to count the header as an entry and mark as >= 2 then it doesn't delete the top most entry. When it is >=1 It attempts to delete the whole sheet- When it is >1 it does nothing for the topmost entry but gets everything else. Referring to this section below when saying '>'
The Entire code is below the first code entry.
Any advise on how to get this Pesky first entry in my filtered tables?
Edit- I have learned the values that are being counted in tbl.Range.SpecialCells are not aligned with what i actually have, trying to fix that.
If tbl.Range.SpecialCells(xlCellTypeVisible).Areas.Count >= 2 Then
tblIsVisible = True
Else
If tbl.Range.SpecialCells(xlCellTypeVisible).Areas.Count < 1 Then
tblIsVisible = False
End If
End If
'In Module6
Function TestEmptyTable()
Dim tbl As ListObject
Dim tblIsVisible As Boolean
Set tbl = ActiveSheet.ListObjects(1)
If tbl.Range.SpecialCells(xlCellTypeVisible).Areas.Count >= 2 Then
tblIsVisible = True
Else
If tbl.Range.SpecialCells(xlCellTypeVisible).Areas.Count < 1 Then
tblIsVisible = False
End If
End If
TestEmptyTable = tblIsVisible
'MsgBox (TestEmptyTable)
End Function
Function DelTable()
Application.DisplayAlerts = False
If TestEmptyTable() = True Then
'MsgBox ("TestEmptyTable = True")
ActiveSheet.ListObjects("Table1").DataBodyRange.Delete
Else
'MsgBox ("TestEmptyTable= False")
End If
Application.DisplayAlerts = True
End Function
'In Module5
Sub DeleteTable()
'
'
'
'
If Module6.TestEmptyTable = True Then
Call Module6.DelTable
End If
End Sub
'in Module1
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=3, Criteria1:="MyFilterString"
MsgBox (Module6.TestEmptyTable)'Still here from trying to test what happens.
Call DeleteTable
I had some problems to understanding what you needed.
I think this code might help you achieved what you need.
Option Explicit
Sub Main()
Dim ol As ListObject: Set ol = ActiveSheet.ListObjects(1)
If isTableEmpty(ol) Then
Debug.Print "table empty"
Exit Sub
Else
Debug.Print "table not empty"
If TableHasFilters(ol) Then
Call TableDeleteFilteredRows(ol)
Else
ol.DataBodyRange.Delete
End If
End If
End Sub
Function isTableEmpty(ol As ListObject) As Boolean
If ol.ListRows.Count = 0 Then isTableEmpty = True
End Function
Function TableHasFilters(ol As ListObject) As Boolean
TableHasFilters = ol.AutoFilter.FilterMode
End Function
Sub TableFilterRestore(ol As ListObject)
If ol.AutoFilter.FilterMode Then ol.AutoFilter.ShowAllData
End Sub
Function TableVisibleRowsCount(ol As ListObject) As Integer
If ol.ListRows.Count > 0 Then
TableVisibleRowsCount = ol.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Count
End If
End Function
Sub TableDeleteFilteredRows(ol As ListObject)
Dim rCell As Range
Dim olRng As Range
Dim olRowHd As Integer
Dim lrIdx As Integer
Dim arr() As Variant
Dim i As Integer: i = 0
' Exit if table has no rows
If ol.ListRows.Count = 0 Then Exit Sub
' Set variables
Set olRng = ol.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible)
olRowHd = ol.HeaderRowRange.Row
' Count filtered rows
Dim nRows As Integer: nRows = TableVisibleRowsCount(ol)
' Redim array
ReDim arr(1 To nRows)
' Popuplate array with listrow index of visible rows
For Each rCell In olRng
' get listrow index
lrIdx = ol.ListRows(rCell.Row - olRowHd).Index
' Add item to array
i = i + 1
arr(i) = lrIdx
Next rCell
' Clear table filters
Call TableFilterRestore(ol)
' Delete rows
For i = UBound(arr) To LBound(arr) Step -1
ol.ListRows(arr(i)).Delete
Next i
End Sub
I'd like to write a VBA code that checks if a cell has an image and if it does print something (could be anything, in this case I chose a number 1) in the same row as the image, in column #6.
I keep getting the "Argument not Optional" Error on the first line of the sub. Curious if someone can help me! Thank you!!
Function CellImageCheck(CellToCheck As Range) As Integer
' Return 1 if image exists in cell, 0 if not
Dim wShape As Shape
For Each wShape In ActiveSheet.Shapes
If wShape.TopLeftCell = CellToCheck Then
CellImageCheck = 1
Else
CellImageCheck = 0
End If
Next wShape
End Function
Sub testFunction()
Dim i As Integer
Application.ScreenUpdating = False
For i = 3 To 10 Step 1
If CellImageCheck(Cells(i, 1)) Then
Cells(i, 6) = CellImageCheck
Else
End If
Next i
End Sub
As per my comment:
Function CellImageCheck(CellToCheck As Range) As Boolean
' Return True if image exists in cell, False if not
CellImageCheck = False
Dim wShape As Shape
For Each wShape In ActiveSheet.Shapes
If wShape.TopLeftCell.Address = CellToCheck.Address Then
CellImageCheck = True
Exit For
End If
Next wShape
End Function
Sub testFunction()
Application.ScreenUpdating = False
With Worksheets("Sheet1") 'Change this to the sheet being tested.
Dim i As Long
For i = 3 To 10 Step 1
Dim bl As Boolean
bl = False
bl = CellImageCheck(.Cells(i, 1))
If bl Then .Cells(i, 6) = bl
Next i
End With
End Sub
I am attempting to write code to enter in next available row a value of 1 when a checkbox is checked and value of 0 if unchecked.
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
Set LastRow = Sheet9.Range("a70000").End(xlUp)
LastRow.Offset(1, 2).Value = 1
End If
If CheckBox2.Value = False Then
LastRow.Offset(1, 2).Value = 0
End If
End Sub
Private Sub enterMDGfunction_Click()
Dim LastRow As Object
Set LastRow = Sheet9.Range("a70000").End(xlUp)
Unload Me
DataEntrySystemHomepage.Show
End Sub
Currently it wont enter into next available row. After one entry the datasheet stops populating. Does it have to do with my unload form code?
Set LastRow = Sheet9.Range("a70000").End(xlUp)
LastRow.Offset(1, 2).Value = 1
This enters a value one row down from LastRow, in Col C, but because you never put anything new in Col A, the next time you get LastRow it will again return the same cell in ColA as previously.
Either put something in Col A, or perform the end(xlup) from Col C
With a bit of re-work it's simpler as:
Private Sub CheckBox2_Click()
Sheet9.Range("C70000").End(xlUp).Offset(1, 0).Value = _
IIf(CheckBox2.Value, 1, 0)
End Sub
I have a column range of about 500 rows. Most of those cells are stored as text. I populate a listbox on a userform with the values from that range. When a user selects one of those values from the listbox an event will find the value on the same row from another column using Index and Match and display it in a label on the userform. I get an error when selecting one of the few cells in the listbox that are not stored as text in the range because there is a leading space. I am assuming that the populated listbox automatically removes leading spaces from any cells in the range. Therefore, when it tries to find value 12345 from the listbox, for example, in the range it can't find it because the range contains (space)12345. I have tried:
Public Sub UserForm_Initialize()
Dim arr() As Variant
Dim rNum As Range
Const sNum As String = "Number"
Me.EnableEvents = False
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pReport
If .AutoFilterMode = True Then .ShowAllData
.Cells.Rows.Hidden = False
.Cells.Columns.Hidden = False
End With
Set wf = Application.WorksheetFunction
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
End With
-- HERE is where I tried all my implementations without success
arr = wf.Transpose(pReport.Range(rNum.address).Value)
Call BubbleSort(arr)
frmIssues.lstIssues1.List = arr
lstIssues1.ListStyle = 1
lstIssues2.ListStyle = 1
lstIssues1.MultiSelect = 2
lstIssues2.MultiSelect = 2
txtFocus.SetFocus
Me.EnableEvents = True
End Sub
Private Sub lstIssues1_Change()
Dim rNum As Range
Dim rTitle As Range
Dim strResult As String
Dim intIndex As Integer
Dim intCount As Integer
Const sNum As String = "Number"
Const sTitle As String = "Title"
If EnableEvents = False Then Exit Sub
With lstIssues1
For intIndex = 0 To .ListCount - 1
If .Selected(intIndex) Then intCount = intCount + 1
Next
End With
If intCount = 1 Then
Set wf = Application.WorksheetFunction
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
Set rTitle = .ListColumns(.ListColumns(sTitle).Range.column).DataBodyRange
End With
With pReport
strResult = wf.Index(.Range(rTitle.address), wf.Match(lstIssues1.List(lstIssues1.ListIndex), .Range(rNum.address), 0))
End With
lblDescription.Caption = wf.Trim(strResult)
txtFocus.SetFocus
Else
lblDescription.Caption = ""
txtFocus.SetFocus
Exit Sub
End If
Me.EnableEvents = False
For i = 0 To lstIssues2.ListCount - 1
If lstIssues2.Selected(i) = True Then lstIssues2.Selected(i) = False
Next
Me.EnableEvents = True
End Sub
and numerous variations of it (Clean, CStr, .Text, etc.) and nothing works. Truly, I have no clue how to fix this and any help whatsoever is much appreciated. Thank you!
Clarification
1) This Excel file is generated from the Web.
2) A Macro turns the Worksheet into a table
3) Left(Range("D362"),1) returns 1 (The number, say, is 12345)
4) Before the error occurs Range("D362") returns (space)12345
5) After the error occurs Range("D362") returns (space)12345
I have just tested this and it works in removing the space at the begining of a string. Sadly it isnt a single line as I (and likely you) would have prefered
Sub test()
Dim CellValue As String
Dim lngNumberOfCharacters As Long
CellValue = ActiveCell.Value
CellValueCheck = Left(CellValue, 1)
If CellValueCheck = " " Then
lngNumberOfCharacters = Len(CellValue) - 1
CellValue = Right(CellValue, lngNumberOfCharacters)
ActiveCell.Value = CellValue
End If
End Sub
Let me know if you need anything confirmed
I'm trying to write some code to Hide columns if the first 3 characters of cells in a range equal the contents of another. I have the code for hiding columns if cells in a range are blank as this;-
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, cell As Range
On Error GoTo ErrHandler
Set r = Me.Range("C8:R8")
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each cell In r
If cell.Value = "" Then
cell.EntireColumn.Hidden = True
Else
cell.EntireColumn.Hidden = False
End If
Next
ErrHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
And the code for identifiying the first 3 charcters of a cell;-
Dim LResult As String
LResult = Left ("Alphabet",3)
But how do I combine the two, referencing a specific cell rather than "Alphabet"?
Cant get this to work - any suggestions?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, cell As Range
On Error GoTo ErrHandler
Set r = Me.Range("B7:CG7")
Application.ScreenUpdating = False
Application.EnableEvents = False
Row = 1
col = 1
For Each cell In r
If cell.Value = "" And Left(cell.Value, 3) = cell(Row, col).Value Then
cell.EntireColumn.Hidden = True
Else
cell.EntireColumn.Hidden = False
End If
Next
ErrHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Cheers
You have almost the working code. You are comparing cell.Value to an empty string - now just apply Left to it
LResult = Left (cell.Value,3)
Edit:
row = 20
col = 30
For Each cell In r
If cell.Value = "" and Left (cell.Value,3) = Cell(row, col).Value Then
cell.EntireColumn.Hidden = True
Else
cell.EntireColumn.Hidden = False
End If
where you want data from cell at row and col (I used 20, 30 as the example)