Repeat macro after UserForm Input - vba

The macro ,upon opening the workbook, will look to see if cell "C27" contains any of the following Text: Location1, Location2, Location3, or Location4. If they do then it will continue to save 2 copy files of the template by those locations. If not then it will open a UserForm To select the correct location from a ComboBox.
How could i reset the check after the UserForm is closed, I tried Call Auto_Open after the Unload me but it didnt work.
Macro
Sub Auto_Open()
With Range("B30")
.Value = Time
.NumberFormat = "h-mm-ss AM/PM"
End With
Dim FileName As String
Dim FilePath As String
Dim FileDate As String
Select Case Range("C27").Value
Case "Location1", "Location2", "Location3", "Location4"
FilePath = "C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test"
FileName = Sheets("Data").Range("C27").Text
Application.DisplayAlerts = False
ThisWorkbook.SaveAs FileName:=FilePath & "\" & FileName
Dim FileCopyName As String
Dim FileCopyPath As String
Dim FileTime As String
FilePath = "C:\Users\aholiday\Desktop\Backup"
FileName = Sheets("Data").Range("C27").Text
FileTime = Sheets("Data").Range("B30").Text
ThisWorkbook.SaveAs FileName:=FilePath & "\" & FileName & Space(1) & FileTime & ".xlsx", FileFormat:=xlOpenXMLWorkbook
MsgBox "File was saved! Ready for Next Test, Please Exit."
Case Else
MsgBox "File was not saved, Please Insert The Correct Testing Location"
UserForm.Show
Exit Sub
End Select
Application.DisplayAlerts = True
End Sub
UserForm
Private Sub UserForm_Initialize()
'Empty TestLocation Box
TestLocation.Clear
'Fill TestLocation Box
With TestLocation
.AddItem "Location1"
.AddItem "Location2"
.AddItem "Location3"
.AddItem "Location4"
End With
End Sub
'---------------------
Private Sub Insert_Click()
Sheets("Data").Activate
Range("C27").Value = TestLocation.Value
End Sub
'--------------------
Private Sub CloseBox_Click()
Unload Me
End Sub

By using the following code for the insert button:
Private Sub Insert_Click()
Sheets("Data").Range("C27").Value = TestLocation.Value
Auto_Open
End Sub
The code will work (tested it), as long as you have the Auto_Open code in a module.
If you put the Auto_Open sub in the ThisWorkbook then move it to the module.
Then use the following code in ThisWorkbook:
Private Sub Workbook_Open()
Auto_Open
End Sub
Also:
Case "Location1", "Location2", "Location1", "Location4"
Should be:
Case "Location1", "Location2", "Location3", "Location4"

Related

Passing an user form result to vba code variable

