Is there any way to efficiently convert all formulas on a sheet to values when there is an autofilter applied to the sheet?
I've explored saving the autofilter parameters, unfiltering to paste values, then refiltering using the saved parameters.. found some code that works but that is far too risky (and evidently only works with basic filtering logic used)
Would love to avoid a "for each cell" if possible, as some reports on sheets can be rather lengthy
Convert Formulas in Filter Worksheet To Values
Option Explicit
Sub FilteredToValues()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets("Sheet1") ' adjust!
Dim srg As Range: Set srg = sws.UsedRange
If Not sws.FilterMode Then ' the worksheet is not in filter mode
srg.Value = srg.Value ' or whatever
Exit Sub
End If
' When the worksheet is in filter mode, that means that at least
' one row is hidden. It also means that at least one row, the header row,
' is visible. Thus no error handling is necessary.
Dim arg As Range
' Convert the visible range.
' Reference the visible rows.
Dim vrg As Range: Set vrg = srg.SpecialCells(xlCellTypeVisible)
' Convert by looping through the areas of the visible range.
For Each arg In vrg.Areas
arg.Value = arg.Value
Next arg
' Convert the hidden range.
' Reference the visible cells in the first column.
Dim vcrg As Range: Set vcrg = Intersect(srg.Columns(1), vrg)
Dim urg As Range, cel As Range
' Combine the hidden cells of the first column into a range.
For Each cel In srg.Columns(1).Cells
If Intersect(cel, vcrg) Is Nothing Then
If urg Is Nothing Then Set urg = cel Else Set urg = Union(urg, cel)
End If
Next cel
' Reference the hidden rows.
Dim hrg As Range: Set hrg = Intersect(urg.EntireRow, srg)
' Convert by looping through the areas of the hidden range.
For Each arg In hrg.Areas
arg.Value = arg.Value
Next arg
MsgBox "Formulas converted to values.", vbInformation
End Sub
Related
Inspection templates
Depending on which inspection is going to be undertaken I load the inspection sheet (a name defined selection) from Inspection template and add it to a worksheet that contains all the tag information for a selected tag to be inspected
Sub copycells()
' copycells Macro
'
'
Application.Goto Reference:="Ex_d_Visual"
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("A9").Select
ActiveSheet.Paste
End Sub
the problem is that the merged cells height does not copy across to the new worksheet.
"EX_d_Visual" = A1:K41
I have tried many different copy paste options and paste special options but can't seem to get it to work, I think that I may need to use a "for cell next" loop and get each original cell height then set the new sheet equivalent cell to the same height. getting the cell height from the original is doable using the range "Ex_d_Visual" but just not sure how to set the new sheet as I only know the single cell that I have copied into.
Adjust Row Height in a Copied Range
Sub CopyCells()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim srg As Range: Set srg = wb.Names("Ex_d_Visual").RefersToRange
Dim dws As Worksheet: Set dws = wb.Sheets("Sheet1")
Dim dCell As Range: Set dCell = dws.Range("A9")
srg.Copy dCell
Dim sCell As Range
For Each sCell In srg.Cells
dCell.RowHeight = sCell.RowHeight
Set dCell = dCell.Offset(1)
Next sCell
End Sub
In your case, since you know that the destination merged range will have the same number of rows in it, you can define it using .Resize to be identical in size to the source range.
Then looping over the rows to apply the original row height could look like this:
Const RangeName = "Ex_d_Visual"
Const SheetName = "Sheet1"
Const RangeAddress = "A9"
Dim SourceRange As Range
Set SourceRange = ThisWorkbook.Names(RangeName).RefersToRange
Dim DestinationRange As Range
Set DestinationRange = ThisWorkbook.Sheets(SheetName).Range(RangeAddress).Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)
Dim Row As Range, Offset As Long
For Each Row In SourceRange.Rows
DestinationRange.Rows(1 + Offset).RowHeight = Row.Height
Offset = Offset + 1
Next Row
I am trying to make a Range object of all entrys and than apply a filter, which searches for a number in there.
I want the Range to hold only the matching entrys afterwards, but I always get the error 1004...
Here the code:
Dim rSearch As Range
Dim rResult As Range
Set rSearch = wbMe.Sheets(iCurSheet).Range("F2:F1000")
rSearch.AutoFilter Field:=iColKey, Criteria1:="=" & wbMe.Sheets(iCurSheet).Cells(iLine, iColKey).Value
The last line throws the exception. I found out that the AutoFilter has to be applied to the first line, so .Range("A1:K1"), but I still don't get why I am not able to Filter on a Range, maybe i get the Object wrong?
Thanks in advance!
Edit:
So I tried some stuff:
Set rSearch = wbMe.Sheets(iCurSheet).Range("A2:K1000")
rSearch.AutoFilter Field:=11, Criteria1:="=" & wbMe.Sheets(iCurSheet).Cells(iLine, iColKey).Value
MsgBox "Count Rows rSearch:" & rSearch.Rows.Count
I expected the MsgBox to say smth less, but I get 999, so it hasn't filtered anything.
My guess that I was filtering the wrong column, but I wanna filter on Col K (I need Col F afterwards to search once more, sry for mixing stuff up).
Now I don't get the AutoFilter exception anymore. But for some reason my rSearch range does not shrink.
How do I shrink my Range?
Count Visible Data Cells (Criteria Cells)
A quick fix could be something like
MsgBox "Count Rows rSearch:" & rSearch.Columns(11).SpecialCells(xlCellTypeVisible).Cells.Count - 1
Note that the headers need to be included in the range for AutoFilter to work correctly.
Using SpecialCells
Sub CountVisibleDataCells()
' Define constants.
Const CriteriaIndex As Long = 11
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the range ('rg').
Dim rg As Range: Set rg = ws.Range("A1:K21")
' Store the criteria value from the cell, converted to a string ('CStr'),
' in a string variable ('Criteria'). AutoFilter 'prefers' this.
Dim Criteria As String: Criteria = CStr(ws.Range("M1").Value)
' Filter the range.
rg.AutoFilter Field:=CriteriaIndex, Criteria1:=Criteria
' Reference the visible cells in the criteria column ('vrg').
Dim vrg As Range
Set vrg = rg.Columns(CriteriaIndex).SpecialCells(xlCellTypeVisible)
' Turn off the worksheet auto filter.
ws.AutoFilterMode = False
' Store the number of visible cells of the criteria column
' in a long variable (subtract 1 to not count the header).
Dim CriteriaCount As Long: CriteriaCount = vrg.Cells.Count - 1
' Inform.
MsgBox "Count of '" & Criteria & "': " & CriteriaCount
End Sub
Using Application Count
Sub CountCriteriaCells()
' Define constants.
Const CriteriaIndex As Long = 11
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the range ('rg').
Dim rg As Range: Set rg = ws.Range("A1:K21")
' Store the criteria value from the cell, converted to a string ('CStr'),
' in a string variable ('Criteria').
Dim Criteria As String: Criteria = CStr(ws.Range("M1").Value)
' You may need to modify this because 'CountIf' works differently.
' Reference the criteria data range ('cdrg') (no headers).
Dim cdrg As Range
With rg.Columns(CriteriaIndex)
Set cdrg = .Resize(.Rows.Count - 1).Offset(1)
End With
' Store the number of cells containing the criteria ('CriteriaCount')
' in a long variable.
Dim CriteriaCount As Long
CriteriaCount = Application.CountIf(cdrg, Criteria)
' Inform.
MsgBox "Count of '" & Criteria & "': " & CriteriaCount
End Sub
I am trying to copy part of a range of data from Sheet "Source" to sheet "Target" when clicking a button. The real code is more complex this is a simple example to illustrate the question.
My test data has 6 rows and 2 columns and I am trying to copy 3 rows and 2 columns.
When I am trying to copy the first 3 rows, it always copies the complete column:
Sub ButtonCopySourceToTarget_Clicked()
Set vbaPractice= ThisWorkbook
Set mySource = vbaPractice.Worksheets("Source")
Set myTarget = vbaPractice.Sheets("Target")
' The second parameter of the Range function (&3) gets ignored - why?
mySource.Range("A1:B1" & 3).Copy
myTarget.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub
Copy Values More Efficiently
Option Explicit
Sub ButtonCopySourceToTarget_Clicked()
' Reference the workbook and the worksheets.
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("Source")
Dim tws As Worksheet: Set tws = wb.Worksheets("Target")
' Reference the source range ('srg').
Dim srg As Range: Set srg = sws.Range("A1:B7")
' Reference the first three rows of the source range,
' the source copy range ('scrg').
Dim scrg As Range: Set scrg = srg.Resize(3)
' Reference the first target cell ('tfCell').
Dim tfCell As Range: Set tfCell = tws.Range("A1")
' Reference the target range ('trg'), a range of the same size as
' the source copy range.
Dim trg As Range
Set trg = tfCell.Resize(scrg.Rows.Count, scrg.Columns.Count)
' Copy values by assignment (most efficient).
trg.Value = scrg.Value
End Sub
The code works when the criteria exists. I get an error when the criteria doesn't exist.
' Define constants.
Const srcName As String = "wfm_rawdata"
Const srcFirst As String = "D2" ' Location for Group
Const dstName As String = "bond_insurance"
Const dstFirst As String = "A2" ' do not change the 'A' (entire row).
'This function will transfer rows from one worksheet to another worksheet
' if the value = specified critiera
' Define workbook.
Dim wb As Workbook: Set wb = ActiveWorkbook ' Workbook containing this code.
' Define Source Range
Dim LastRow As Long
Dim srg As Range
' Define worksheet and column am working on and
' getting the range of last used cell using(LastRow)
With wb.Worksheets(srcName).Range(srcFirst)
LastRow = .Offset(.Worksheet.Rows.Count - .Row).End(xlUp).Row
Set srg = .Resize(LastRow - .Row + 1, 10)
End With
'Combine' critical cells into a range.
Dim brg As Range ' Built Range --> Range in the new sheet
Dim cel As Range ' Current Cell Range --> Range in the current sheet(rawdata)
'for every cell in group within wfm_rawdata sheet if the value = GO
For Each cel In srg.Cells
If cel.Value = "BOND INSURANCE" Then
' If the range in the new sheet have nothing then
' add specific criteria from the group in wfm_rawdata
If brg Is Nothing Then
Set brg = cel
' if there is range in there combine the new and
' old range together using -> Union function
Else
Set brg = Union(brg, cel)
End If
End If
Next cel
Application.ScreenUpdating = False
' Copy and delete critical rows of Source Range.
With wb.Worksheets(dstName).Range(dstFirst)
.Resize(.Worksheet.Rows.Count - .Row + 1, _
.Worksheet.Columns.Count).clear
Set brg = brg.EntireRow ' 'Convert' cells into rows.
brg.Copy .Offset ' Copy. 'Offset' because range is in 'With'.
brg.Delete ' Delete.
End With
How can I use a Boolean or other function to bypass the above code if the criteria doesn't exist?
For example if criteria "dog" exists then run the code and if it doesn't exist bypass the code.
I use this code to run three modules with code similar to the top code.
Sub master()
Call report1
Call report2
Call report3
End Sub
One you've assigned srg you can use Match() to check whether it contains any instances of the term you're interested in:
'...
'...
' Define worksheet and column am working on and getting the range of last used cell using(LastRow)
With wb.Worksheets(srcName).Range(srcFirst)
LastRow = .Offset(.Worksheet.Rows.Count - .Row).End(xlUp).Row
Set srg = .Resize(LastRow - .Row + 1, 10)
End With
'Exit if "BOND INSURANCE" is not found in `srg`
If IsError(Application.Match("BOND INSURANCE", srg, 0)) Then Exit Sub
'...
'...
In the picture below, I'm trying to hide the rows that are empty in a certain cells (e.g. Row 39 to Row 48). Is is possible to do it in one click? I'm planning of doing it with VBA.
This is the formula that I'm currently using but the thing is the cells that I want to hide may not start at row 39 or ends at row 48, it depends on the data.
Sub HideRows()
Dim ws As Worksheet
For Each ws In Worksheets(Array("NAMES", "AUGUST"))
'ws.Rows("39:48").Hidden = True
Next
End Sub
Hide 'Empty' Rows
This is a slightly different approach:
uses Option Explicit
uses constants and variables
uses For Each...Next loops for both, worksheets and cells
qualifies all objects (e.g. ws.Cells or rg.Cells, not just Cells)
combines empty cells into a range
unhides all rows in one go, then hides the 'empty' rows in another (go)
Option Explicit
Sub HideRows()
Const StartRow As Long = 9
Const EndRow As Long = 89
Const ColNum As Long = 3
Dim WorksheetNames As Variant
WorksheetNames = Array("NAMES", "AUGUST") ' add more
Dim ws As Worksheet ' Current Worksheet
Dim rg As Range ' Current Range
Dim hrg As Range ' Current Hide Range
Dim cCell As Range ' Current Cell in Range
' Loop through the worksheets in the workbook containing this code.
For Each ws In ThisWorkbook.Worksheets(WorksheetNames)
' Create a reference to the range of the current worksheet.
Set rg = ws.Range(ws.Cells(StartRow, ColNum), ws.Cells(EndRow, ColNum))
' or using resize:
'Set rg = ws.Cells(StartRow, ColNum).Resize(EndRow - StartRow + 1)
' Loop through the cells of the current range.
For Each cCell In rg.Cells
If IsEmpty(cCell) Then ' cell is empty
' Combine ('add') the current cell into the hide range.
If Not hrg Is Nothing Then ' for all except the first
Set hrg = Union(hrg, cCell)
Else ' for the first
Set hrg = cCell
End If
'Else ' cell is not empty - do nothing
End If
Next cCell
' Unhide all rows of the current range of the current worksheet.
rg.EntireRow.Hidden = False
If Not hrg Is Nothing Then ' there are combined cells
' Hide the rows of the hide range.
hrg.EntireRow.Hidden = True
' Reset the hide range variable for the next worksheet.
' Also, note that 'Union' works only with ranges from one worksheet.
Set hrg = Nothing
'Else ' there are no combined cells - do nothing
End If
Next ws
End Sub
I already made it. Below is the script that I used.
Sub HideRows()
Dim ws As Worksheet
For Each ws In Worksheets(Array("NAMES", "AUGUST"))
StartRow = 9
EndRow = 89
ColNum = 3
For i = StartRow To EndRow
If Not IsEmpty(Cells(i, ColNum).Value) Then
ws.Cells(i, ColNum).EntireRow.Hidden = False
Else
ws.Cells(i, ColNum).EntireRow.Hidden = True
End If
Next i
Next
End Sub