I made a Sub. But its giving an error.!
I want to check if column A has values then it checks for columns" H and I ". those must be filled.
Else the file wont save..!!
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim cell As Range
Dim LastRow As Long
Dim oneRange As Range
Dim aCell As Range
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
If cell.Value(Range("A8:A" & LastRow)) Is Nothing Then
Exit Sub
Else
For Each cell In Range("H8:I" & LastRow)
If IsEmpty(cell.Value) Then
MsgBox "Please Select Value from Dropdown Menu...." & cell.Address
Application.Goto cell
Cancel = True
Exit For
End If
Next cell
End If
End Sub
TRIED AND TESTED
Is this what you are trying?
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Dim lRow As Long
Dim aCell As Range
Set ws = ThisWorkbook.Sheets("receivings")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
If Application.WorksheetFunction.CountA(.Range("A8:A" & lRow)) = 0 _
Then Exit Sub
For Each aCell In Range("H8:I" & lRow)
If IsEmpty(aCell.Value) Then
MsgBox "Please Select Value from Dropdown Menu...." _
& aCell.Address
Application.Goto aCell
Cancel = True
Exit For
End If
Next aCell
End With
End Sub
sheet1 and sheets(1) is often not the same. Best is using the name of the sheet.
You might miss a "." at the second for (...in .range...) ?
PS, i'm new in VBA, what does application.goto aCell, do ? because it strage to put a "exit for" after a "goto"...
Related
This VBA takes a lot of time to execute
Sub test()
Dim IB As String
Dim copyRng As Range, cel As Range, pasteRng As Range
With Selection
Set copyRng = Selection
End With
IB = Application.InputBox("Enter Exact Sheet Name to Paste")
Set pasteRng = Sheets(IB).Range("A1")
For Each cel In copyRng
cel.Copy
pasteRng.Range(cel.Address).PasteSpecial xlPasteAll
Next
Application.CutCopyMode = False
End Sub
Copy Non-Contiguous Ranges
I've turned off screen updating and replaced looping through cells with looping through areas of the range.
When you would only need values to be copied, another (vast) improvement in performance would be to copy by assignment. Then in the loop, you would use the following code:
darg.Value = sarg.Value
instead of sarg.Copy darg.
Option Explicit
Sub CopyNonContiguous()
Const ProcTitle As String = "Copy Non-Contiguous"
Dim srg As Range
If TypeName(Selection) = "Range" Then
Set srg = Selection
Else
MsgBox "Select a range. please.", vbCritical, ProcTitle
Exit Sub
End If
Dim wsName As Variant
wsName = Application.InputBox( _
"Enter Sheet Name to Paste", ProcTitle, , , , , , 2)
If wsName = False Then
MsgBox "You canceled.", vbExclamation, ProcTitle
Exit Sub
End If
Dim dws As Worksheet
On Error Resume Next
Set dws = ActiveWorkbook.Worksheets(wsName) ' consider 'ThisWorkbook'
On Error GoTo 0
If dws Is Nothing Then
MsgBox "The worksheet '" & wsName & "' doesn't exist.", _
vbCritical, ProcTitle
Exit Sub
End If
Application.ScreenUpdating = False
Dim sarg As Range
Dim darg As Range
For Each sarg In srg.Areas
Set darg = dws.Range(sarg.Address)
sarg.Copy darg
Next sarg
Application.ScreenUpdating = True
MsgBox "Cells copied.", vbInformation, ProcTitle
End Sub
I have a macro in my Excel Workbook that I run reports on.
I want to add in the pastespecial Function below but don't know where to place it in the script further down. It keeps giving me errors. I've tried almost every line.
I also want to add an extract phrase function added in as well. There is some text I want removed from one column at the beginning of every cell eg: alpha/beta/kappa
Help please. Thank you.
++++++++++++++++++++++++++++++++
Copy and Value Paste to Different Sheet
This example will Copy & Paste Values for single cells on different worksheets
1
2
Sheets("Sheet1").Range("A1").Copy
Sheets("Sheet2").Range("B1").PasteSpecial Paste:=xlPasteValues
++++++++++++++++++++++++++++++++++++++
My code below where I want to insert the above pastespecial function:
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Option Explicit
Function GetHeadersDict() As Scripting.Dictionary
' We must activate the Microsoft Scripting Runtime from Tools --References
Dim result As Scripting.Dictionary
Set result = New Scripting.Dictionary
With result
.Add "Track #", False
.Add "Date", False
.Add "Status", False
.Add "Shoes", False
.Add "Description", False
End With
Set GetHeadersDict = result
End Function
Function FindHeaderRange(ByVal ws As Worksheet, ByVal header As String) As Range
Set FindHeaderRange = ws.Cells.Find(header, , , xlWhole)
End Function
Sub clearDataNotFormulasSheet2()
Sheets("Results").Range("A2:k96").ClearContents
End Sub
Sub copyColumnData()
On Error GoTo ErrorMessage
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Report")
Set ws2 = ThisWorkbook.Sheets("Results")
clearDataSheet2
Dim numRowsToCopy As Long
numRowsToCopy = ws1.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row - 1
'MsgBox "The no of rows to copy is " & numRowsToCopy
Dim destRowOffset As Long
destRowOffset = ws2.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row
'MsgBox "The next Blank row is " & destRowOffset
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim dictKey As Variant
Dim header As String
Dim numColumnsToCopy As Long
Dim Report As Range
Dim dest As Range
Dim headersDict As Scripting.Dictionary
Set headersDict = GetHeadersDict()
For Each dictKey In headersDict
header = dictKey
If headersDict.Item(header) = False Then
Set Report = FindHeaderRange(ws1, header)
If Not (Report Is Nothing) Then
Set dest = FindHeaderRange(ws2, header)
If Not (dest Is Nothing) Then
headersDict.Item(header) = True
' Look at successive headers to see if they match
' If so, copy these columns altogether to make the macro faster
For numColumnsToCopy = 1 To headersDict.Count
'MsgBox numColumnsToCopy
If Report.Offset(ColumnOffset:=numColumnsToCopy).Value = dest.Offset(ColumnOffset:=numColumnsToCopy).Value Then
headersDict.Item(Report.Offset(ColumnOffset:=numColumnsToCopy).Value) = True
Else
Exit For
End If
Next numColumnsToCopy
Report.Offset(RowOffset:=1).Resize(RowSize:=numRowsToCopy, ColumnSize:=numColumnsToCopy).Copy _
dest.Offset(RowOffset:=destRowOffset)
End If
End If
End If
Next dictKey
Dim msg As String
For Each dictKey In headersDict
header = dictKey
If headersDict.Item(header) = False Then
msg = msg & vbNewLine & header
End If
Next dictKey
ExitSub:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
If msg <> "" Then
MsgBox "The following headers were not copied:" & vbNewLine & msg
End If
Exit Sub
ErrorMessage:
MsgBox "An error has occurred: " & Err.Description
Resume ExitSub
End Sub
Private Sub CommandButton1_Click()
End Sub
I had the same issue of yours just replace Report.Offset(RowOffset:=1).Resize(RowSize:=numRowsToCopy, ColumnSize:=numColumnsToCopy).Copy _ dest.Offset(RowOffset:=destRowOffset)
with
Report.Offset(RowOffset:=1).Resize(RowSize:=numRowsToCopy,ColumnSize:=numColumnsToCopy).Copy
dest.Offset(RowOffset:=destRowOffset).PasteSpecial Paste:=xlPasteValues
I want to prevent copy pasting data in excel if the data is not unique. Im using the following macro.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim AffectedCells As Range
Dim Cell As Range
Set AffectedCells = Intersect(Target, Target.Parent.Range("A:A"))
If Not AffectedCells Is Nothing Then
For Each Cell In AffectedCells
If CountIf(Range("A:A"),A1) >2 Then
MsgBox "The data """ & Cell.Value & """ inserted in " & Cell.Address & " in column A is duplicste. We undo!", vbCritical Application.Undo 'undo insert
Exit Sub
End If
Next Cell
End If
End Sub
It is still allowing the data to be pasted.
I tried letting excel not save itself if the value is duplicate but it is still saving.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim rngCell As Range
Dim lngLstRow As Long lngLstRow = Sheet1.UsedRange.Rows.Count
For Each rngCell In Sheet1.Range("A1:A" & lngLstRow)
If CountIf(Range("A:A"),A1) > 2 Then
MsgBox "Please enter unique value " & rngCell.Address
rngCell.Select
End If
Next
End Sub
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.
I'm having an issue with my code to autofill some using VBA in Excel. I keep getting the error "AutoFill method of range class failed" but I'm not sure what is wrong with the code. it looks okay to me but maybe I'm missing something? The code is as follows:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)
A = MsgBox("Do you really want to save the workbook?", vbYesNo)
If A = vbNo Then Cancel = True
Dim lrow As Long
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("A1").Select
Selection.AutoFill Destination:=Range("A1:A" & lastrow)
Range("A1:A" & lastrow).Select
'Range("D1").Select
'Selection.AutoFill Destination:=Range("D1:D" & lastrow)
'Range("D1:D" & lastrow).Select
'Range("H1").Select
'Selection.AutoFill Destination:=Range("H1:H" & lastrow)
'Range("H1:H" & lastrow).Select
'Range("L1").Select
'Selection.AutoFill Destination:=Range("L1:L" & lastrow)
'Range("L1:L" & lastrow).Select
End Sub
Any help in the right direction would be greatly appreciated. (Note I am just trying to fix Column A I figure if I can get that working the rest will fall into line).
Thanks!!!
-D
Is this what you are trying?
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Ret As Variant
Ret = MsgBox("Do you really want to save the workbook?", vbYesNo)
If Ret = vbNo Then
Cancel = True
Else
'~~> Make these changes only if user wants to save the workbook
Dim lrow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(1)
With ws
'~~> If Col B has data then find the last row in Col B
lrow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & lrow).Formula = .Range("A1").Formula
End With
End If
End Sub