Type Mismatch Using ActiveSheet.UsedRange - excel

Code below is supposed to hide all columns where any of its cells contain a certain value. If I directly specify a search Range, it works. However, if I use "ActiveSheet.UsedRange", it throws a type mismatch error. What is going on?
Sub HideColumn()
Dim MySel As Range
For Each cell In ActiveSheet.UsedRange
If cell.Value = "X123" Then
If MySel Is Nothing Then
Set MySel = cell
Else
Set MySel = Union(MySel, cell)
End If
End If
Next cell
MySel.EntireColumn.Hidden = True
End Sub

Hide Columns of Cells Equal To a String
If a cell contains an error value, the line If cell.Value = "X123" Then will fail with a Type mismatch error. In the following code, this is handled by converting the cell value to a string with CStr(cell.Value). Another way would be to add an outer (preceding) If statement If Not IsError(cell) Then.
Option Explicit would have warned you that the cell variable is not declared forcing you to do Dim cell As Range. Why don't you use it?
Option Explicit
Sub HideColumns()
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim rg As Range: Set rg = ActiveSheet.UsedRange
Dim crg As Range, cell As Range, urg As Range
For Each crg In rg.Columns
For Each cell In crg.Cells
If StrComp(CStr(cell.Value), "X123", vbTextCompare) = 0 Then
If urg Is Nothing Then
Set urg = cell
Else
Set urg = Union(urg, cell)
End If
Exit For ' match in column found; no need to loop anymore
End If
Next cell
Next crg
rg.EntireColumn.Hidden = False ' unhide all columns
If Not urg Is Nothing Then urg.EntireColumn.Hidden = True ' hide matching
End Sub

Related

How to define a range in a case statement?

I want to delete a column if a cell within a range (in this case the very first row) contains a specific value. I thought I could do it like this:
Public Sub Delete_Column()
Select Case Range(A1:A10)
Case "Birthday", "Gender"
cell.EntireColumn.Delete
End Select
End Sub
But it's not working. I'm sure it's the Select Case Range(A1:A10) line that's wrong, but I don't know how to fix it.
Delete Columns (Using Union)
Sub DeleteColumns()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim drg As Range
Dim cell As Range
' First 10 cells (columns) in the first worksheet row.
For Each cell In ws.Range("A1").Resize(, 10).Cells
' Specified single-row range in the first worksheet row.
'For Each cell In ws.Range("A1:J1").Cells
Select Case CStr(cell.Value)
Case "Birthday", "Gender"
If drg Is Nothing Then
Set drg = cell
Else
Set drg = Union(drg, cell)
End If
'Case Else ' do nothing
End Select
Next cell
If drg Is Nothing Then Exit Sub ' no cell found
drg.EntireColumn.Delete
End Sub
Range("A1:A10") is not a first row, it's the column A for the first row.
Perhaps you mean Range("A1:J1") ?
Try the modified code below:
Public Sub Delete_Column()
Dim Rng As Range, C As Range
' set the Range object
Set Rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:A10") ' <-- replace "Sheet1" with your sheet's name
' first row should be:
Set Rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:J1") ' <-- replace "Sheet1" with your sheet's name
' loop over each cell in your Range
For Each C In Rng.Cells
Select Case C.Value
Case "Birthday", "Gender"
C.EntireColumn.Delete
End Select
Next C
End Sub
This should do what you're looking for.
Note use of the Range.Find method:
Public Sub Delete_Column()
Dim rng As Excel.Range, searchValue As Variant
Set rng = Range("A1:A10")
searchValue = "q"
If Not rng.Find(searchValue, LookIn:=xlValues) Is Nothing Then
Debug.Print "found"
Else
Debug.Print "not found"
End If
End Sub
you could:
hide "valid" columns
delete visible (-> "invalid") ones
Sub DeleteColumns()
With ThisWorkbook.Worksheets("Sheet1").Range("A1:J1")
Dim cel As Range
For Each cel In .Cells
Select Case cel.Value
Case "Birthday", "Gender"
Case Else
cel.EntireColumn.Hidden = True ' hide "valid" columns
End Select
Next
On Error Resume Next ' ignore any error should no columns have been hidden
.SpecialCells(xlCellTypeVisible).EntireColumn.Delete ' delete hidden columns
.EntireColumn.Hidden = False ' make all "valid" columns back visible
End With
End Sub

VBA - copy data from range and paste in same range in other file