I have a code that counts the files in a folder if they contain a specific string on their name.
For example: If I want it to count the files with close on their name (Close_26_03_2003.csv).
Currently the code reads the value of a cell in the sheet and searches for that string in the file name with the (InStr function). Problem is I have to write the type of file in the cell.
What I am trying to do is create an user form, with three option buttons (open, close and cancel). For open it sets the string equal to open, and search for files that have it on their name (same as for close). Cancel ends the sub.
Problem is I don't know which code I have to use in the user form for this and don't know how to pass it to the code that counts files (I though about assigning it to a variable).
Code as is:
Sub CountFiles3()
Dim path As String, count As Integer, i As Long, var As Integer
Dim ws As Worksheet
Dim Filename As String
Dim FileTypeUserForm As UserForm1
Application.Calculation = xlCalculationManual
path = ThisWorkbook.path & "\*.*"
Filename = Dir(path)
'the problem is here:
'x = user form result***************
'if cancel = true, end sub
Set ws = ThisWorkbook.Sheets("FILES")
i = 0
Do While Filename <> ""
'var = InStr(Filename, ws.Cells(2, 7).Value) 'this is current code, it checks if the cell has open or close
var = InStr(Filename, x)
If var <> 0 Then
i = i + 1
ws.Cells(i + 1, 1) = Filename
Filename = Dir()
Else: Filename = Dir()
End If
Loop
Application.Calculation = xlCalculationAutomatic
ws.Cells(1, 2) = i
MsgBox i & " : files found in folder"
End Sub
And this is my current user form code:
Private Sub Cancel_Click()
Me.Tag = 3 ' EndProcess
Me.Hide
End Sub
Private Sub ClosingType_Click()
Me.Tag = 2 ' "CLOSING"
Me.Hide
End Sub
Private Sub OpeningType_Click()
Me.Tag = 1 ' "OPENING"
Me.Hide
End Sub
Any ideas?
add following code to your CountFiles3() sub in the "'the problem is here:" section:
Dim x As String
x = GetValue
If x = "end" Then Exit Sub
then add following code in any module:
Function GetValue()
With MyUserForm '<--| change "MyUserForm " to your actual UserForm name
.Show
GetValue = .Tag
End With
Unload MyUserForm '<--| change "MyUserForm " to your actual UserForm name
End Function
and change your Userform code as follwos
Private Sub Cancel_Click()
Me.Tag = "end" ' EndProcess
Me.Hide
End Sub
Private Sub ClosingType_Click()
Me.Tag = "close" ' "CLOSING"
Me.Hide
End Sub
Private Sub OpeningType_Click()
Me.Tag = "open" ' "OPENING"
Me.Hide
End Sub

how to set same assign commandbutton in each worksheet

I want to make commandButon every time I insert newsheet with the same name(TestButton). In the hope that if CommandButton click will call the procedure Tester. This applies to the CommandButton in all sheet. My code is as following:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim Obj As Object
Dim Code As String
Dim LF As String 'Line feed or carriage return
LF = Chr(13)
Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, DisplayAsIcon:=False, Left:=880, Top:=20, Width:=100, Height:=50)
Obj.Name = "TestButton"
'buttonn text
ActiveSheet.OLEObjects(1).Object.Caption = "Send"
'macro text
Code = "Sub TestButton_Click()" & LF
Code = Code & "Call Tester" & LF
Code = Code & "End Sub"
'add macro at the end of the sheet module
With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
.insertlines .CountOfLines + 1, Code
End With
End Sub
Sub Tester()
MsgBox "You have click on the test button"
End Sub
but I get an error message "Run-time error 1004 Programmatic access to Visual Basic is not trusted". how to solve it?
You should setup a worksheet how you want it and hide it. Use that worksheet as a template. Whenever you add a worksheet, replace it with a copy of the template.
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim WorkSheetName As String
Dim i As Integer
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = fasle
i = Sh.Index
Worksheets("HiddenTempalte").Copy After:=Worksheets(i)
WorkSheetName = Sh.Name
Sh.Delete
Worksheets(i).Name = WorkSheetName
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
"Trust Access to VBA Project":
How to check from .net code whether "Trust access to the VBA project object model" is enabled or not for an Excel application?
Consider using a Forms button instead:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
With Sh.Buttons.Add(Left:=880, Top:=20, Width:=100, Height:=50)
.Caption = "Send"
.OnAction = "Tester"
End With
End Sub
Public Sub Tester()
MsgBox "You have click on the test button"
End Sub

VBA won't call UserForm from inside its own workbook

