I am trying to create a VBA template that can be used to suppress all data values under a certain amount. I have found/updated some code I found online that does successfully create a new sheet, transfer the selected data, and replace all numeric values 30 and under with "< 30" as desired. However, it also updates the original data source, replacing the data selected instead of only updating the data on the new sheet. How can I prevent it from modifying the original data and only modifying the data copied to the new sheet?
I've tried this code here, but am not getting the desired results and have been unable to figure out how to modify it to achieve them:
Sub SuppressLessThan()
Dim Rng As Range
Dim WorkRng As Range
Dim ws As Worksheet
On Error Resume Next
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Select the cells you are working with:", "Select Range", WorkRng.Address, Type:=8)
Set ws = Worksheets.Add
WorkRng.Copy
For Each Rng In WorkRng
If Rng.Value < 30 Then
Rng.Value = "< 30"
End If
Next
With ws.Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValuesAndNumberFormats
End With
ws.Columns("A").AutoFit
Application.CopyCutMode = False
End Sub
It currently copies the selected range and updates both the original data source and new sheet with the suppressed values. How can I prevent it from modifying the original data and only transform the copied data?
Give this a try:
Sub SuppressLessThan()
Dim wb As Workbook
Dim ws As Worksheet
Dim Rng As Range
Dim WorkRng As Range
Dim dTargetNum As Double
Dim sDefault As String
dTargetNum = 30
If TypeName(Selection) = "Range" Then sDefault = Selection.Address
On Error Resume Next
Set WorkRng = Application.InputBox("Select the cells you are working with:", "Select Range", sDefault, Type:=8)
On Error GoTo 0
If WorkRng Is Nothing Then Exit Sub 'Pressed cancel
Set wb = WorkRng.Worksheet.Parent
Set ws = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
WorkRng.Copy
ws.Range("A1").PasteSpecial xlPasteValues
ws.Range("A1").PasteSpecial xlPasteFormats
ws.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
For Each Rng In ws.UsedRange.Cells
If Rng.Value < dTargetNum Then Rng.Value = "< " & dTargetNum
Next Rng
ws.UsedRange.EntireColumn.AutoFit
End Sub
Related
I've been trying to write some macros to a cross-departmental spreadsheet, which when I press a command button will essentially "archive" a row of work. I also have one which is meant to auto-capitalise a column when people type in it. See below:
This is the Archive macro:
Sub Archive()
If MsgBox("Do you want to archive the selected row?" & vbNewLine & vbNewLine & "Row should only be archived after x has passed.", vbYesNo, "Archive") = vbNo Then Exit Sub
For Each WSheet In ActiveWorkbook.Worksheets
If WSheet.AutoFilterMode Then
If WSheet.FilterMode Then
WSheet.ShowAllData
End If
End If
For Each DTable In WSheet.ListObjects
If DTable.ShowAutoFilter Then
DTable.Range.AutoFilter
DTable.Range.AutoFilter
End If
Next DTable
Next WSheet
'Declare variables
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim lastRow As Long
'Set variables
Set sht1 = Sheets("xDepartment")
Set sht2 = Sheets("Archive")
'Select Entire Row
Selection.EntireRow.Select
'Move row to destination sheet & Delete source row
lastRow = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
With Selection
.Copy Destination:=sht2.Range("A" & lastRow + 1)
.EntireRow.Delete
End With
End Sub
The autocapitalisation macro is attached to the specific sheet? (i.e., it's attached when right-clicking on "xDepartment" and selecting "View code" - not sure if that has something to do with it?). There's also a macro on this sheet which calculates the date that data in a certain cell is changed:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A1 As Range
Set A1 = Range("O:O,Q:Q,T:T,W:W")
If Not Intersect(Target, A1) Is Nothing Then
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Application.EnableEvents = True
End If
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("O:O, Q:Q"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd/mm/yyyy"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub
The error that comes up is "Run-time error '13': Type mismatch". Do you know why this might be happening?
Thanks in advance!
After your First line in the Archive macro put
Application.EnableEvents = False
On error goto Whoops
Then just above your End Sub for that macro put
Whoops:
Application.EnableEvents = True
This will turn off the other macro while your archive is running
Your code to move the row from xDepartment worksheet to Archive worksheet includes the line,
Selection.EntireRow.Select
This makes the xDepartment worksheet active. The code to actually move the row and remove the original does nothing to change the xDepartment as the ActiveSheet.
With Selection
.Copy Destination:=sht2.Range("A" & lastRow + 1)
.EntireRow.Delete
End With
In your worksheet_change, you have,
Set WorkRng = Intersect(Application.ActiveSheet.Range("O:O, Q:Q"), Target)
So your Archive worksheet's Worksheet_Change is going to try to work on the xDepartment worksheet.
But you delete the row so it no longer exists; hen ce:
Run-time error '13': Type mismatch
Set your WorkRng with,
Set WorkRng = Intersect(Range("O:O, Q:Q"), Target)
It is in a private sub procedure on the Archive's private code sheet so there is no need to specify a parent worksheet unless you specifically want to work on another worksheet.
Avoid the use of ActiveSheet, Select, Selection and Activate whenever possible and never use them in a worksheet's private code sheet to refer to that worksheet.
The intent is to copy all unlocked cells in multiple sheets except "Sheet1" from Workbook1 (origin file) to Workbook2 (destination file) which contains worksheets with the same names as Workbook1.
Workbook1 is a checklist and Workbook2 is an updated version with additions of new worksheets or extra unlocked cells. The workbook and worksheet names are different from above but have renamed everything for simplicity.
I put some code together:
Sub ImportData()
Dim vFile As Variant, wbCopyTo As Workbook, wsCopyTo As Worksheet, _
wbCopyFrom As Workbook, wsCopyFrom As Worksheet, WorkRng As Range, _
OutRng As Range, Rng As Range
Application.ScreenUpdating = False
Set wbCopyTo = ActiveWorkbook 'sets Workbook2 to destination file
'this allows user to select old file Workbook1
' - the workbook name may be different in practice
' hence the ability to choose file
vFile = Application.GetOpenFilename("All Excel Files (*.xls*)," & _
"*.xls*", 1, "Select your old file", "Open", False)
If TypeName(vFile) = "Boolean" Then
Exit Sub 'check file selected is okay to use else exits sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
End If 'sets Workbook1 to origin file
For Each Worksheet In wbCopyFrom.Worksheets
'should loop each worksheet, I think the error is part of this For statement
If Worksheet.Name <> "Sheet1" Then
On Error Resume Next
Set wsCopyFrom = Worksheet 'sets Sheet2 to origin sheet
'sets sheet matching name on previous line in Workbook2
' to destination sheet
Set wsCopyTo = wbCopyTo.Worksheets(Worksheet.Name)
wbCopyFrom.Activate
wsCopyFrom.Select 'selects origin sheet
Set WorkRng = wsCopyFrom.UsedRange
For Each Rng In WorkRng
If Rng.Locked = False Then
If OutRng.Count = 0 Then
Set OutRng = Rng
Else
Set OutRng = Union(OutRng, Rng)
End If
End If
Next
'a loop I found to pick all unlocked cells,
' seems to work fine for first sheet
If OutRng.Count > 0 Then OutRng.Select
Dim rCell As Range
For Each rCell In Selection.Cells
rCell.Copy Destination:=wsCopyTo.Cells(rCell.Row, rCell.Column)
'a loop to copy all unlocked cells exactly as is
' in terms of cell reference on sheet,
' seems to work fine for first sheet
Next rCell
End If
'should go to Sheet3 next, seems to go to the sheet
' but then doesn't select any unlocked cells nor copy anything across
Next Worksheet
wbCopyFrom.Close SaveChanges:=False 'closes origin file Workbook1
Application.ScreenUpdating = True
End Sub
It will select and copy all unlocked cells from "Sheet2" in Workbook1 to "Sheet2" in Workbook2, however, it will not cycle through all of the sheets necessary ("Sheet3" onwards).
it's possible your use of On Error Resume Next is masking problems
use something other than Worksheet as your For Each loop variable name
you don't reset OutRng after each worksheet
Try something like this:
Sub ImportData()
Dim vFile As Variant, wbCopyTo As Workbook, wsCopyTo As Worksheet, _
wbCopyFrom As Workbook, OutRng As Range, c As Range, wsCopyFrom As Worksheet
Application.ScreenUpdating = False
Set wbCopyTo = ActiveWorkbook 'sets Workbook2 to destination file
vFile = Application.GetOpenFilename("All Excel Files (*.xls*)," & _
"*.xls*", 1, "Select your old file", "Open", False)
If TypeName(vFile) = "Boolean" Then Exit Sub
Set wbCopyFrom = Workbooks.Open(vFile)
For Each wsCopyFrom In wbCopyFrom.Worksheets
If wsCopyFrom.Name <> "Sheet1" Then
Set wsCopyTo = wbCopyTo.Worksheets(wsCopyFrom.Name)
Set OutRng = UsedRangeUnlocked(wsCopyFrom)
If Not OutRng Is Nothing Then
For Each c In OutRng
c.Copy wsCopyTo.Range(c.Address)
Next c
End If
End If
Next wsCopyFrom
wbCopyFrom.Close SaveChanges:=False 'closes origin file Workbook1
Application.ScreenUpdating = True
End Sub
'return a range containing all unlocked cells within the UsedRange of a worksheet
Function UsedRangeUnlocked(sht As Worksheet) As Range
Dim rngUL As Range, c As Range
For Each c In sht.UsedRange.Cells
If Not c.Locked Then
If rngUL Is Nothing Then
Set rngUL = c
Else
Set rngUL = Application.Union(rngUL, c)
End If
End If
Next c
Set UsedRangeUnlocked = rngUL
End Function
I found the code below on this site which works perfectly once I referenced the appropriate cells etc. However, I tried to modify it to keep formulas but I am not having much luck. Any help is greatly appreciated.
Sub test()
Dim names As New Collection
Dim ws As Worksheet, ws1 As Worksheet
Dim wb As Workbook
Dim lastrow As Long
Dim cell As Range
Dim nm As Variant
Dim res As Range
Dim rngHeader As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
'change "A" to column with "Names"
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'change "A" to column with "Names"
For Each cell In .Range("A2:A" & lastrow)
On Error Resume Next
'collect unique names
names.Add CStr(cell.Value), CStr(cell.Value)
On Error GoTo 0
Next cell
'disable all filters
.AutoFilterMode = False
'change "A1:C1" to headers address of your table
Set rngHeader = .Range("A1:C1")
For Each nm In names
With rngHeader
'Apply filter to "Name" column
.AutoFilter Field:=1, Criteria1:=nm
On Error Resume Next
'get all visible rows
Set res = .Offset(2).Resize(lastrow - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
'if there is visible rows, create new WB
If Not res Is Nothing Then
'create new workbook
Set wb = Workbooks.Add
'add sheet with name form column "Names" ("Paul", "Nick" or etc)
wb.Worksheets.Add.name = nm
'delete other sheets from new wb
For Each ws1 In wb.Worksheets
If ws1.name <> nm Then ws1.Delete
Next
'copy/paste data
With wb.Worksheets(nm)
'copy headers
.Range("A1").Resize(, rngHeader.Columns.Count).Value = rngHeader.Value
'copy data
.Range("A2").Resize(res.Rows.Count, res.Columns.Count).Value = res.Value
End With
'save wb
wb.Close saveChanges:=True, Filename:=ThisWorkbook.Path & "\Spreadsheet_" & nm & ".xlsx"
Set wb = Nothing
End If
End With
Next
'disable all filters
.AutoFilterMode = False
End With
Set names = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There is a part in your code which states that it copies / pastes data:
'copy/paste data
With wb.Worksheets(nm)
'copy headers
.Range("A1").Resize(, rngHeader.Columns.Count).Formula = rngHeader.Formula
'copy data
.Range("A2").Resize(res.Rows.Count, res.Columns.Count).Formula = res.Formula
End With
If you copy the .Formula instead of the .Value then it should work. Give it a try and let us know.
I have a template sheet that I have set up named "Template".
I have a range of cells on another worksheet called "Formulation" that I would like it to look through the range "G7:W7" and create a copy of the "Template" and rename it accordingly.
I have adapted a piece of code I have found but I keep encountering a run time error 13 - type mismatch.
Here is the code:
`Sub CopyInfoSheetandInsert()
'
' CopyInfoSheetandInsert Macro
'
Dim rcell As Range
Dim Background As Worksheet
Set Background = Sheets("Formulation")
For Each rcell In Range("D7:W7")
If rcell.Value <> "" Then
Sheets("Template").Copy Before:=Sheets("COSHH")
Sheets("Template (2)").Name = rcell.Value
End If
Next rcell
End Sub
Any advice would be greatly appreciated!
UPDATE
By moving the macro button to the formulation page the copy function now works however, on the following line of code I now get a subscript out of range error?
Sheets("Template(2)").Name = rcell.Value
Kind Regards,
Aidan
You need something like:
Sub CopyInfoSheetandInsert()
Dim rcell As Range
Dim Background As Worksheet
Set Background = Sheets("Formulation")
For Each rcell In Range("D7:W7")
If rcell.Value <> "" And SheetExists(rcell.Value) = False Then
Sheets("Template").Copy Before:=Sheets("COSHH")
Sheets(Sheets("COSHH").Index - 1).Name = rcell.Value
End If
Next rcell
End Sub
Function SheetExists(SheetName) As Boolean
Dim sht As Worksheet
'Assume Failure
SheetExists = False
For Each sht In ActiveWorkbook.Sheets
If sht.Name = SheetName Then
'Success
SheetExists = True
Exit Function
End If
Next sht
End Function
HI I have created a VBA that takes info from a ALL data sheet and plots it in worksheets.
The worksheets get automatically generated which is great but the issue is that VBA is only supposed to create Unique worksheets - however this is not the case.
Example: if in my ALL data sheet I have IKEA 3 times then the first time the vba encounters IKEA then it should create a worksheet while it should ignore any repeats.
Actual
IKEA; Sheet 2 ; Sheet 3
Wanted
IKEA
VBA Code
Sub CreateSheetsFromAList()
Dim iReply As Integer
Dim MyCell As Range, MyRange As Range
On Error Resume Next
Range("B1").End(xlUp).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=rListPaste.Cells(1, 1), Unique:=True
Set MyRange = Sheets("ALL").Range("B1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
End Sub
Try this code (it creates new sheet only if there is no sheets with name MyCell.Value):
Sub CreateSheetsFromAList()
Dim iReply As Integer
Dim MyCell As Range, MyRange As Range
Dim sh as Worksheet
On Error Resume Next
Range("B1").End(xlUp).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=rListPaste.Cells(1, 1), Unique:=True
Set MyRange = Sheets("ALL").Range("B1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Set sh = Nothing
Set sh=Sheets(MyCell.Value)
If sh is Nothing Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
End If
Next MyCell
End Sub