I'm trying to find a solution for macro described below in steps - it should copy data from range in one file and then paste it in other file in same range as original data:
Find coloured cells in sheet, select them and copy
Go to other file to sheet named same as source sheet
Paste data in same ranges as in source file (e.g. if data was copied from range A4:B20, A22:B24 and E4:G20 [selection will always contain union of ranges like this] I want to use same ranges in destination to paste data)
In below code I get error "Application-defined or object-defined error" and part of code "With ActiveSheet.Range(SelectedRng)" highlighted in yellow.
Could you please help me find a solution for this?
Sub SelectCellsWithColorIndex()
Const rgAddress As String = "A1:AZ300"
Const cIndex As Long = 37
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range(rgAddress)
Dim sh_name As String
Dim crg As Range
Dim cell As Range
Dim SelectedRng As Range
Application.ScreenUpdating = False
For Each cell In rg.Cells
If cell.Interior.ColorIndex = cIndex Then
If crg Is Nothing Then
Set crg = cell
Else
Set crg = Union(crg, cell)
End If
End If
Next cell
If crg Is Nothing Then
MsgBox "No coloured cells in range.", vbExclamation
Else
crg.Select
End If
Set SelectedRng = ActiveSheet.Range(Selection.Address)
SelectedRng.Copy
sh_name = ActiveSheet.Name
Workbooks("Workbook2.xlsx").Activate
Worksheets(sh_name).Activate
With ActiveSheet.Range(SelectedRng)
.PasteSpecial xlPasteValues
End With
Application.ScreenUpdating = True
End Sub
Please, try the next way. It uses Find with SearchFormat parameter and should be much faster than iteration between each cell in the range. Then, a discontinuous (Union) range cannot be copied at once. In order to also be fast, an iteration between the discontinuous range areas are necessary and clipboard should not be used. Selecting, activating only consumes Excel resources, not bringing any benefit, too:
Sub SelectCellsWithColorIndex()
Const rgAddress As String = "A1:AZ300"
Const cIndex As Long = 37
Dim ws As Worksheet: Set ws = ActiveSheet
Dim ws2 As Worksheet: Set ws2 = Workbooks("Workbook2.xlsx").Worksheets(ws.name) 'it must exist!
Dim rg As Range: Set rg = ws.Range(rgAddress)
Dim crg As Range, blueCell As Range, firstAddress As String, A As Range
'Sets or returns the search criteria for the type of cell formats to find:
With Application.FindFormat
.Clear
.Interior.ColorIndex = cIndex
.Locked = True
End With
Set blueCell = rg.Find(what:=vbNullString, SearchFormat:=True)
If Not blueCell Is Nothing Then
firstAddress = blueCell.Address
Do
If crg Is Nothing Then Set crg = blueCell Else Set crg = Union(crg, blueCell)
Set blueCell = rg.Find(what:=vbNullString, After:=blueCell, SearchFormat:=True)
Loop While blueCell.Address <> firstAddress
Else
MsgBox "no cell with (that) blue color found", vbInformation, "No blue cells...": Exit Sub
End If
For Each A In crg.Areas
ws2.Range(A.Address).Value = A.Value
Next A
End Sub
Please, send some feedback after testing it.
Is the Union range is huge, Application.ScreenUpdating = False and Application.Calculation = xlCalculationManual at the beginning of copying loop followed by Application.ScreenUpdating = True and Application.Calculation = xlCalculationAutomatic after, will help a litle. Otherwise, for a reasonable number of cells it will be fast enough without any optimization...

Search range for all cells with specific text and change the value of all adjacent cell to 0

Looking for help to achieve searching a range of cells E9:E with All cells containing "Accommodation & Transportation" and changing the value of the cells adjacent to them with 0. , I was not able to get anything online with similar topic and I'm not too good with VBA coding, though i am able to understand what the code will provide in results.
I Have a Commandbutton1 with the below code :
Sub CommandButton1_click()
Dim blanks As Excel.Range
Set blanks = Range("F9:F" & Cells(Rows.Count, 5).End(xlUp).Row).SpecialCells(xlCellTypeBlanks)
blanks.Value = blanks.Offset(0, -1).Value
End Sub
Further i have a command button that will select only cells that are not blank. I need the above result because if the below code selects Non Blank cells from Columns E:F it wont be selecting cells adjacent to those containing "Accommodation & Transportation" as they are blank cells and it will return the error "Runtime Error '1004' This action wont work on multiple selections".
The below code acts the same as [Go to Special => Constants]
Sub SelectNonBlankCells()
Dim rng As Range
Dim OutRng As Range
Dim InputRng As Range
Dim xTitle As String
On Error Resume Next
xTitle = Application.ActiveWindow.RangeSelection.Address
Set InputRng = Range("E8:F500")
ActiveWindow.ScrollRow = 1
For Each rng In InputRng
If Not rng.Value = "" Then
If OutRng Is Nothing Then
Set OutRng = rng
Else
Set OutRng = Application.Union(OutRng, rng)
End If
End If
Next
If Not (OutRng Is Nothing) Then
OutRng.Select
End If
End Sub
Maybe you can try another approach, if your goal is to edit cells adjacent to certain cells. The code below is based on an example in the Help file of the Range.Find function:
Sub DoSomething()
Dim sh As Worksheet
Set sh = ActiveSheet
Dim checkRange As Range
Set checkRange = sh.Range("E8:F500") ' your intended range to search
Dim foundRange As Range
Set foundRange = checkRange.Find("Accommodation & Transportation")
Dim firstAddr As String
If Not foundRange Is Nothing Then
firstAddr = foundRange.Address
Do
' use foundRange to access adjacent cells with foundRange.Offset(row, col)
'
'
foundRange.Offset(0, 1) = "all good"
Set foundRange = checkRange.FindNext(foundRange)
Loop While Not foundRange Is Nothing And foundRange.Address <> firstAddr
End If
End Sub
Or even better, you could add some parameters to make it more reusable:
Sub Main()
DoSomething "Accommodation & Transportation", ActiveSheet.Range("E8:F500")
End Sub
Sub DoSomething(ByVal findWhat As String, ByVal searchWhere As Range)
Dim foundRange As Range
Set foundRange = searchWhere.Find(findWhat)
Dim firstAddr As String
If Not foundRange Is Nothing Then
firstAddr = foundRange.Address
Do
' use foundRange to access adjacent cells with foundRange.Offset(row, col)
'
'
foundRange.Offset(0, 1) = "all good"
Set foundRange = searchWhere.FindNext(foundRange)
Loop While Not foundRange Is Nothing And foundRange.Address <> firstAddr
End If
End Sub