I have a CMD button on my sheet with the following code:
Private Sub cmdBlastoff_Click()
UserForm2.Show vbModeless 'launch gateway userform
End Sub
This code worked for a long time, but is now generating "Error 9: Subscript out of range."
The userform I am trying to call (UserForm2) is located in the same workbook.
I will put the full code of the userform below in case it's relevant, but the code in its Userform_initialize sub is:
Private Sub userform_initialize()
Sheets("hiddensheet1").Range("B5").Value = "v7.04" 'sets version # in hidden sheet
FileNameChecker_local 'runs a sub (located below in the userform module) to determine the filename and path
ValueInjector 'runs a sub (located below in the userform module) to put some values into text fields on the userform
cmdBigGo.Font.Size = 15 'sets font size of a button
End Sub
As I said earlier, this was working until recently and I am out of ideas.
So far I have tried:
1) Finding some way to explicitly point to the exact location of
userform2 by specifying the workbook in front of it:
ActiveWorkbook.UserForm2.show (doesn't work for reasons that are
now obvious) I regard a more explicit call as the most likely fix,
but don't know how to do it
2) Removing vbModeless from the call button call
3) Explicitly setting the ActiveWorkbook to the one all my stuff is
stored on, which is where the call button sits (this shouldn't be
necessary, I know)
Any other ideas?
Full code of the UserForm2 (probably not relevant, all working prior to this problem arising):
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
'should check to see if there is an output folder in the directory where COGENT sits and if not create it
'should pull default filepath to the outputs folder from the hiddensheet
'should call data baster on terminate
'DONE should allow the user to change the default save location
'DONE should allow them to change the save location THIS time.
'DONE should pull filepath from hiddensheet, check against original (?) and
'DONE Should create a default filename
Public strFileFullName As String
Public strFileJustPath As String
Public strUserFolderName As String
Public strFileName As String
Public strRawDate As String
Public strDLlink As String
Public strDLdest As String
Public strDLlocalName As String
Public strDLNameOnWeb As String
Public strOpenURLPointer As String
Dim strSaveAsErrHandler As String
Dim strQueryID As String
Private Sub userform_initialize()
Sheets("hiddensheet1").Range("B5").Value = "v7.04" 'sets version # in hidden sheet
FileNameChecker_local 'runs a sub (located below in the userform module) to determine the filename and path
ValueInjector 'runs a sub (located below in the userform module) to put some values into text fields on the userform
cmdBigGo.Font.Size = 15 'sets font size of a button
End Sub
Private Sub chkCyberDiv_Click()
If chkCyberDiv.Value = True Then
'==Cyber OUs visible==
chkNDIO.Visible = True
txtQueryID.Value = "169436"
'==Other Div OUs invisible==
chkCivilDiv.Value = False
Else
chkNDIO.Visible = False
End If
End Sub
Private Sub chkCivilDiv_Click()
If chkCivilDiv.Value = True Then
'==Civil OUs visible==
chkCivilInfoSys.Visible = True
'==Other Div OUs invisible==
chkCyberDiv.Value = False
Else
chkCivilInfoSys.Visible = False
End If
End Sub
Sub cmdBigGo_Click()
'==========Check if SaveAsNewName worked and if not kill sub==========
SaveAsNewName
If strSaveAsErrHandler = "Filename/path not viable." Then
MsgBox strSaveAsErrHandler
Exit Sub
Else
'==========Startup==========
Application.ScreenUpdating = False
Sheets("LoadingData").Visible = True
Sheets("Launchpad").Visible = False
'==========Check for/create Temp Directory==========
If FileFolderExists(strFileJustPath & "\temp") = True Then
'MsgBox "temp Folder already exists."
Else
MkDir strFileJustPath & "\temp"
'MsgBox "temp Folder didn't exist, but it do now."
End If
'==========Download Section==========
'=====Set up===== 'big gap for now = 169436
strQueryID = txtQueryID.Value
strDLlink = "https://workbench.northgrum.com/xauth/login.aspx?&ActionPageID=37&ActionParameters=QueryID%3d" & strQueryID & "%26View%3d0%26OutputToExcel%3d1"
strDLdest = strFileJustPath & "\temp\dump.xlsx"
'=====Run=====
'MsgBox "cmdBigGo thinks strDLdest = " & strDLdest
Dim done
done = URLDownloadToFile(0, strDLlink, strDLdest, 0, 0)
'==========Copy Targets from temp file==========
Sheets("LoadingData").Select
copyPathName = strFileJustPath & "\temp\"
copyFileName = "dump.xlsx"
copyTabName = "Targets"
ControlFile = ActiveWorkbook.Name
Workbooks.Open FileName:=copyPathName & "\" & copyFileName
ActiveSheet.Name = copyTabName
Sheets(copyTabName).Copy After:=Workbooks(ControlFile).Sheets(1)
Windows(copyFileName).Activate
ActiveWorkbook.Close SaveChanges:=False
Windows(ControlFile).Activate
ActiveWorkbook.Sheets("Targets").Name = "COGENT Targets"
'^source: https://msdn.microsoft.com/en-us/library/office/ff194819.aspx
'==========Delete Temp Directory==========
On Error Resume Next
Kill copyPathName & "\*.*" ' delete all files in the folder
RmDir copyPathName ' delete folder
On Error GoTo 0
'==========Create Userform1 Button on "Targets"==========
Rows("1:1").RowHeight = 26
Dim btnCOGENT As Button
Set btnCOGENT = Sheets("COGENT Targets").Buttons.Add(10.5, 4.5, 84.75, 19.5)
With btnCOGENT
.OnAction = "CallUserform1"
.Characters.Text = "COGENT"
End With
With btnCOGENT.Characters(Start:=1, Length:=6).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
Sheets("COGENT Targets").Shapes("Button 1").ScaleWidth 0.7433628319, msoFalse, _
msoScaleFromTopLeft
'==========Finish up==========
Worksheets("COGENT Targets").Activate
Sheets("LoadingData").Visible = False
Application.ScreenUpdating = True
End If
UserForm1.Show vbModeless
End Sub
Private Sub SaveAsNewName()
strSaveAsErrHandler = ""
On Error GoTo ErrorHandler
'==========Save the file with a new name==========
Dim strExpectedFileFullName As String
strExpectedFileFullName = txtFilePath.Value & "\" & txtFileName & ".xlsm"
ActiveWorkbook.SaveAs strExpectedFileFullName
FileNameChecker_local 'get the new filename
Exit Sub
ErrorHandler:
'==========Error Handler==========
If Err.Number = 1004 Then
lblSaveAsText.Caption = "That name and location didn't work... Try using 'Browse' or 'Create Outbox."
lblSaveAsText.BackColor = &H8080FF
strSaveAsErrHandler = "Filename/path not viable."
Else
MsgBox "unknown error...email Owen.Britton#NGC.com; it's probably his fault."
strSaveAsErrHandler = ""
End If
End Sub
Sub FileNameChecker_local()
'==========Check Filename and SaveAs if needed==========
strFileJustPath = ActiveWorkbook.Path
strFileFullName = ActiveWorkbook.FullName
'==========Get Filename==========
Dim i As Integer
Dim intBackSlash As Integer, intPoint As Integer
For i = Len(strFileFullName) To 1 Step -1
If Mid$(strFileFullName, i, 1) = "." Then
intPoint = i
Exit For
End If
Next i
If intPoint = 0 Then intPoint = Len(strFileFullName) + 1
For i = intPoint - 1 To 1 Step -1
If Mid$(strFileFullName, i, 1) = "\" Then
intBackSlash = i
Exit For
End If
Next i
strFileName = Mid$(strFileFullName, intBackSlash + 1, intPoint - intBackSlash - 1)
'MsgBox "strFileName = " & strFileName & vbNewLine & _
"strFileJustPath = " & strFileJustPath & vbNewLine & _
"strFileFullName = " & strFileFullName & vbNewLine & _
"ran from userform2"
End Sub
Private Sub ValueInjector()
strRawDate = Format(Date, "mm-d-yy")
'==========Inject File Name==========
If strFileName = "COGENT Launchpad" Then
txtFileName.Value = "COGENT_Pull_" & strRawDate 'might be better to include query number\
lblSaveAsText.Caption = "Give your output a descriptive name. Here's a suggestion:"
Else
'txtFileName.Value = strFileName
lblSaveAsText.Caption = "This file should be named 'COGENT Launchpad.' Some features break if you rename it."
lblSaveAsText.BackColor = &H8080FF
'MsgBox "Please rename this file 'COGENT Launchpad'"
End If
'==========Inject File Path==========
Application.ScreenUpdating = False
If IsEmpty(Worksheets("Hiddensheet1").Range("B6")) Then
cmdCreateOutbox_click
Worksheets("Hiddensheet1").Range("B6") = strFileJustPath & "\Outbox"
txtFilePath.Value = Worksheets("Hiddensheet1").Range("B6")
Else
txtFilePath.Value = Worksheets("Hiddensheet1").Range("B6")
End If
Application.ScreenUpdating = True
Worksheets("Launchpad").Activate
End Sub
Private Sub cmdBrowse_Click()
FileNameChecker_local
GetFolder (strFileJustPath)
End Sub
Private Sub cmdMakeDefault_Click()
Worksheets("Hiddensheet1").Range("B6") = txtFilePath.Value
imgCheckMark.Visible = True
End Sub
Private Sub cmdCreateOutbox_click()
'MsgBox "looking for" & strFileJustPath & "\Outbox"
If FileFolderExists(strFileJustPath & "\Outbox") Then
MsgBox "Outbox Folder already exists."
Else
MsgBox "Outbox Folder did not exist, but it does now."
MkDir strFileJustPath & "\Outbox"
txtFilePath.Value = strFileJustPath & "\Outbox"
End If
End Sub
Function GetFolder(strFilePath As String) As String
Dim fldr As FileDialog
Dim strGetFolderOutput As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strFilePath
If .Show <> -1 Then GoTo NextCode
strGetFolderOutput = .SelectedItems(1)
End With
NextCode:
GetFolder = strGetFolderOutput
txtFilePath.Value = strGetFolderOutput
Set fldr = Nothing
End Function
Private Sub userform_terminate()
Unload Me
End Sub
Somehow the hidden sheet got deleted, and it gets referred to before I check its existence and create it if missing. Thanks guys; I was barking up totally the wrong tree. Fixed and working.
Nothing was wrong with the calling of the userform at all.

