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
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
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 very new to vba , currently i am looking for code to copy cell values from list to multiple sheet in specific cell
what i am trying to do is as per bellow sheet "point" i have a list with values column B are the names and C & D are values
i need to copy sheet named "template" and rename as per the values in Column B and the values are un defined and be upto any length
list sheet
template
currently i am using bellow code to copy sheet and rename as per list
Sub CopySheetRenameFromCell()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Sheets("template")
Set sh2 = Sheets("point")
For Each c In sh2.Range("B6", sh2.Cells(Rows.Count, 2).End(xlUp))
sh1.Copy After:=Sheets(Sheets.Count)
On Error Resume Next
ActiveSheet.Name = c.Value:
On Error GoTo 0
Next
End Sub
result sheet
but i have no idea how can i copy value from "point" Sheet Column C and D values 1 & 51 to sheet "a" Column C2 and F2 and so on
a values in sheet "a"
b values in sheet "b" and on
awaiting your help
Copy Template Worksheet
This is a basic code. It assumes that each of the cells of the range B6:BLastRow contains a valid value for naming a worksheet. It also assumes that each of the worksheets to be created does not exist already.
Option Explicit
Sub CopySheetRenameFromCell()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets("Point")
' Calculate the source last row ('slRow'),
' the row of the last non-empty cell in the column.
Dim slRow As Long
slRow = sws.Cells(sws.Rows.Count, "B").End(xlUp).Row
' Reference the template worksheets ('tws').
Dim tws As Worksheet: Set tws = wb.Worksheets("Template")
' Declare additional variables.
Dim dws As Worksheet ' Current Destination (Copied) Worksheet
Dim sr As Long ' Current Row in the Source Worksheet
' Loop through the rows of the source worksheet.
For sr = 6 To slRow
' Create a copy of the template worksheet after the last sheet
' in the workbook.
tws.Copy After:=wb.Sheets(wb.Sheets.Count)
' Reference this copy, the destination worksheet,
' which is the last (work)sheet in the workbook.
Set dws = wb.Sheets(wb.Sheets.Count)
' Rename the destination worksheet.
dws.Name = sws.Cells(sr, "B").Value
' Write the values from columns 'C' and 'D' in the row ('r')
' of the source worksheet to the cells `C2` and `F2` respectively
' in the destination worksheet.
dws.Range("C2").Value = sws.Cells(sr, "C").Value
dws.Range("F2").Value = sws.Cells(sr, "D").Value
Next sr
' Save the workbook.
'wb.Save
' Inform.
MsgBox "Point worksheets created.", vbInformation
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
'...
'...