I cant seem to figure out this. I would like to search my worksheets to see if there is a "=REF!" and if there is a error to not run my code. The problem with it is that when I run it the error in the code is revolved around the next part
Sub logs()
Dim numberofsheets As Integer
For numberofsheets = 1 To 5
Set checkRange = Sheets("Final Four").Range("A1:Z100")
If IsError(CheckCell) And _
CVErr(CheckCell) = CVErr(2023) Then
Exit Sub
End If
Next
Set checkRange = Sheets("Top Left").Range("A1:Z100")
If IsError(CheckCell) And _
CVErr(CheckCell) = CVErr(2023) Then
Exit Sub
End If
Next
Set checkRange = Sheets("Bottom Left").Range("A1:Z100")
If IsError(CheckCell) And _
CVErr(CheckCell) = CVErr(2023) Then
Exit Sub
End If
Next
Set checkRange = Sheets("Top Right").Range("A1:Z100")
If IsError(CheckCell) And _
CVErr(CheckCell) = CVErr(2023) Then
Exit Sub
End If
Next
Set checkRange = Sheets("Bottom Right").Range("A1:Z100")
If IsError(CheckCell) And _
CVErr(CheckCell) = CVErr(2023) Then
Exit Sub
End If
ActiveSheet.EnableCalculation = True
lst = Sheets("data").UsedRange.Rows.Count
x = lst + 1
' Display a message when one of the designated cells has been
' changed.
' Place your code here.
Sheets("data").Range("A" & x) = ActiveSheet.Range("I3")
Sheets("data").Range("B" & x) = ActiveSheet.Range("I4")
End Sub
Not sure how to do this. I'm very new at it.
I think you are looking for something like the For loop below to implement in your code:
Sub logs()
Dim Sht As Worksheet
Dim checkRange As Range, CheckCell As Range
For Each Sht In ThisWorkbook.Sheets ' loop through your worksheets
With Sht
Select Case .Name ' check for the sheet.Name
Case "Final Four", "Top Left", "Bottom Left", "Top Right", "Bottom Right"
Set checkRange = .Range("A1:Z100") ' set the range for the current sheet
For Each CheckCell In checkRange
If IsError(CheckCell) Then
If CheckCell.Value = CVErr(2023) Then Exit Sub
' you can use the following syntax as well
If CheckCell.Value = CVErr(xlErrRef) Then Exit Sub
End If
Next CheckCell
Set checkRange = Nothing
Case Else
' do nothing
End Select
End With
Next Sht
' rest of your code
End Sub
Related
I have used a macro to track changes in a workbook, but I would now like to run this macro in over a 100 excel files within a particular folder using a Do While Loop.
I am very new to VBA and will appreciate all the help I can get.
I have come across some code that should enable me to loop through excel files in a folder and run the macro in each one.
However it requires me to get rid of the 'sub' and 'end sub' from the macro when I copy and paste it into the do while loop, but I have 3 of them within the macro; some variables will be undefined if I delete all 3.
Therefore I tried 'Call Tracker' within the loop ('Tracker' being the macro name) and hoped it would run in each excel file.
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*,xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
'Your code here
Call Tracker
End With
xFileName = Dir
Loop
End If
End Sub
Below is the code inside 'Tracker'
Option Explicit
Dim sOldAddress As String
Dim vOldValue As Variant
Public Sub Workbook_TrackChange(Cancel As Boolean)
Dim Sh As Worksheet
For Each Sh In ActiveWorkbook.Worksheets
Sh.PageSetup.LeftFooter = "&06" & ActiveWorkbook.FullName & vbLf & "&A"
Next Sh
End Sub
Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wSheet As Worksheet
Dim wActSheet As Worksheet
Dim iCol As Integer
Set wActSheet = ActiveSheet
'Precursor Exits
'Other conditions that you do not want to track could be added here
If vOldValue = "" Then Exit Sub 'If you comment out this line *every* entry will be recorded
'Continue
On Error Resume Next ' This Error-Resume-Next is only to allow the creation of the tracker sheet.
Set wSheet = Sheets("Tracker")
'**** Add the tracker Sheet if it does not exist ****
If wSheet Is Nothing Then
Set wActSheet = ActiveSheet
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Tracker"
End If
On Error GoTo 0
'**** End of specific error resume next
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Sheets("Tracker")
'******** This bit of code moves the tracker over a column when the first columns are full**'
If .Cells(1, 1) = "" Then '
iCol = 1 '
Else '
iCol = .Cells(1, 256).End(xlToLeft).Column - 7 '
If Not .Cells(65536, iCol) = "" Then '
iCol = .Cells(1, 256).End(xlToLeft).Column + 1 '
End If '
End If '
'********* END *****************************************************************************'
.Unprotect Password:="Secret"
'******** Sets the Column Headers **********************************************************
If LenB(.Cells(1, iCol).Value) = 0 Then
.Range(.Cells(1, iCol), .Cells(1, iCol + 7)) = Array("Cell Changed", "SAP ID", "Field Name", "Old Field Value", _
"New Field Value", "Time of Change", "Date Stamp", "User")
.Cells.Columns.AutoFit
End If
With .Cells(.Rows.Count, iCol).End(xlUp).Offset(1)
If Target.Count = 1 Then
.Offset(0, 1) = Cells(Target.Row, 2) 'SAPID
End If
'.Offset(0, 1) = Cells(Target.Row, 2) 'SAPID
If Target.Count = 1 Then
.Offset(0, 2) = Cells(Target.Column) 'Field name
End If
'.Offset(0, 2) = Cells(Target.Column) 'Field name
.Value = sOldAddress
.Offset(0, 3).Value = vOldValue
If Target.Count = 1 Then
.Offset(0, 4).Value = Target.Value
End If
.Offset(0, 5) = Time
.Offset(0, 6) = Date
.Offset(0, 7) = Application.UserName
.Offset(0, 7).Borders(xlEdgeRight).LineStyle = xlContinuous
End With
.Protect Password:="Secret" 'comment to protect the "tracker tab"
End With
ErrorExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
wActSheet.Activate
Exit Sub
ErrorHandler:
'any error handling you want
'Debug.Print "We have an error"
Resume ErrorExit
End Sub
Public Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
With Target
sOldAddress = .Address(external:=True)
If .Count > 1 Then
vOldValue = "Multiple Cell Select"
Else
vOldValue = .Value
End If
End With
End Sub
'Call Tracker' in the loop does not produce an error. In fact the code seems to execute and loops through all the files but it does not run the macro in each one it opens.
I am trying to embed applying a chart template into a macro and require help.
I have this code for the Macro that I am using to create scatter plots:
Option Explicit
Public Sub Test()
' Keyboard Shortcut: Ctrl+Shift+X
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1") 'change as appropriate
Application.ScreenUpdating = False
BuildChart ws, SelectRanges(ws)
Application.ScreenUpdating = True
End Sub
Private Function SelectRanges(ByRef ws As Worksheet) As Range
Dim rngX As Range
Dim rngY As Range
ws.Activate
Application.DisplayAlerts = False
On Error Resume Next
Set rngX = Application.InputBox("Please select X values. One column.",
Type:=8)
If rngX Is Nothing Then GoTo InvalidSelection
Set rngY = Application.InputBox("Please select Y values. One column.",
Type:=8)
If rngY Is Nothing Then GoTo InvalidSelection
If rngX.Columns.Count > 1 Or rngY.Columns.Count > 1 Then GoTo
InvalidSelection
On Error GoTo 0
Set SelectRanges = Union(rngX, rngY)
Application.DisplayAlerts = True
Exit Function
InvalidSelection:
If rngX Is Nothing Or rngY Is Nothing Then
MsgBox "Please ensure you have selected both X and Y ranges."
ElseIf rngX.Rows.Count <> rngX.Rows.Count Then
MsgBox "Please ensure the same number of rows are selected for X and Y
ranges"
ElseIf rngX.Columns.Count > 1 Or rngY.Columns.Count > 1 Then
MsgBox "Please ensure X range has only one column and Y range has only
one column"
Else
MsgBox "Unspecified"
End If
Application.DisplayAlerts = True
End
End Function
Private Sub BuildChart(ByRef ws As Worksheet, ByRef unionRng As Range)
With ws.Shapes.AddChart2(240, xlXYScatter).Chart
.SetSourceData Source:=unionRng
End With
ActiveChart.ApplyChartTemplate ( _
"C:\Users\maaro\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
End Sub
And would like to embed this code below into the above code so that it applies the template to the chart I create whenever I run this Macro. My initial guess would be to put it underneath "Private Sub BuildCharts". How would I be able to do this? Thank you.
ActiveChart.ApplyChartTemplate ( _
"C:\Users\XXXXX\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
Perhaps modify Sub BuildChart like this:
Private Sub BuildChart(ByRef ws As Worksheet, ByRef unionRng As Range)
With ws.Shapes.AddChart2(240, xlXYScatter).Chart
.SetSourceData Source:=unionRng
.ApplyChartTemplate ( _
"C:\Users\maaro\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
End With
End Sub
I am trying to write a macro that will ask user to provide workbook, macro opens workbook. Than user selects the range for copy and specifies the worksheet to which paste data in Userform. Macro copy selected Range to the specified worksheet.
But I face some problems with it.
Here is code:
Public Sub copy_WB()
Application.DisplayAlerts = False
Dim wbk As Workbook, answer As String,lrow as long, lcol as long
Dim UserRange As Range
Prompt = "Select a cell for the output."
Title = "Select a cell"
answer = MsgBox("Would you like to clear all data?", vbYesNo, "Confirmation")
If answer = vbYes Then
Call clear_all
End If
Set wbk = Get_workbook
If wbk Is Nothing Then
Exit Sub
End If
' Display the Input Box
On Error Resume Next
Set UserRange = Application.InputBox( _
Prompt:=Prompt, _
Title:=Title, _
Type:=8) 'Range selection
' Was the Input Box canceled?
If UserRange Is Nothing Then
MsgBox "Canceled."
Exit Sub
Else
UserRange.Parent.Parent.Activate
UserRange.Parent.Activate
lrow = UserRange(UserRange.Count).Row
lcol = UserRange(UserRange.Count).Columns
If lrow > 1000000 Or lcol > 15000 Then
ActiveSheet.UsedRange.Copy
Else
UserRange.Copy
End If
sh_sel.Show
Do While IsUserFormLoaded("sh_sel")
DoEvents
Loop
ActiveSheet.Range("A2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
ThisWorkbook.Worksheets(3).Range("A1") = lrow
ThisWorkbook.Worksheets(3).Range("A2") = lcol
wbk.Close False
Application.DisplayAlerts = True
End Sub
Private Sub clear_all()
Dim wb As Workbook, shs As Worksheet, lrow As Single, lcol As Single
Set wb = ThisWorkbook
For Each shs In wb.Worksheets
With shs.UsedRange
lrow = .Rows(.Rows.Count).Row
lcol = .Columns(.Columns.Count).Column
End With
If Not (lrow = 0 Or lrow = 1) Then
With shs
.Range(.Cells(2, 1), .Cells(lrow, lcol)).clear
End With
End If
Next shs
End Sub
Function Get_workbook() As Workbook
Dim wbk As Workbook, pathb As String
pathb = ThisWorkbook.path
ChDir pathb
wbk_name = Application.GetOpenFilename(Title:="Please choose File:", FileFilter:="Excel Files *.xls*(*.xls*),")
On Error Resume Next
If Len(Dir(wbk_name)) = 0 Then
MsgBox "The file was not chosen - macro off."
Exit Function
Else
Set wbk = Workbooks.Open(wbk_name)
End If
Set Get_workbook = wbk
End Function
Function IsUserFormLoaded(ByVal UFName As String) As Boolean
Dim UForm As Object
IsUserFormLoaded = False
For Each UForm In VBA.UserForms
If UForm.Name = UFName Then
IsUserFormLoaded = True
Exit For
End If
Next
End Function 'IsUserFormLoaded
The first problem that I am facing is when user press
The button which locates in the upper left corner of the sheet to select the entire sheet range, it will not be copied. I was trying to correct it somehow by adding the condition of last row of selected range is bigger then...(see code please).
But it does not actually works. sometimes it copy range, sometimes no.
The second problem: inputbox is disappears when macro run. Have no idea why it happans.
Userform code:
Private Sub UserForm_Initialize()
Dim sh As Worksheet
For Each sh In ThisWorkbook.Sheets
ListBox1.AddItem sh.Name
Next sh
Me.StartUpPosition = 0
Me.Left = Application.Left + (0.5 * Application.Width) - (0.5 * Me.Width)
Me.Top = Application.Top + (0.5 * Application.Height) - (0.5 * Me.Height)
HideTitleBar.HideTitleBar Me
End Sub
Private Sub ListBox1_Click()
ThisWorkbook.Sheets(ListBox1.Value).Activate
Unload Me
End Sub
User forms contains list of sheets in current workbook, after user selection of the sheet data would be pasted.
I have a UserForm which should be able to copy paste cells ideally. So firstly I would click the range I would want to copy, then activate the UserForm. The UserForm would have a combo box to choose which sheet I want to paste the data in, thereafter it would go to that sheet and user will click on the range or cell where he wants the data to be pasted.
I originally did an input box code to do this and it works perfectly, however when I do it in the UserForm it does not work as I am not able to incorporate the Type:=8 code in the textbox. Hence I would need some help on how can I enable my UserForm to paste cell data on the sheet, similarly to what I have done in application.inputbox.
This is the perfectly working code in the form of an input box:
Sub CopyPasteCumUpdateWithinSameSheet()
Dim rng As Range
Dim inp As Range
Selection.Interior.ColorIndex = 37
Set inp = Selection
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
Exit Sub
Else
inp.Copy
rng.Select
ActiveSheet.Paste Link:=True
'Cells(1,2).Font.ThemeColor =
End If
End Sub
This is the UserForm I have tried:
Dim Sh As Worksheet
Private Sub CommandButton1_Click()
On Error GoTo 0
If TypeName(rng) <> "Range" Then
Exit Sub
Else
inp.Copy
rng.Select
ActiveSheet.Paste Link:=True
End If
End Sub
Private Sub UserForm_Initialize()
CopyPasteUserform.Show vbModeless
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> "Inputs" Then
ComboBox1.AddItem Sh.Name
End If
Next
ComboBox1.Style = fmStyleDropDownList
End Sub
Private Sub ComboBox1_Change()
With ThisWorkbook.Sheets(ComboBox1.Text)
.Visible = xlSheetVisible
.Activate
End With
End Sub
Private Sub TextBox1_Change()
Dim rng As Range
Dim inp As Range
Selection.Interior.ColorIndex = 37
Set inp = Selection
On Error Resume Next
Set rng = TextBox.Value
End Sub
I tried incorporating the UserForm but all other functions stop responding apart from the RefEdit.
Dim Sh As Worksheet
Private Sub UserForm_Initialize()
CopyPasteUserform.Show vbModeless
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> "Inputs" Then
ComboBox1.AddItem Sh.Name
End If
Next
ComboBox1.Style = fmStyleDropDownList
Dim rng As Range
Dim inp As Range
Selection.Interior.ColorIndex = 37
Set inp = Selection
End Sub
Private Sub Combobox1_Change()
With ThisWorkbook.Sheets(ComboBox1.Text)
.Visible = xlSheetVisible
.Activate
End With
End Sub
Private Sub RefEdit1_Change()
Label1.Caption = ""
If RefEdit1.Value <> "" Then _
Label1.Caption = "[" & ComboBox1 & "]" & RefEdit1
Dim rng As Range
Dim inp As Range
On Error Resume Next
Set rng = RefEdit1.Value
On Error GoTo 0
If TypeName(rng) <> "Range" Then
Exit Sub
Else
inp.Copy
rng.Select
ActiveSheet.Paste Link:=True
End If
End Sub
You do not need the combobox to navigate to the sheets. That is the beauty of the Refedit
Is this what you are trying? I have not done any error handling. I am sure you can take care of that.
Create a userform and place 2 labels, 2 refedits and 1 commandbutton as shown below
Next paste this code in the userform code area
Code
Private Sub CommandButton1_Click()
Dim rngCopy As Range, rngPaste As Range
Dim wsCopy As Worksheet, wsPaste As Worksheet
If RefEdit1.Value <> "" And RefEdit2.Value <> "" Then
Set wsCopy = ThisWorkbook.Sheets(Replace(Split(RefEdit1.Value, "!")(0), "'", ""))
Set rngCopy = wsCopy.Range(Split(RefEdit1.Value, "!")(1))
Set wsPaste = ThisWorkbook.Sheets(Replace(Split(RefEdit2.Value, "!")(0), "'", ""))
Set rngPaste = wsPaste.Range(Split(RefEdit2.Value, "!")(1))
rngCopy.Copy rngPaste
Else
MsgBox "Please select Input and Output range"
End If
End Sub
In Action
The data will be copied from Sheet1!$A$1:$A$3 to Sheet2!$A$1:$A$3
Followup From Comments
However the pastelink feature has been missed out in the userform. Is it possible to incorporate it?:) – Niva 7 mins ago
Add a checkbox to the form as shown below
Use this code
Private Sub CommandButton1_Click()
Dim rngCopy As Range, rngPaste As Range
Dim wsCopy As Worksheet, wsPaste As Worksheet
If RefEdit1.Value <> "" And RefEdit2.Value <> "" Then
Set wsCopy = ThisWorkbook.Sheets(Replace(Split(RefEdit1.Value, "!")(0), "'", ""))
Set rngCopy = wsCopy.Range(Split(RefEdit1.Value, "!")(1))
Set wsPaste = ThisWorkbook.Sheets(Replace(Split(RefEdit2.Value, "!")(0), "'", ""))
Set rngPaste = wsPaste.Range(Split(RefEdit2.Value, "!")(1))
If CheckBox1.Value = True Then
wsPaste.Activate
rngPaste.Select
rngCopy.Copy
ActiveSheet.Paste Link:=True
Else
rngCopy.Copy rngPaste
End If
Else
MsgBox "Please select Input and Output range"
End If
End Sub
Description: Type:=8 will check that user input correct range name or not? In UserForm the TextBox not have this function. But we can detect this error when user click button. see my code.
No need to check when textbox is change, I delete code of textbox_change.
Replace below in your user form code area.
Option Explicit
Dim Sh As Worksheet
Dim inp As Range
Dim rng As Range
Private Sub CommandButton1_Click()
ActiveCell.Value = Me.TextBox1.Text
'On Error Resume Next
'If TypeName(Range(Me.TextBox1.Text)) <> "Range" Then
' MsgBox "Invalid range name!", vbCritical
' Exit Sub
'Else
' inp.Copy
' rng.Select
'
' ActiveSheet.Paste Link:=True
' MsgBox "Copy and paste finish.", vbInformation
'End If
'On Error GoTo 0
End Sub
Private Sub UserForm_Initialize()
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> "Inputs" Then
ComboBox1.AddItem Sh.Name
End If
Next
ComboBox1.Style = fmStyleDropDownList
End Sub
Private Sub ComboBox1_Change()
With ThisWorkbook.Sheets(ComboBox1.Text)
.Visible = xlSheetVisible
.Activate
End With
End Sub
New to VBA, and using it in Excel.
I have a User form, and I am trying to use a lookup to fill TextBox4 from the value that is entered in ComboBox3. I have the following code which compiles, however it is producing the msgbox to say that the string cant be found...
Private Sub ComboBox3_Change()
Dim strFind As String
Dim rFound As Range
ws = "Year-to-Date Summary"
If ComboBox3.ListIndex > -1 Then
strFind = ComboBox3
On Error Resume Next
With ws.Column(2, 3)
Set rFound = .Find(What:="strFind", After:=.Cells(39, 49), _
LookIn:=.Cells(39, 49), LookAt _
:=.Cells(39, 49), SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:= False)
End With
If rFound Is Nothing Then
MsgBox strFind & " cannot be found"
Exit Sub
Else
TextBox4 = rFound(1, 2)
End If
End If
End Sub
I also tried Vlookup, however this sprung error messages...
Private Sub ComboBox3_Change()
TextBox4.Text = WorksheetFunction.VLookup(Val(ComboBox3.Text), _
Sheets("Year-to-Date Summary").Range("C39:C49" & LastRow), 2, False)
End Sub
ws is a variant. You do not assign worksheets like this. You have to use Set
strFind is within quotes so it will be considered as a string
See this example (UNTESTED)
Private Sub ComboBox3_Change()
If ComboBox3.ListIndex = 0 Then Exit Sub
Dim strFind As String
Dim ws As Worksheet
Dim rFound As Range
Set ws = ThisWorkbook.Sheets("Year-to-Date Summary")
strFind = ComboBox3.Value
Set rFound = ws.Columns(3).Find(What:=strFind, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rFound Is Nothing Then
TextBox4 = rFound.Offset(,1)
Else
MsgBox strFind & " cannot be found"
End If
End Sub
If your range is fixed then change ws.Columns(3) to ws.Range("C39:C49") in the above code.
If you would like to use the worksheet function then you this (TRIED AND TESTED)
Note: I have not used error trapping in the below code. i am sure you can take care of that.
Private Sub ComboBox3_Change()
If ComboBox3.ListIndex = 0 Then Exit Sub
TextBox4.Text = Application.WorksheetFunction.VLookup( _
Val(ComboBox3.Value), _
Sheets("Year-to-Date Summary").Range("C39:D49"), _
2, _
False _
)
End Sub
Note how we used C39:C49 / Columns(3) + Offset in the first example and how we used C49:D49 in the 2nd Example
EDIT: I forgot to comment on On Error Resume Next Never use it until and unless required. It is like telling the code to "shut up!" if it finds an error :)
Your ws is obviously a string, which does not have a .column property.
Replace line ws = "Year-to-Date Summary" by
set ws = worksheets("Year-to-Date Summary") and see if that helps.
Do you make sure that every module has an "Option Explicit" and that your app compiles successfully ? You would have spotted that error I think.
Private Sub ComboBox3_Change()
TextBox4.Text = WorksheetFunction.VLookup(Me.ComboBox3.Text, Sheets("Year-to-Date Summary").Range("$B$39:$C$49"), 2, False)
TextBox3.Text = WorksheetFunction.VLookup(Me.TextBox4.Text, Sheets("Year-to-Date Summary").Range("$C$39:$D$49"), 2, False)
End Sub
This worked for me, to do two textboxes from the combobox
Private Sub ComboBox3_Change()
Dim strFind As String
Dim rFound As Range
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Year-to-Date Summary")
If ComboBox3.ListIndex > -1 Then
strFind = ComboBox3.text
On Error Resume Next
'editted removing the whole vlookup part...
'added for loop to search the text within the range
Set rSearch = ws.Range("B:C")
For Each rFound In rSearch
If rFound.Value = strFind Then
TextBox4.Text = rFound.value
else
MsgBox strFind & " cannot be found"
Exit Sub
End If
Next rFound
End Sub