vba savecopyas: how to open the copied workbook then delete it's VBA Scripts

I have a savecopyas code at an at close prompt code that works, but if someone opens the copied document then trys to close it, the same copied VBA script within itself will try running the savecopyas to it's own path, resulting in an error/debug messagebox. My first idea would be to open the copied workbook in the background and delete all the VBA scripts then close and save as read only, however I also had a thought maybe I should just try to change the copied workbook to an .xlsx instead of it's original version .xslm format.
Any suggestions?
Here is what I have so far, but my question I guess is how do I open the copied workbook(not the original) and delete the VBA scripts in it in the background(not visible) then save and close?
Any help/suggestions would be much appreciated.
This is in my 'ThisWorkBook' module:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not Me.Saved Then
Msg = "Do you want to save the changes you made to "
Msg = Msg & Me.Name & "?"
Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case Ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call Auto_Save 'Change this to your own subroutine
End Sub
This is in my 'Module1':
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim backupfolder As String
backupfolder = "C:\Users\" & Environ("username") & "\Documents\John's Backup\"
ThisWorkbook.SaveCopyAs Filename:=backupfolder & ThisWorkbook.Name
End Sub
Sub Auto_Save()
Dim savedate
savedate = Date
Dim savetime
savetime = Time
Dim formattime As String
formattime = Format(savetime, "hh.MM.ss")
Dim formatdate As String
formatdate = Format(savedate, "DD - MM - YYYY")
Application.DisplayAlerts = False
Dim backupfolder As String
backupfolder = "C:\Users\" & Environ("username") & "\Documents\John's Backup\"
ActiveWorkbook.SaveCopyAs Filename:=backupfolder & ActiveWorkbook.Name
ActiveWorkbook.Save
Application.DisplayAlerts = True
MsgBox "Backup Run. Please Check at: " & backupfolder & " !"
End Sub
You nailed it - remove the macros by saving the workbook as an xlsx file (assuming you are using Excel 2007+).
If I understand your situation correctly, the workbook backup is saved when the workbook closes. So, I would save the workbook, then SaveAs the workbook, and then close the workbook.
One implementation could look like this:
ActiveWorkbook.Save
' Note that xlOpenXMLWorkbook = 41
ActiveWorkbook.SaveAs backupfolder & ActiveWorkbook.Name, FileFormat:= xlOpenXMLWorkbook
Separately, the folder location could fail if a user is on an older version of Windows (or if a future version has a different location for the Documents folder). So, instead of this:
backupfolder = "C:\Users\" & Environ("username") & "\Documents\John's Backup\"
do something like this:
Dim WshShell as Object
Set WshShell = CreateObject("WScript.Shell")
backupfolder = WshShell.SpecialFolders("MyDocuments") + "\John's Backup\"

