input box cancel excel vba - excel

This code copies a block of excel data (Col A to Col BH), and prompts the user to select the row where the copied template needs to be pasted. The code seems to work just fine( feel free to clean up/optimize any code), my issue is whenever a user clicks cancel when they need to pick the row I get an error "run time error 13 type mismatch". Is there anyway to just end the macro if cancel is selected?
Sub CopyTemplate()
Worksheets("HR-Calc").Activate
Dim rng As Variant
Dim trng As Range
Dim tco As String
Dim hi As String
Dim de As String
'Use the InputBox select row to insert copied cells
Set rng = Application.InputBox("select row to paste into", "Insert template location", Default:=ActiveCell.Address, Type:=8)
startrow = rng.Row
' MsgBox "row =" & startrow
Range("Bm2") = startrow
Application.ScreenUpdating = False
'copy template block
Range("C6").End(xlDown).Select
Range("bm1") = ActiveCell.Offset(1, 0).Row
Worksheets("HR-CAlc").Activate
tco = "A6:bh" & Range("bm1")
Range(tco).Select
Selection.Copy
Range("A" & Range("bm2")).Activate
Selection.Insert Shift:=xlDown
Range("c100000").End(xlUp).Select
Selection.End(xlUp).Select
'mycell.Select
''Use the InputBox to select text to be replaced
''Set rep = Application.InputBox("select data range where text will be replaced", Default:=ActiveCell.Address, Type:=8)
'Set rep = ActiveCell
' Told = Application.InputBox("Find the text that needs to be replaced", "Find text in Input data", Default:=ActiveCell.Value, Type:=2)
' If Told = "" Or vbCancel Then
' End If
'
' Tnew = Application.InputBox("Input desired text", "Replace text in data", Default:=ActiveCell.Value, Type:=2)
' If Tnew = "" Or vbCancel Then
' End If
'
' rep.Select
' Selection.Replace What:=Told, Replacement:=Tnew, LookAt:=xlPart, _
' SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
' ReplaceFormat:=False
Range("bm1:bm2").ClearContents
SendKeys "{F2}"
SendKeys "{BS}"
Application.ScreenUpdating = True
End Sub

You still need error handling to detect the Cancel
Dim rng As Range '<~~~ change type so If test will work
'Use the InputBox select row to insert copied cells
Set rng = Nothing ' in case it was previously set
On Error Resume Next
Set rng = Application.InputBox("select row to paste into", "Insert template location", Default:=ActiveCell.Address, Type:=8)
On Error GoTo 0 ' or your error handler
If rng Is Nothing Then
' User canceled, what now?
Exit Sub 'maybe...
End If

Add these lines including error handler:
On Error Resume Next
Set rng = Application.InputBox("select row to paste into", "Insert template location", Default:=ActiveCell.Address, Type:=8)
On Error GoTo 0
If IsEmpty(rng) = True Then
Exit Sub
End If
These lines will exit the sub if it won't find any value for rng.

Related

How to Find, cut, paste and erase with VBA code