Excel VBA - For Each Loop Alternative

I have a For Each Loop that looks for cells that contain a string with a wildcard and if that string is not bold. If those conditions are met then that cell's row is deleted. I believe the For Each Loop is inefficient, and even with only around 200 rows the code takes a few seconds to run. Is there a more efficient way to achieve these results?
Dim Cell As Range
Dim sheetRange As Range
Set sheetRange = ActiveSheet.UsedRange
For Each Cell In sheetRange
Set Cell = sheetRange.Find(What:="Total*", lookat:=xlPart)
If Not Cell Is Nothing Then
If Cell.Font.Bold = False Then
Cell.EntireRow.Delete
End If
End If
Next Cell
Please take a look at the code below and see if you can adapt it to your specific use case. The DeleteTotalRows subroutine uses the built-in .Find method to jump specifically to cells that include the value 'Total'. It passes each of these cells to the MergeDeleteRange subroutine. This sub will build a range to delete, which contains all rows with the Total word and bold font.
Report back if you run into issues.
Option Explicit
Sub DeleteTotalRows()
Dim fnd As Range
Dim rngToDelete As Range
Dim firstFnd As Range
Dim sht As Worksheet
'Update this
Set sht = Worksheets("Sheet2")
With sht
Set fnd = .Cells.Find(what:="Total", lookat:=xlPart)
If fnd Is Nothing Then Exit Sub
Set firstFnd = fnd
Do
MergeDeleteRange rngToDelete, fnd
Set fnd = .Cells.Find(what:="Total", lookat:=xlPart, after:=fnd)
Loop While fnd.Address <> firstFnd.Address
End With
If rngToDelete Is Nothing Then Exit Sub
rngToDelete.Delete
End Sub
Private Sub MergeDeleteRange(ByRef outputRng As Range, ByRef inputCell As Range)
'Not deleting if the cell isn't bold
If Not inputCell.Font.Bold Then Exit Sub
'Create output range if it's still empty
If outputRng Is Nothing Then Set outputRng = inputCell.EntireRow
'Since you are testing multiple columns, confirm that the
'row isn't already in the output range
If Not Intersect(inputCell, outputRng) Is Nothing Then
Exit Sub
End If
Set outputRng = Union(outputRng, inputCell.EntireRow)
End Sub

How to delete a row if there is no value in a column?

I'm trying to delete rows in table if there is no value in a certain column.
I've used a code that deletes rows if there is one cell value missing, but I would like to delete rows if a cell does not contain a value in a certain column.
For example, if there is no value in Column G Row 5 then I want to delete the entire row.
Sub Test2()
Dim rng As Range
On Error Resume Next
Set rng = Range("Table3").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.Delete Shift:=xlUp
End If
End Sub
This deletes all rows with any type of missing cell value.
Two small changes:
Sub Test2()
Dim rng As Range
On Error Resume Next
Set rng = Range("G:G").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Delete Shift:=xlShiftUp
End If
End Sub
EDIT:
If you want to work directly with the table, then consider iterating over the ListRows of the table in question, something like this:
Sub Test2()
Dim myTbl As ListObject
Set myTbl = Sheet1.ListObjects("table3") ' change sheet as necessary
Dim indx As Long
indx = myTbl.ListColumns("ColumnName").Index
Dim rngToDelete As Range
Dim myRw As ListRow
For Each myRw In myTbl.ListRows
If IsEmpty(myRw.Range(1, indx).Value) Then
If rngToDelete Is Nothing Then
Set rngToDelete = myRw.Range
Else
Set rngToDelete = Union(rngToDelete, myRw.Range)
End If
End If
Next myRw
If Not rngToDelete Is Nothing Then
rngToDelete.Delete Shift:=xlShiftUp
End If
End Sub
Note: Technically, it's xlShiftUp, not xlUp.

Resources