Export excel file to txt format via excel vba GUI

My goal is to export excel file to txt file format. The idea is to has a GUI to let user select the excel file that she/he wish to export and she/he can decide which file path and file name to save. Once users has finish input and output setting, he/she just need to click Export text button to export the excel file to txt file and save in the location that he/she has decided. The GUI as below
I've a macro to convert excel file to txt format
Private Sub ConvertToText()
ActiveWorkbook.SaveAs FileName:="C:\Projects\ExelToText\Text.txt", FileFormat:=xlCurrentPlatformText, CreateBackup:=False
End Sub
My question is how could I pass value from FileInput and FileOutput as variable to above macro instead harcode the filepath. Appreciate your helps and if you have any better suggestions, please share it out. Thanks
Below is the full source code
Private Sub ReadButton_Click()
OpenWorkbookUsingFileDialog
End Sub
------------------------------
Private Sub WriteButton_Click()
WriteWorkbookUsingFileDialog
End Sub
------------------------------
Private Sub ExportButton_Click()
ConvertToText
End Sub
------------------------------
Private Sub OpenWorkbookUsingFileDialog()
Dim fdl As FileDialog
Dim FileName As String
Dim FileChosen As Integer
Set fdl = Application.FileDialog(msoFileDialogFilePicker)
fdl.Title = "Please Select a Excel File"
fdl.InitialFileName = "c:\"
fdl.InitialView = msoFileDialogViewSmallIcons
fdl.Filters.Clear
fdl.Filters.Add "Excel Files", "*.xlsx; *.xls"
FileChosen = fdl.Show
If FileChosen <> -1 Then
MsgBox "You have choosen nothing"
ReadTextBox = Null
Else
MsgBox fdl.SelectedItems(1)
FileName = fdl.SelectedItems(1)
ReadTextBox = FileName
End If
End Sub
-----------------------------------
Private Sub WriteWorkbookUsingFileDialog()
Dim file_name As Variant
file_name = Application.GetSaveAsFilename( _
FileFilter:="Text Files,*.txt,All Files,*.*", _
Title:="Save As File Name")
If file_name = False Then Exit Sub
If LCase$(Right$(file_name, 4)) <> ".txt" Then
file_name = file_name & ".txt"
End If
WriteTextBox = file_name
End Sub
----------------------------
Private Sub ConvertToText()
ActiveWorkbook.SaveAs FileName:="C:\Projects\ExelToText\Text.txt",FileFormat:=xlCurrentPlatformText, CreateBackup:=False
End Sub
Make it so your subroutine ConvertToText requires a file path/string argument:
Private Sub ConvertToText(sourcePath as String, destPath as String)
Dim wb as Workbook
Set wb = Workbooks.Open(sourcePath)
wb.SaveAs FileName:=destPath,
FileFormat:=xlCurrentPlatformText, CreateBackup:=False
wb.Close
End Sub
Then, make small modifications to your ExportButton to send this parameter to the ConvertToText sub:
Private Sub ExportButton_Click()
On Error Resume Next
ConvertToText Me.TextBox1.Value, Me.TextBox2.Value 'Modify this so that it refers to the TextBoxes on your form
If Err.Number <> 0 Then
MsgBox "Unable to convert file. Please ensure a valid file was entered.", vbCritical
End If
On Error GoTo 0
End Sub