I am new on VBA and i dont know almost nothing.
I've been trying a code to find a value entered in a inputbox "CXRG", find on sheet "ESTOQUEV" cut all the line and paste on sheet "SAIDA" (down from another values) and erase the blank line from "ESTOQUEV"
Someone could help me?
Private Sub CommandButton1_Enter()
linha = Worksheets("SAIDA").Range("A100000").End(xlUp).Row + 1
Worksheets("SAIDA").Cells(linha, 1) = CXOS.Value
Worksheets("SAIDA").Cells(linha, 2) = CXRG.Value
CXOS.Text = ""
CXRG.Text = ""
SendKeys "{TAB}", True ' Envia TAB para pular par o inicio.
Call refresh.Macro8
End Sub
you have to try this code (run just findAndPast())
Sub findAndPast()
Dim shttoFind As Worksheet
Dim shttoPast As Worksheet
Dim LastRowOffind As Long
Dim inBox As String
Dim cell As Range
Set shttoFind = Worksheets("ESTOQUEV")
Set shttoPast = Worksheets("SAIDA")
Call Find_Last
LastRowOffind = shttoPast.Cells(shttoPast.Rows.Count, "A").End(xlUp).Row + 1
ActiveCell.EntireRow.Copy
shttoPast.Activate
shttoPast.Cells(LastRowOffind, 1).PasteSpecial
shttoFind.Activate
ActiveCell.EntireRow.Delete
End Sub
Sub Find_Last()
Dim FindString As String
Dim Rng As Range
FindString = InputBox("Enter a Search value")
If Trim(FindString) <> "" Then
With Sheets("ESTOQUEV").Range("A:C")
Set Rng = .Find(What:=FindString, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub

creating a complex macro using vba

I have a complex workbook that i need filtered using vba.
I need to delete rows that have blank cells from column G.
I then need columns C through G hidden.
Then I need Column H filtered to delete all rows greater than 2.
Finally I need Column I sorted from Largest to smallest.
This is what i have so far but It half way works and i don't want to use a command button. I want to be able to paste a document in here and the code automatically works it.
Private Sub CommandButton1_Click()
'Created by William Hinebrick 277096
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Please select range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If (xRg.Areas.Count > 1) Or (xRg.Columns.Count > 1) Then
MsgBox "You can only select one column per time", vbInformation, "Kutools for Excel"
Exit Sub
End If
xRg.Range("A1").EntireRow.Insert
Set xRg = xRg.Range("A1").Offset(-1).Resize(xRg.Rows.Count + 1)
xRg.Range("A1") = "Temp"
xRg.AutoFilter 1, ">2"
Set xRg = Application.Intersect(xRg, xRg.SpecialCells(xlCellTypeVisible))
On Error GoTo 0
If Not xRg Is Nothing Then xRg.EntireRow.Delete
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Created by William Hinebrick 277096
Dim xRg As Range
Application.ScreenUpdating = False
For Each xRg In Range("G1:G10000")
If xRg.Value = "" Then
xRg.EntireRow.Hidden = True
Else
xRg.EntireRow.Hidden = False
End If
Next xRg
Application.ScreenUpdating = True
End Sub
Sub Column_Hide()
'Created by William Hinebrick 277096
Columns("C:G").EntireColumn.Hidden = True
Columns("J").EntireColumn.Hidden = True
End Sub
Private Sub Sort_Drop(ByVal Target As Range)
On Error Resume Next
Range("I1").Sort Key1:=Range("I2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub
I would like to be able to use this daily as I will be pasting New spreadsheets to this worksheet to be filtered so I may concise the results
This should do everything listed.
If you require it to perform everytime you copy data in, then the Worksheet_Changeevent from your 2nd sub is the way to go. But this means it also runs every other time you change something in your workbook. I'd personally simply assign a Keyboard shortcut to it. Seems the easiest way to go.
Option Explicit
Sub test()
Dim i As Double
Dim lastrow As Double
lastrow = ActiveSheet.UsedRange.Rows.Count
For i = lastrow To 2 Step (-1) 'delete empty G cells
If ActiveSheet.Cells(i, 7).Value = "" Then Cells(i, 7).EntireRow.Delete
Next
lastrow = ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row
For i = lastrow To 2 Step (-1) 'delete H >2
If ActiveSheet.Cells(i, 8).Value > 2 Then Cells(i, 8).EntireRow.Delete
Next
Columns("C:G").EntireColumn.Hidden = True 'hide columns
Range("I1").Sort Key1:=Range("I2"), _
Order1:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom 'Sort by I descending order
End Sub

Copy an entire row from sheet 2 which contains any value from column A on sheet 1, into sheet 3

I would like to be able to copy any row from sheet 2 which contains any value from column a in sheet 1. Copied and pasted into sheet 3.
I found this code online but cell value is specific. I have about 80 values so individually listing them would take to long.
Sub Test()
For Each Cell In Sheets(1).Range("J:J")
If **Cell.Value = "131125"** Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next
End Sub
How about this:
Option Explicit
Sub CopyThings()
Dim rng As Range
Dim rng1 As Range
Dim ans As Integer
On Error GoTo ISAIDRANGE
Set rng = Application.InputBox("what do you want to copy?", "Select Range", Type:=8)
ans = MsgBox("the whole row?", vbYesNo)
Set rng1 = Application.InputBox("where do you want to paste", "Select Range", Type:=8)
Application.ScreenUpdating = False
rng1.Parent.Activate
Select Case ans
Case Is = vbYes
rng.Rows.EntireRow.Copy rng1.Rows.EntireRow
Case Is = vbNo
rng.Copy rng1
End Select
ISAIDRANGE:
Application.ScreenUpdating = True
If Err.Number = 424 Then ans = MsgBox("that's not a valid range", vbExclamation, "I meant a VALID range")
End Sub

Run Macro if mandatory SHeet name exist

I have a macro and its dependent on Specific sheet name 'PRODUCTS45' problem is if a user run the macro on different sheet e.g. Sheet1 it throws debug error.
can anyone help me to make macro run only when sheet 'PRODUCTS45' is present and if not throws msgbox that mandatory sheet is not present.
Option Explicit
Sub FlagWord()
Dim R As Range, WS As Worksheet
Dim RE As Object
Dim C As Range, D As Range
Dim S As String
Dim I As Long, J As Long
S = InputBox("Enter desired word")
'Current filled in range
Set WS = Worksheets("SHEET")
'case sensitive sheet name and its required to run macro if this is not present macro should not run
With WS
Set R = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set R = R.Resize(columnsize:=.Cells(1, .Columns.Count).End(xlToLeft).Column)
End With
If Not S = "" Then
'If S not present then add column
With WS.Rows(1)
Set C = .Find(what:=S, after:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext, MatchCase:=False)
End With
'Add column if not already present
If C Is Nothing Then
Set R = R.Resize(columnsize:=R.Columns.Count + 1)
R(1, R.Columns.Count) = S
End If
End If 'no new column if S is blank
'do the word match
'Clear the data area
With R
.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).ClearContents
End With
'fill in the data
'use regex to allow for easy word boundaries
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False 'only need a single match
.ignorecase = True
For Each C In R.Columns(1).Offset(1, 0).Resize(R.Rows.Count - 1).Cells
For Each D In R.Rows(1).Offset(0, 1).Resize(columnsize:=R.Columns.Count - 1).Cells
.Pattern = "\b" & D.Text & "\b"
If .test(C.Text) = True Then
R(C.Row, D.Column) = "YES"
End If
Next D
Next C
End With
End Sub
How about something like this:
Public Sub CheckForSheetBeforeCallingFlagWord()
Dim ws As Worksheet
Dim bolFound As Boolean
bolFound = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "PRODUCTS45" Then bolFound = True
Next ws
If bolFound = False Then
MsgBox "Required sheet 'PRODUCTS45' not found." & Chr(10) & "Aborting..."
Exit Sub
End If
Call flagword
End Sub
This procedure checks for the existence of the required sheet. If it is not found then you get a message box and nothing else happens. If the sheet is found then the other procedure gets called (and executed).
Trying to reference a worksheet that doesn't exist will throw an error. You can use an error handler to trap this and give the desired message.
Sub myMacro()
On Error GoTo sheetNotFound
doStuff ThisWorkbook.Sheets("PRODUCTS45")
Exit Sub
sheetNotFound:
MsgBox "PRODUCTS45 not found"
End Sub
Sub doStuff(ws As Worksheet)
' remaining code goes here
End Sub

vba#excel_highlight the empty cells

I'm creating an excel file with column A to H are mandatory cells.
This excel file will be passing around for input.
So, I would like to highlight the empty cells as a reminder.
I have written the following code...
Sub Highlight_Cell()
Dim Rng As Range
For Each Rng In Range("A2:H20")
If Rng.Value = "" Then
Rng.Interior.ColorIndex = 6 ‘yellow
Else
Rng.Interior.ColorIndex = 0 'blank
End If
Next Rng
MsgBox "Please fill in all mandatory fields highlighted in yellow."
End Sub
However, I would like to set the range from A2 to the last row that contains data within column A to H.
Also, display the message box only when empty cell exist.
Could you please advise how should I amend?
Million Thanks!!!
This is a VBA solution that prevents the user from saving until the desired range is filled (acknowledging Gserg's comment that that the last row is one that has at least one cell entered)
In the second portion you can either add your sheet index directly, Set ws = Sheets(x) for position x, or Set ws = Sheets("YourSheet") for a specific sheet name
The code will only highlight truly blank cells within A to H of this sheet till the last entered cell (using SpecialCells as a shortcut). Any such cells will be selected by the code on exit
Put this code in the ThisWorkbook module (so it fires whenever the user tries to close the file)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
bCheck = False
Call CheckCode
If bCheck Then Cancel = True
End Sub
Put this code in a standard module
Public bCheck As Boolean
Sub CheckCode()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
bCheck = False
'works on sheet 1, change as needed
Set ws = Sheets(1)
Set rng1 = ws.Columns("A:H").Find("*", ws.[a1], xlValues, xlWhole, xlByRows)
If rng1 Is Nothing Then
MsgBox "No Cells in columns A:H on " & ws.Name & " file will now close", vbCritical
Exit Sub
End If
Set rng2 = ws.Range(ws.[a1], ws.Cells(rng1.Row, "H"))
On Error Resume Next
Set rng2 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If rng2 Is Nothing Then Exit Sub
bCheck = True
rng2.Interior.Color = vbYellow
MsgBox "Please fill in all mandatory fields on " & ws.Name & " highlighted in yellow", vbCritical, "Save Cancelled!"
Application.Goto rng2.Cells(1)
End Sub

Resources