Here's the code I have for renaming a file. It does a SaveAs and then deletes the original. This needs to be ran on different types of workbooks: some have a .xls extension, others have a .xlsx extension. If it has a .xls extension, I need to force it to have a .xlsx extension somehow.
How can I do this other than by manually typing an "x" at the end of the blank in the InputBox when it pops up?
Or maybe there's a different solution to this problem? My goal is to force the InputBox to show the current filename with a .xlsx extension regardless of what is currently is.
Sub RenameFile()
Dim myValue As Variant
Dim thisWb As Workbook
Set thisWb = ActiveWorkbook
MyOldName2 = ActiveWorkbook.Name
MyOldName = ActiveWorkbook.FullName
MyNewName = InputBox("Do you want to rename this file?", "File Name", _
ActiveWorkbook.Name)
If MyNewName = vbNullString Then Exit Sub
If MyOldName2 = MyNewName Then Exit Sub
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=thisWb.Path & "\" & MyNewName, _
FileFormat:=51
Kill MyOldName
End Sub
If the new extension is always going to be .xlsx, why not leave the extension out of the input box entirely:
Dim fso As New Scripting.FileSystemObject
MyNewName = InputBox("Do you want to rename this file?", "File Name", _
fso.GetBaseName(ActiveWorkbook.Name)) & ".xlsx"
Note that this requires a refernece to Microsoft Scripting Runtime.
Do you want to present the extension at the point of the MsgBox or after? The following code will force the extension to be changed to whatever type you specify. Just add code for other conversions you want to handle. If you want to present the new extension in the Msgbox, copy the code I added and place before the MsgBox. If you want to 'guarantee' new extension, you need to keep the code after the Msgbox in case user overrules your suggestion.
Sub RenameFile()
Dim myValue As Variant
Dim thisWb As Workbook
Dim iOld As Integer
Dim iNew As Integer
Dim iType As Integer
Set thisWb = ActiveWorkbook
Dim MyOldName2, MyOldName, MyNewName As String
MyOldName2 = ActiveWorkbook.Name
MyOldName = ActiveWorkbook.FullName
MyNewName = InputBox("Do you want to rename this file?", "File Name", _
ActiveWorkbook.Name)
If MyNewName = vbNullString Then Exit Sub
If MyOldName2 = MyNewName Then Exit Sub
iOld = InStrRev(MyOldName, ".")
iNew = InStrRev(MyNewName, ".")
If LCase(Mid(MyOldName, iOld)) = ".xls" Then
MyNewName = Left(MyNewName, iNew - 1) & ".xlsx"
iType = 51
ElseIf LCase(Mid(MyOldName, iOld + 1)) = ".YYYY" Then ' Add lines as needed for other types
MyNewName = Left(MyNewName, iNew - 1) & ".ZZZZ" ' Must change type to match desired output type
iType = 9999
Else
MsgBox "Add code to handle extension name of '" & LCase(Mid(MyOldName, iOld)) & "'", vbOKOnly, "Add Code"
Exit Sub
End If
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=thisWb.Path & "\" & MyNewName, FileFormat:=iType
Kill MyOldName
End Sub
Related
savePath = "\\local drive path"
myFileName = savePath & "Workbook Name " & saveDate
Application.DisplayAlerts = False
'MsgBox (myFileName)
wbTarget.Activate
ActiveWorkbook.SaveAs Filename:=myFileName, FileFormat:=xlOpenXMLWorkbook
When using the above code, I get an error 1004 "Method SaveAs of object_Workbook failed and can't figure out why. I'm relatively new to excel but belive I have everything set up right.
Update: Sorry should have shown the more complete code.
Sub SaveAs()
'Save As "Workbook Name"
Dim wbTarget As Workbook
Dim wbThis As Workbook
Dim strName As String
Set wbTarget = Workbooks("Workbook Name")
wbTarget.Activate
Dim myFileName As String
Dim saveDate As String
Dim saveMonth As String
Dim monthNum As String
Dim savePath As String
Sheets("Raw").Select
saveDate = Range("A2").Value
saveMonth = Range("A2").Value
monthNum = Range("A2").Value
savePath = "\\local drive path"
myFileName = savePath & "Riskviews Data " & saveDate
Application.DisplayAlerts = False
'MsgBox (myFileName)
wbTarget.SaveAs Filename:=myFileName, FileFormat:=xlOpenXMLWorkbook
End Sub
I updated the last part to say "wbTarget.SaveAs" but that didn't seem to work.
The problem may be with ActiveWorkBook. You should try to avoid relying on .Active, .Activate, and .Select when you can simply refer to your objects directly.
Delete wbTarget.Activate and try the below,
WbTarget.SaveAs Filename:=myFileName, FileFormat:=xlOpenXMLWorkbook
I can see you have tried to debug. MsgBox myFileName (notice: no ()) should have displayed what you are passing to the save command. From your code above, it would be \\local drive pathWorkbook Name - noting that there is a space at the end as well. You have not defined saveDate, you have not added an extension and you have not indicated the file format.
See the following answers for further information to SaveAs.
How to do a "Save As" in vba code, saving my current Excel workbook with datestamp?
I'm trying to assign a new excel worksheet that is being prompt to open as a new Workbook Object. I'm trying the below code, however it's not working
Option Explicit
Sub MoveGeneratedReport()
Dim newWbReport As Workbook
Dim MonthlyComplianceReport As Workbook
Set MonthlyComplianceReport = SelectWorkbook
End Sub
Private Function SelectWorkbook() As Workbook
Dim strFileToOpen As String
strFileToOpen = Application.GetOpenFilename(Title:="Select Compliancy Report for export", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strFileToOpen <> False Then '<---- Error Ocuring here
Workbooks.Open Filename:=strFileToOpen
End If
End Function
I'm receiving the
"Type Mismatch"
error, however if I just run the function SelectWorkbook() it works fine and opens the document.
My end goal here is to open the document and then assign it to a Workbook object. Any suggestions to fix this error?
EDIT:
I should clarify my question here too... How can I assign this newly opened Workbook via the prompt to a Workbook object so that the rest of my code can work with it?
EDIT 2:
This seems to be working really well
Option Explicit
Sub MoveGeneratedReport()
Dim newWbReport As Workbook
Dim MonthlyComplianceReport As Workbook
Set MonthlyComplianceReport = SelectWorkbook
Debug.Print MonthlyComplianceReport.Name
End Sub
Private Function SelectWorkbook() As Workbook
Dim strFileToOpen As String
strFileToOpen = Application.GetOpenFilename(Title:="Select Compliancy Report for export", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strFileToOpen <> "" Then
On Error GoTo ErrHandle
Set SelectWorkbook = Workbooks.Open(Filename:=strFileToOpen)
End If
Exit Function
ErrHandle:
If Err.Number <> 1004 Then
MsgBox "Error " & Str(Err.Number) & Chr(13) & _
"Error Line: " & Erl & Chr(13) & Chr(13) & _
Err.Description
End If
End Function
GetOpenFilename returns a String so it wont ever be true or false. Test for an empty string instead:
If strFileToOpen <> "" Then
Edit:
To set the workbook object change it to this:
Private Function SelectWorkbook() As Workbook
Dim strFileToOpen As String
strFileToOpen = Application.GetOpenFilename(Title:="Select Compliancy Report for export", _
FileFilter:="Excel Files *.xls* (*.xls*),")
If strFileToOpen <> "" Then
Set SelectWorkbook = Workbooks.Open(Filename:=strFileToOpen)
End If
End Function
I'm trying to combine/nest 3 different functions in Excel VBE: open, loop, and click. I have them written out separately, but am unsure of how to combine them. I've tried the "call macro" function but got a compile error returned to me.
The goal is to open a bunch of files within a certain folder and click on the URL in all of them (the URL will not always be the same, so I need a click function that targets any unknown URL within a sheet).
Open macro:
Sub openMyfile()
Dim Source As String
Dim StrFile As String
Source = "/users/kmogilevsky/Desktop/IC_new/"
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Do While Len(StrFile) > 0
Workbooks.Open Filename:=Source & StrFile
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Loop
End Sub
Loop macro:
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
Set MySource = MyObj.GetFolder("/users/kmogilevsky/Desktop/IC_new/")
For Each file In MySource.Files
If InStr(file.Name, "test") > 0 Then
End If
Next file
End Sub
Click macro (this needs some work):
Private Sub CommandButton1_Click()
Call NewSub
End Sub
Sub ReadWorkbooksInCurrentFolder()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim MyPath As String
Dim strFilename As String
'Stop annoying popups while macro is running
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'When working with many open workbooks its good to explicitly reference all workbooks, makes sure your code works and easier to read, understand and remember which workbook is which.
Set wbDst = ThisWorkbook
srcSheetName = "Data"
dstSheetName = "Results"
'I want to loop through all .xlsx files in the folder
MyPath = ThisWorkbook.Path
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)
If Len(strFilename) = 0 Then
MsgBox "No workbooks found ending in .xlsx in current folder"
Exit Sub
End If
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Call CollectData(wbDst, wbSrc, dstSheetName, srcSheetName)
wbSrc.Close
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub CollectData(ByRef wbDst as Workbook, ByRef wbSrc as Workbook, dstSheetName as String, srcSheetName as String)
'Copy cell A1 contents in source workbook to destination workbook cell A1
wbDst.Sheets(dstSheetName).Range("A1") = wbSrc.Sheets(srcSheetName).Range("A1")
End Sub
Please edit the subroutine CollectData() so that it suits your needs, i.e. performs the click / url open. (I am not familiar with opening urls from excel, but I loop through workbooks often)
This code will open all Excel files in the IC_New folder on the desktop.
It will then look at each sheet and follow any hyperlinks that are on the sheet.
Sub Open_ClickHyperlinks()
Dim sPath As String
Dim vFiles As Variant
Dim vFile As Variant
Dim wrkBk As Workbook
Dim wrkSht As Worksheet
Dim HLink As Hyperlink
sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & _
"IC_New" & Application.PathSeparator
'Return all files that have an extension starting with xls.
vFiles = EnumerateFiles(sPath, "xls*")
'Loop through each file.
For Each vFile In vFiles
'Open the file
Set wrkBk = Workbooks.Open(Filename:=vFile, UpdateLinks:=False)
With wrkBk
'Loop through each worksheet in the file.
For Each wrkSht In .Worksheets
'Loop through each hyperlink on the worksheet.
For Each HLink In wrkSht.Hyperlinks
HLink.Follow
Next HLink
Next wrkSht
.Close SaveChanges:=False
End With
Next vFile
End Sub
'Get all files in the specified folder, default to include all subfolders as well.
Public Function EnumerateFiles(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function
So here is 1 part of a 3 part macro that lets you browse to a folder and consolidate/transpose/retain header of a bunch of .csv files. The problem we have is where to inject some code so that routing and account numbers are formatted as text and retain their leading zeros. If the easiest solution is to just format the entire sheet as text, that would work for us...whatever it takes without having to go into specifics since this info wont always be in the same column.
Thanks in advance!
Option Explicit
'Set a public constant variable
Public Const DNL As String = vbNewLine & vbNewLine
Sub ImportData()
'Declare all variables
Dim wb As Workbook, ws As Worksheet
Dim wbX As Workbook, wsX As Worksheet
Dim i As Long, iRow As Long, iFileNum As Long, sMsg As String
Dim vFolder As Variant, sSubFolder As String, sFileName As String
Dim bOpen As Boolean
'Turn off some application-level events to improve code efficiency
Call TOGGLEEVENTS(False)
'Have the user choose the folder
vFolder = BrowseForFolder()
'Exit if nothing was chosen, variable will be False
If vFolder = False Then Exit Sub
'Check if this is what the user wants to do, confirm with a message box, exit if no
sMsg = "Are you sure you want to import data from this folder:"
sMsg = sMsg & DNL & vFolder
If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "ARE YOU SURE?") <> vbYes Then Exit Sub
'Set sub-folder as variable for save name at end of routine
sSubFolder = Right(vFolder, Len(vFolder) - InStrRev(vFolder, Application.PathSeparator))
'Set destination file with one worksheet
Set wb = Workbooks.Add(xlWBATWorksheet)
Set ws = wb.Sheets(1)
'This will be the row to start data on, to incriment in loop
iRow = 2
'Loop through files in folder
sFileName = Dir$(vFolder & "\")
Do Until sFileName = ""
'Check that the file pattern matches what you want, i.e. 12.16.00.xls
If sFileName Like "*.csv" Then '### set file extension here
'Check to see if the file is open
'If file is open, set as variable, if not, open and set as variable
If ISWBOPEN(sFileName) = True Then
Set wbX = Workbooks(sFileName)
bOpen = True
Else
Set wbX = Workbooks.Open(vFolder & "\" & sFileName)
bOpen = False
End If
'Set first sheet in target workbok as worksheet variable, from which to mine data
Set wsX = wbX.Sheets(1)
'Get last row from column A (range for copy/pasting)
i = wsX.Cells(wsX.Rows.Count, 1).End(xlUp).Row
'Check if a file has been added, if not add headers (frequency)
If iFileNum = 0 Then
ws.Range("B1", ws.Cells(1, i + 1)).Value = Application.Transpose(wsX.Range("A1:A" & i))
End If
'Add data
ws.Range("B" & iRow, ws.Cells(iRow, i + 1)).Value = Application.Transpose(wsX.Range("B1:B" & i))
'Add file name to column A
ws.Range("A" & iRow).Value = "'" & Left$(sFileName, Len(sFileName) - 4)
'Incriment variable values
iRow = iRow + 1
iFileNum = iFileNum + 1
'If file was closed to start with, clean up and close it
If bOpen = False Then wbX.Close SaveChanges:=False
End If
'Get next file name
sFileName = Dir$()
Loop
'Check if file name to save exists
If Dir$(vFolder & "\" & sSubFolder & ".xls", vbNormal) = "" Then
wb.SaveAs vFolder & "\" & sSubFolder & ".xls"
MsgBox "Complete!", vbOKOnly
Else
MsgBox "File already exists! File is NOT saved!", vbInformation, "COMPLETE!"
End If
'Reset events back to application defaults
Call TOGGLEEVENTS(True)
End Sub
I've created a excel spreadsheet template for our customers to populate and send back to us. I want to manually select their populated data and save it as a .csv to import into another piece of software. I, first, attempted this by recording a macro. This didn't work because different customers send different numbers of records.
I've tried snippets of code from online research and came up with this.
Sub Select_To_CSV()
Dim rng As Range
Dim myrangearea()
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Dim myPath As String, v
myPath = "p:\" & _
Format(Date, "yyyymmdd") & ".csv"
'myPath = "x:\" & Format(Date, "yyyymmdd") & ".csv"
v = SaveAs(myPath)
If v <> False Then ThisWorkbook.SaveAs v
End Sub
Function SaveAs(initialFilename As String)
On Error GoTo EndNow
SaveAs = False
With Application.FileDialog(msoFileDialogSaveAs)
.AllowMultiSelect = False
.ButtonName = "&Save As"
.initialFilename = initialFilename
.Title = "File Save As"
'.Execute
.Show
SaveAs = .SelectedItems(1)
End With
EndNow:
End Function
Sub Select_To_CSV()
Dim rng As Range
Dim myrangearea()
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Dim myPath As String, v
myPath = "p:\" & _
Format(Date, "yyyymmdd") & ".csv"
'myPath = "x:\" & Format(Date, "yyyymmdd") & ".csv"
v = SaveAs(myPath)
If v <> False Then ThisWorkbook.SaveAs v
End Sub
This worked really well except when I went back to look at the .csv in the folder it was the same worksheet not the selected columns.
Ultimately what I am looking to do is,
Manually select the columns I want
Run a macro that converts the selected columns to a .csv
Have the Save As Dialog Box appear
Navigate to the certain folder I want.
Here you go:
Sub MacroMan()
ChDrive "P:" '// <~~ change current drive to P:\
Dim copyRng As Excel.Range
Dim ThisWB As Excel.Workbook
Dim OtherWB As Excel.Workbook
Dim sName As String
'// set reference to the 'Master' workbook
Set ThisWB = ActiveWorkbook
'// assign selected range to 'copyRng'
Set copyRng = Application.InputBox(Prompt:="Select range to convert to CSV", Type:=8)
'// If the user selected a range, then proceed with rest of code:
If Not copyRng Is Nothing Then
'// Create a new workbook with 1 sheet.
Set OtherWB = Workbooks.Add(1)
'// Get A1, then expand this 'selection' to the same size as copyRng.
'// Then assign the value of copyRng to this area (similar to copy/paste)
OtherWB.Sheets(1).Range("A1").Resize(copyRng.Rows.Count, copyRng.Columns.Count).Value = copyRng.Value
'// Get save name for CSV file.
sName = Application.GetSaveAsFilename(FileFilter:="CSV files (*.csv), *.csv")
'// If the user entered a save name then proceed:
If Not LCase(sName) = "false" Then
'// Turn off alerts
Application.DisplayAlerts = False
'// Save the 'copy' workbook as a CSV file
OtherWB.SaveAs sName, xlCSV
'// Close the 'copy' workbook
OtherWB.Close
'// Turn alerts back on
Application.DisplayAlerts = True
End If
'// Make the 'Master' workbook the active workbook again
ThisWB.Activate
MsgBox "Conversion complete", vbInformation
End If
End Sub
This will allow you to manually select a range (including entire columns). It will then transfer said range onto a new sheet, save that sheet as a CSV, using the Save As dialog, and then close it afterwards.