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
Related
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
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
I am new to VBA macros. I am trying to create a macro that that finds column name "Load Type" applies filter on column value LCL and keep only data rows with LCL and removes rest all data rows.
Example Macro should work like
Search column named "Load Type"
Select/ Filter column Value with LCL
Remove all other data other than LCL
If column named "Load Type", value <> LCL then entire row delete.
I want the macro to keep only data with value LCL in column named Load Type and remove rest all data even if there is blank it should remove the entire row if load type is blank.
Column N heading is Load type has multiple values LCL, Blanks, BB. I want the macro to keep only data and corrospoding row with column "Load Type" value LCL and remove rest all data.
Desired output is in above image.
My coding image
I tried coading like this but its says variable not defined I am confused of do i fix this.
Sub SortLCL_Concat()
Dim wb As Workbook
Dim sRng As Range
Dim fRng As Range
Dim cel As Range
Dim tRow As Long
Dim fCol As Long
Set wb = ThisWorkbook
Set fRng = ActiveWorkbook.Worksheets("Main")
fCol = fRng.Column
tRow = ActiveWorkbook.Worksheets("Main").Cells(Rows.Count, 1).End(xlUp).Row
With ActiveWorkbook.Worksheets("Main")
For tRow = .Rows.Count To 2 Step -1
If .Cells(tRow, fCol).Value <> LCL Then .Rows(tRow).Delete
Next tRow
End With
End Sub
I want the macro to keep only data with value LCL in column named Load Type and remove rest all data even if there is blank it should remove the entire row if load type is blank.
Delete Data Rows Using AutoFilter
Option Explicit
Sub SortLCL_Concat()
Const wsName As String = "Main"
Const FilterColumnTitle As String = "Load Type"
Const FilterCriteria As String = "<>LCL"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
If ws.FilterMode Then ws.ShowAllData
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
Dim fCol As Long: fCol = Application.Match(FilterColumnTitle, rg.Rows(1), 0)
Dim drg As Range: Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1)
rg.AutoFilter fCol, FilterCriteria
Dim vdrg As Range
On Error Resume Next
Set vdrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False
If vdrg Is Nothing Then Exit Sub
vdrg.Delete xlShiftUp
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
'...
'...
I need to write a code in order to perform the below action:
From a column, select only the colored cells (eg. in yellow) and copy them under another column already filled with values at the bottom of the list
Here the code i wrote so far however i have troubles writing the part to copy the colored cells to the other sheet:
copycolor Sub m()
Dim wk As Workbook
Dim sh As Worksheet
Dim rng As Range
Dim C As Range
Set wk = ThisWorkbook
With wk
Set sh = .Worksheets("Base Dati Old")
End With
With sh
Set rng = .Range("A:A")
For Each C In rng
If C.Interior.ColorIndex = 46 Then
C.Copy
End If
Next C
End With
End Sub
Assuming you have headers in your data I'd advise to do two things:
Don't loop all cells in column A, it will slow down things significanlty.
If headers are present, applying a filter based on color might be a more optimal way.
For example:
Sub CopyColor()
Dim wk As Workbook: Set wk = ThisWorkbook
Dim sht As Worksheet: Set sht = wk.Worksheets("Base Dati Old")
Dim lr As Long, rng As Range
'Define last used row;
lr = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Set range;
Set rng = sht.Range("A1:A" & lr)
'Filter your data on yellow;
rng.AutoFilter 1, RGB(255, 255, 0), xlFilterCellColor
'Copy filtered cells;
rng.SpecialCells(12).Offset.Copy wk.Worksheets("DestinationSheet").Range("A1")
'Turn off filter
rng.AutoFilter
End Sub
Don't forget to change the name of the sheet you'd want to copy your data to. You may also need to find the last used row for that sheet and make that part dynamic.
Good luck.