I am working on an Access database with VBA, which needs to obtain data from an Excel workbook.
I need to assign a variable to the open book (set g_xl = ????) without opening another Excel instance (appoint to opened workbook).
Sub AssignVariableToExcelApplication()
Dim g_xl As Excel.Application
Dim strComputer As String
Dim objWMIService As Object
Dim colitems As Object
Dim objitem As Object
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colitems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", , 48)
Dim row As Integer
row = 1
For Each objitem In colitems
If objitem.Name = "EXCEL.EXE" Then
Debug.Print objitem.ProcessID & vbCrLf & _
objitem.Name & vbCrLf & _
objitem.Caption & vbCrLf & _
objitem.CommandLine & vbCrLf & _
objitem.ExecutablePath
'This is the question
'Set g_xl = objitem ?????? (I need that g_xl appoints to objitem)
Exit For
End If
Next
End Sub
You don't need any of this, only the full path to the Excel file. Then GetObject() can get a reference to the open workbook.
sPath = "C:\my\path\myWorkbook.xlsx"
Set wb = GetObject(sPath)
' Demo
Debug.Print wb.Sheets(1).Cells(1,1).Value
' If you need the Application
Set g_xl = wb.Application
This will only start a new Excel instance, if the file isn't open.
With g_xl as type Excel.Application, that commented line is going to be
Set g_xl = CreateObject("Excel.Application")
or
Set g_xl = GetObject("Excel.Application")
The latter will hook up with an existing Excel.Application which is what I think you're trying to do. It will create a new instance if an existing one isn't found.
Related
I have used the below code to a workbook (SaveAs) and then delete the original file.
The Windows OS put the new created file on the first left vacant space on My Desktop.
What I need after using SaveAs , is to move it’s icon to the same old position of the original file on my Desktop.
Meaning, If my file is initially placed on the upper right of my desktop , I want to keep it in that location after using SaveAs.
In advance, appreciate for your time to help.
Sub Rename_Me_Automatic()
Application.DisplayAlerts = False
Dim FilePath As String, wb As Workbook, FolderPath As String
Dim oldName As String, newName As String
Set wb = ThisWorkbook
FilePath = wb.FullName
FolderPath = wb.Path & Application.PathSeparator
oldName = wb.Name
newName = Left(oldName, Len(oldName) - 5) & WorksheetFunction.RandBetween(1, 20)
wb.SaveAs FolderPath & newName
Kill FilePath 'delete orginal file
Application.DisplayAlerts = True
End Sub
Please, also try this code. It uses classical Windows behavior. VBA writes a VBScript, creates the file and runs it. The script finds the open Excel session, the workbook in discussion, save, close it, quits Excel application in certaing circumstances and changes the workbook name only after that (keeping the same file icon position). Finally, the script kills itself:
Sub SaveAndChangeActiveWorkbookName_VBScript()
Dim vbsStr As String, fso As Object, vbsObj As Object, strVBSPath As String
Dim newName As String, wb As Workbook, ext As String, searchName As String
Set wb = ThisWorkbook
With wb
ext = Split(.Name, ".")(UBound(Split(.Name, ".")))
searchName = Left(.Name, Len(.Name) - (Len(ext) + 1))
End With
newName = searchName & WorksheetFunction.RandBetween(5, 20) & "." & ext
strVBSPath = ThisWorkbook.Path & "\Rename.vbs" 'the fullname of the VBScript to be created and run
vbsStr = "Dim objExcel, wb, objFile, FSO, fullName" & vbCrLf & _
"Set objExcel = GetObject(, ""Excel.Application"")" & vbCrLf & _
"Set FSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
" Set wb = objExcel.Workbooks(""" & ThisWorkbook.Name & """)" & vbCrLf & _
"fullName = wb.FullName" & vbCrLf & _
"wb.Close True" & vbCrLf & _
"If objExcel.Workbooks.Count = 0 Then" & vbCrLf & _
" objExcel.Quit" & vbCrLf & _
"ElseIf objExcel.Workbooks.Count = 1 Then" & vbCrLf & _
" If not UCase(Workbooks(1).Name) = ""PERSONAL.XLSB"" Then" & vbCrLf & _
" objExcel.Quit" & vbCrLf & _
" End If" & vbCrLf & _
"End If" & vbCrLf & _
"Set objFile = FSO.GetFile(fullName)" & vbCrLf & _
"objFile.Name = """ & newName & """" & vbCrLf & _
"FSO.DeleteFile Wscript.ScriptFullName, True" 'kill itself...
Set fso = CreateObject("Scripting.FileSystemObject")
Set vbsObj = fso.OpenTextFile(strVBSPath, 2, True)
vbsObj.Write vbsStr 'write the above string in the VBScript file
vbsObj.Close
Shell "cmd.exe /c """ & strVBSPath & """", 0 'execute/run the VBScript
End Sub
The next version tries simplifying your code, not needing any API:
Sub SaveAndChangeActiveWorkbookName_ShellAppl()
Dim sh32 As Object, oFolder As Object, oFolderItem As Object, wb As Workbook
Dim newName As String, ext As String, searchName As String
Set sh32 = CreateObject("Shell.Application")
Set wb = ThisWorkbook
With wb
ext = Split(.Name, ".")(UBound(Split(.Name, "."))) 'extract extension
searchName = Left(.Name, Len(.Name) - (Len(ext) + 1)) 'extract the rest of its name
newName = searchName & WorksheetFunction.RandBetween(5, 20) & _
IIf(showExtension, "." & ext, "") 'it sets correct new name...
.Save
.ChangeFileAccess xlReadOnly '!
Set oFolder = sh32.Namespace(.Path & "\")
Set oFolderItem = oFolder.ParseName(.Name)
oFolderItem.Name = newName
If (UCase(Workbooks(1).Name) = "PERSONAL.XLSB" _
And Workbooks.Count = 2) Or Workbooks.Count = 1 Then
Application.Quit
Else
.Close False 'no need to save it again and it closes faster in this way...
End If
End With
End Sub
'Function to check how 'Hide extension for known file type' is set:
Function showExtension() As Boolean
Dim fileExt As String, Shl As Object, hideExt As Long
fileExt = "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt"
Set Shl = CreateObject("WScript.Shell")
hideExt = Shl.RegRead(fileExt)
If hideExt = 0 Then showExtension = True
End Function
I've been educated that Windows does not allow changing name of an open workbook. Which is true, you cannot do it manually. Windows does not let you do it, this is its philosophy to avoid data loss.
But setting ReadOnly file attribute looks to temporarily remove the file full name from the Windows File Allocation Table. If you try Debug.Print wb.FullFileName before and after changing its attribute, it will show the same (old) one. But it looks that there are ways to do it and letting the open workbook outside the Allocation Table, you can change its name. I did not even imagine this is possible and I consider that this is the most important issue I learned today.
Intro: Windows OS saves the positions of desktop icons somewhere in registry or another location.
When I post my question, I thought the answer will depend on extracting coordinates of (SavedAs workbook icon) on my desktop,
And then using an API method to place it on the old location of the original file.
But , It looks hard for VBA programmers.
So, I tried the idea of #Daniel Dušek :
(The idea was to SaveAs with the original file name which will just overwrite the old file and then rename it instead of deleting).
The idea itself is excellent, But using native VBA methods (Name and FileSystemObject. MoveFile) ,
have a possible behavior to move the file beside renaming and I need to imitate how Windows OS works when it rename a file (like when you use right-click and choose Rename),
and also, I cannot rename the open workbook by using (Name and FSO. MoveFile) even after set ChangeFileAccess to xlReadOnly.
But, with using native OS API , you can do much more than you can imagine.
I have got a sophisticated API to Rename Link by the professional #Siddharth Rout
The advantage of this API is you can rename a workbook while it is still open (sure after Change File Access to xlReadOnly) 😊.
Now, All works correctly as expected, and I can SaveAs a file keep it’s icon on desktop at the same old position of the original file.
Sub SaveAs_and_Rename_Me_Automatically()
Dim wb As Workbook, filePath As String, folderPath As String
Dim oldName As String, newName As String, ext As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
filePath = wb.FullName
folderPath = wb.Path & "\"
oldName = fso.GetBaseName(filePath)
ext = fso.GetExtensionName(filePath)
newName = oldName & WorksheetFunction.RandBetween(5, 20) & "." & ext
Application.DisplayAlerts = False
wb.SaveAs folderPath & oldName 'SaveAs with orginal name (just overwrite)
wb.ChangeFileAccess xlReadOnly 'change file access to Read_Only:
SHRenameFile filePath, folderPath & newName 'to rename the Workbook while it is still open!
Application.DisplayAlerts = True
If Workbooks.Count = 1 Then
Application.Quit
Else
ThisWorkbook.Close SaveChanges:=True
End If
End Sub
And this the great API to rename:
Private Declare PtrSafe Function SHFileOperation Lib "shell32.dll" _
Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As LongPtr
Private Const FOF_SIMPLEPROGRESS = &H100
Private Const FO_RENAME = &H4
Private Type SHFILEOPSTRUCT
hWnd As LongPtr
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As LongPtr
sProgress As String
End Type
Public Sub SHRenameFile(ByVal strSource As String, ByVal strTarget As String)
Dim op As SHFILEOPSTRUCT
With op
.wFunc = FO_RENAME
.pTo = strTarget
.pFrom = strSource
.fFlags = FOF_SIMPLEPROGRESS
End With
SHFileOperation op '~~> Perform operation
End Sub
a bit hacky setup but works, the idea is following:
save workbook with the suffix "to_del"
from that temp file we rename the original file
save the workbook as the renamed file
delete "to_del" file from the original file
the code:
Sub Rename_Me_Automatic()
Application.DisplayAlerts = False
Dim filePath As String
Dim folderPath As String
Dim oldName As String
Dim newName As String
Dim wb As Workbook
Set wb = ThisWorkbook
filePath = wb.FullName
folderPath = wb.path & Application.PathSeparator
oldName = wb.Name
newName = Left(oldName, Len(oldName) - 5) & WorksheetFunction.RandBetween(1, 20)
wb.SaveAs Filename:=folderPath & newName & "_to_del.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Name folderPath & oldName As folderPath & newName & ".xlsm"
wb.SaveAs Filename:=folderPath & newName & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Kill folderPath & newName & "_to_del.xlsm"
Application.DisplayAlerts = True
End Sub
You do not say anything...
I have something to do in the next time interval, so I prepared a workaround, but working code based on my comment to your answer assumption, respectively:
A workbook named as the one keeping the code, only having a different numeric suffix before its extension, must exist on Desktop, like reference for the place where the other workbook to be placed;
Your code creates a new workbook, with a random (new) suffix.
ThisWorkbook is saved overwriting the existing workbook on Desktop, but using SaveCopyAs, to let the original workbook open and the overwitted workbook to be renamed (not being open):
Private Sub testSaveCopyAsOverwrite()
'References:
'Microsoft Shell Controls And Automation '(C:\Windows\System32\Shell32.dll)
Dim oShell As Shell32.Shell, oFolder As Shell32.Folder, oFolderItem As Shell32.FolderItem
Dim filePath As String, initFileName As String, newFileName As String, wb As Workbook
Dim thisName As String, newName As String, ext As String, searchName As String
filePath = "C:\Users\Fane Branesti\OneDrive\Desktop\"
Set wb = ThisWorkbook
thisName = wb.name
ext = Split(thisName, ".")(UBound(Split(thisName, ".")))
searchName = left(thisName, Len(thisName) - (Len(ext) + 1))
RecreateName: 'for the case when RandBetween returns the same name suffix...
newName = searchName & WorksheetFunction.RandBetween(5, 20) & "." & ext
Set oShell = New Shell32.Shell
initFileName = Dir(filePath & searchName & "*." & ext) 'find the file to be overwriten
If initFileName <> "" Then
If newName = initFileName Then GoTo RecreateName 'if RandBetween returned the same suffix...
ThisWorkbook.SaveCopyAs fileName:=filePath & initFileName 'overwrite the existing workbook, but keeping the original wb open
Set oFolder = oShell.NameSpace(filePath)
Set oFolderItem = oFolder.ParseName(initFileName)
oFolderItem.name = newName 'change the initial file name with the necessary one, without moving it!
Else
MsgBox "No any workbook having the name pattern as: """ & filePath & searchName & """*." & ext & """"
End If
End Sub
Please, take care to add the required reference (from C:\Windows\System32\Shell32.dll) before running it...
In fact, you can run the next code to add it:
Sub addShellControlsAndAutomation()
'Add a reference to 'Microsoft Shell Controls And Automation':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
On Error Resume Next
Application.vbE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\Shell32.dll"
If err.number = 32813 Then
err.Clear: On Error GoTo 0
MsgBox "'Microsoft Shell Controls And Automation' reference already added...", vbInformation, _
"Reference already existing"
End If
On Error GoTo 0
End Sub
I would like to start removing my references to late bind as Mr. Fenton suggests. However, I tried to late bind Excel, exactly as everything I have looked up, and could not fix it until I added
"Microsoft Visual Basic for Applications Extensibility 5.3".
My references currently are:
Visual Basic for Applications
Microsoft Access 15.0 Object Library
Microsoft Data Access Components Installed Version
Microsoft ActiveX Data Objects 6.1 Library
Microsoft DAO 3.6 Object Library
Microsoft Windows Common Controls 6.0 (SP6)
Microsoft Scripting Runtime
Microsoft XML,v6.0
Microsoft Visual Basic for Applications Extensibility 5.3.
Testing was done with Windows 10, Access 2013 Runtime and accdb.
Here is the top part of the Function with the declarations and section with the error:
On Error GoTo errHandle:
Dim FileToImport As Variant
Dim FilesLoaded As String
Dim csvStr As String
DoCmd.Hourglass False
Dim Loc As Integer
Loc = Forms!StartPage.LocationID
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim ofile As Object
Dim fdialog As Object
Dim rs As ADODB.Recordset
Dim uid As String
uid = Forms!AppLoginFrm!FullName
Dim stp As String
Dim thestr As String
Dim inboundrs As ADODB.Recordset
Dim ChkInbound As String
Dim repprg As Long
Dim ExcelApp As Object
Dim fname As String
Dim rng As Object
Dim wb As Object
Dim xlsheet1 As Object
Dim skiphead As Integer
stp = format(Now, "yyyy-mm-dd hh:nn:ss")
Dim tmpfile As String
tmpfile = TempPath()
tmpfile = tmpfile & "tmpLoad.txt"
skiphead = 2
Set fdialog = Application.FileDialog(3)
fdialog.Filters.Clear
fdialog.Filters.Add "Excel Files", "*.xls,*.xlsx"
fdialog.AllowMultiSelect = True
If fdialog.Show = 0 Then
Exit Function
End If
Set ofile = fso.CreateTextFile(tmpfile, True, False)
ofile.WriteLine """Location""" & "," & """YardTrack""" & "," & """Dir""" & "," & """Seq"""...
For Each FileToImport In fdialog.SelectedItems
Set ExcelApp = CreateObject("Excel.Application")
With ExcelApp
.Workbooks.Open FileToImport
.DisplayAlerts = -1
.Visible = -1
.Windows(1).Visible = -1
Set xlsheet1 = .Worksheets(1)
Set rng = xlsheet1.UsedRange
If xlsheet1.cells(1, 1).Value = "TOT-CARS" Then
skiphead = 3
End If
For i = skiphead To rng.rows.count
csvStr = csvStr & Chr(34) & rng(i, 1) & Chr(34) & "," & Chr(34) & rng(i, 2) & Chr...
ofile.Write csvStr
csvStr = ""
Next
ofile.Write Chr(34) & csvStr & Chr(34) & vbCrLf
ExcelApp.Workbooks.Close
Set rng = Nothing
Set xlsheet1 = Nothing
End With
FilesLoaded = FilesLoaded & vbCrLf & fileName(FileToImport)
Next FileToImport
ExcelApp.Quit
ofile.Close
Set fdialog = Nothing
Questions:
1) Did I miss a constant for Open?? The point was to remove references, but to make this work I had to add one. :(
2) What reference should I try to remove next? Honestly I'm a little scared after the last one, but I want the program as stable as possible.
Thank you in advance!
Here is something I copy/pasted out of my personal code stuffz. It is a generic late binding template for working with excel. You can increase your late bdingin efficiency by setting up a module with all the excle constants. Pretty nifty stuff.
Option Compare Database
Public Function getFile() As String
Dim f As Object
Dim i As Long
Set f = Application.FileDialog(3)
f.AllowMultiSelect = False
If f.Show Then
If f.SelectedItems.Count > 0 Then
getFile = f.SelectedItems(1)
End If
End If
End Function
Public Function ConvUNC(filePath As String) As String
Dim fileR As String
fileR = Replace(filePath, "C:", "C$")
ConvUNC = "\\" & Environ$("computername") & "\" & fileR
End Function
Public Sub UploadExcel()
On Error GoTo UpLoadExcel_Err
Dim fileP As String, FileDir As String
Dim oXL As Object, sheet As Object
Dim bringOver As Variant
fileP = getFile
If fileP = "" Then GoTo CleanUp
FileDir = Left(fileP, InStrRev(fileP, "\") - 1) & "\"
Set oXL = CreateObject("Excel.Application")
With oXL
.WorkBooks.Open FileName:=FileDir & Dir$(fileP)
Open NewTextFile For Output As #2
For Each sheet In .Worksheets
bringOver = .ActiveSheet.UsedRange
NextSheet:
Erase bringOver
Next sheet
End With
CleanUp:
On Error Resume Next
DoEvents
oXL.Quit
oXL.Application.Quit
Erase bringOver
Exit Sub
UpLoadExcel_Err:
MsgBox "An error has occured. " & " " & Err.Number & " " & Err.Description & " "
GoTo CleanUp
Resume
End Sub
BigBen seems to have had the answer. I just changed the workbook. I also moved the CreateObject out of the loop as Krish suggested, because of course it should be out of the loop! :)
Set wb = .Workbooks.Open(FileToImport)
.DisplayAlerts = -1
.Visible = -1
.Windows(1).Visible = -1
Set xlsheet1 = wb.Worksheets(1)
Set rng = xlsheet1.UsedRange
Doug, I think you're right I should make a reusable function. I haven't done the ConvUNC.. probably should. I can't use your code as is, because several excel uses use multiple select, but I think I can tweek it.
Thank you all for your help.
I am currently trying to get data recorded into excel workbooks to be automatically copied over onto one "mass data" sheet. The files are named by date ex. "5-28-17". There is one for each day of the month. I'd like to collect all data into one sheet, as previously stated, in order by date descending.
I am currently using this code which should place all of the different workbooks onto their own worksheet, but I am having issues with that as well.
Option Explicit
Const path As String = "C:\Users\dt\Desktop\dt kte\"
Sub GetSheets()
Dim FileName As String
Dim wb As Workbook
Dim sheet As Worksheet
FileName = Dir(path & "*.xls*")
Do While FileName <> ""
Set wb = Workbooks.Open(FileName:=path & FileName, ReadOnly:=True)
For Each sheet In wb.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
wb.Close
FileName = Dir()
Loop
End Sub
I am trying to do this with VBA. There are 15 columns in the sheets I'm pulling from and the sheet I want to copy to. All line up perfectly. Is there a way to move the sheets from the WB I'm currently working on which should contain a worksheet for each WB onto one mass worksheet? Or can I pull all data directly from the folder with all of the workbooks saved by date to one worksheet?
I would use this AddIn.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
It will do what you want, and a whole lot more as well.
Consider using an MS Access database. Not to worry if you do not have the Office GUI .exe app installed. Because you use a Windows machine, you do have its Jet/ACE SQL Engine (.dll files).
CREATE DATABASE
Sub CreateDatabase()
On Error GoTo ErrHandle
Dim fso As Object, olDb As Object, db As Object
Const dbLangGeneral = ";LANGID=0x0409;CP=1252;COUNTRY=0"
Const strpath As String = "C:\Path\To\ExcelDatabase.accdb"
' CREATE DATABASE
Set fso = CreateObject("Scripting.FileSystemObject")
Set olDb = CreateObject("DAO.DBEngine.120")
If Not fso.FileExists(strpath) Then
Set db = olDb.CreateDatabase(strpath, dbLangGeneral)
End If
MsgBox "Successfully created database!", vbInformation
ExitSub:
Set db = Nothing: Set olDb = Nothing: Set fso = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Resume ExitSub
End Sub
CREATE, POPULATE, EXPORT EXCEL TABLE (Excel files never opened)
Sub CreateTable()
On Error GoTo ErrHandle
Dim conn As Object, rst As Object
Dim constr As String, FileName As String, i As Integer
Const xlpath As String = "C:\Users\dt\Desktop\dt kte\"
Const accpath As String = "C:\Path\To\ExcelDatabase.accdb"
' CONNECT TO DATABASE
constr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & accpath & ";"
Set conn = CreateObject("ADODB.Connection")
conn.Open constr
i = 1
FileName = Dir(xlpath & "*.xls*")
Do While FileName <> ""
If i = 1 Then
' CREATE TABLE VIA MAKE TABLE QUERY
conn.Execute "SELECT * INTO MyExcelTable" _
& " FROM [Excel 12.0 Xml;HDR=Yes;" _
& " Database=" & xlpath & FileName & "].[Sheet1$]"
Else
' POPULATE VIA APPEND QUERY
conn.Execute "INSERT INTO MyExcelTable" _
& " SELECT * FROM [Excel 12.0 Xml;HDR=Yes;" _
& " Database=" & xlpath & FileName & "].[Sheet1$]"
End If
i = i + 1
FileName = Dir()
Loop
' EXPORT TO EXCEL
Set rst = CreateObject("ADODB.Recordset")
rst.Open "SELECT * FROM MyExcelTable", conn
ThisWorkbook.Worksheets("MASS_DATA").Range("A1").CopyFromRecordset rst
' CLOSE CONNECTION
rst.Close: conn.Close
MsgBox "Successfully created and populated table!", vbInformation
ExitSub:
Set rst = Nothing: Set conn = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Resume ExitSub
End Sub
I have a macro that get data from a word file and writes it into an excel file and saves it to a specific location.
I want the user to be able to choose where to save the file.
This is my current code:
Sub createExcelFile()
Dim mPathSave As String
Dim xlsApp As Excel.Application
Dim xlsWB As Workbook
Set xlsApp = CreateObject("Excel.Application")
Set xlsWB = xlsApp.Workbooks.Add
'Want to make it dynamic'
mPathSave = "C:\temp"
callFunc = createExcel.createExcel(xlsApp, xlsWB)
'Save the excel file
xlsWB.SaveAs mPathSave & "\" & "teste" & ".xls", FileFormat:=56
xlsWB.Close
xlsApp.Quit
MsgBox "Novo arquivo salvo em: " & mPathSave & "\" & "teste" & ".xls", vbInformation
End Sub
I tried to use Application.FileDialog to open the dialog to choose the place, but I can't make it save a excel, it opens to save a word file.
Here is a simple example
Sub createExcelFile()
Dim mPathSave As String
Dim xlsApp As Excel.Application
Dim xlsWB As Workbook
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = True
Set xlsWB = xlsApp.Workbooks.Add
'Want to make it dynamic'
Application.FileDialog(msoFileDialogFolderPicker).Show
mPathSave = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
'Save the excel file
xlsWB.SaveAs mPathSave & "\" & "teste" & ".xls", FileFormat:=56
xlsWB.Close
xlsApp.Quit
End Sub
I found the following Dos batch script here on the SF forum Rename Multiple files with in Dos batch file and it works exactly as designed :)
My problem is that I execute this from within an excel vba script and
I have to build a delay E.G a Msgbox in the VBA otherwise the VBA script executes faster than the dos script renames the file that I need, resulting in a file not found (it's done on the fly and as I need them).
The excel workbook opens a sheet which is named between 1 and 800. If I want to open file 14.csv(according to the sheet name) the dos script won't help much because it renames the files in sequence, so 1,2,3,4,5 and not 1,2,3,4, 14 (or as required).
a better description maybe:
I open a sheet which is automatically assigned a number(in this case sheet 14) - I then trigger a vba script to find a file with a specific begining in the directory i.e "keyw*.csv" and rename this to E.g "14.csv" which is in turn, imported to its sheet. There is only ever ONE such file that begins "keyw*.csv" present in the directory before it's renamed.
Basically as I see it, I only have the choice of a different function in a DOS batch file or even better, something on the basis of "MoveFile" in a VBA macro, but when I try "MoveFile" in VBA, it doesn't recognize the "*".
Each time I download a file it begins with "keywords_blahbla" so the I need to use a wildcard to find it, in order to rename it.
Obviously I could easily just open the directory and click on the file, but I really would like to automate the whole process so can you possibly guide me in the right direction
thanks
this is the DOS batch I use:
REM DOS FILE
echo on
cd\
cd c:\keywords\SOMETHING\
SETLOCAL ENABLEDELAYEDEXPANSION
SET count=3
FOR %%F IN (c:\keywords\SOMETHING\*.csv) DO MOVE "%%~fF" "%%~dpF!count!.csv" & SET /a
count=!count!+1
ENDLOCAL
and this is the associated VBA script:
Dim vardirfull As String
Dim RetVal
Dim varInput As Variant
Dim fso As Object
vardirfull = Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, ".", vbTextCompare) - 1)
vardir = UCase(vardirfull)
varfil = ActiveSheet.Name
If Range("A2") <> "" Then
ActiveSheet.Range("A2:C1050").ClearContents
Selection.Hyperlinks.Delete
'-----------------------------------------
'using VBA input to open the file:
'varInput = InputBox("Please enter the NUMBER/NAME highlited at the bottom of this Worksheet or enter 'new' for a new Worksheet")
'If CStr(varInput) <> CStr(ActiveSheet.Name) Then GoTo MustBeSheetName
'-----------------------------------------
'using the DOS Batch:
'RetVal = Shell("C:\keywords\" & vardir & "\changeto3.bat", 1)
'MsgBox "check1 - C:\keywords\" & vardir & "\" & varfil & ".csv"
'-----------------------------------------
'using VBA to search without opening a dialog:(wildcard is not accepted)
Set fso = CreateObject("Scripting.FileSystemObject")
fso.MoveFile "C:\keywords\" & vardir & "\keyw*.csv", "C:\keywords\" & vardir & "\" & vardir & ".csv"
'MsgBox "pause to allow DOS to fully execute(if used)"
If (fso.FileExists("C:\keywords\" & vardir & "\" & varfil & ".csv")) Then
Set fso = Nothing
GoTo Contin
Else
MsgBox "No such File"
Exit Sub
End If
Contin:
Range("A2:B2").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\keywords\" & vardir & "\" & varfil & ".csv", Destination:=Range("$A$2"))
EDIT 1
The script is stating an error "constant expression required" which I don't understand because the variable "vardir" is already defined
Dim vardirfull As String
vardirfull = Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, ".", vbTextCompare) - 1)
vardir = UCase(vardirfull)
ActiveSheet.Range("A2:C1050").ClearContents
Selection.Hyperlinks.Delete
'-----------------------------------------
Dim sNewFile As String
Dim sh As Worksheet
Dim qt As QueryTable
Dim sConn As String
Const sPATH As String = "C:\magickeys\" & vardir & "\" **'(error:constant expression required**
Const sKEY As String = "keyw"
'I'm not sure how your sheet gets named, so I'm naming
'it explicitly here
Set sh = ActiveSheet
'sh.Name = "14"
sNewFile = sh.Name & ".csv"
'look for 'keyword' file
sOldFile = Dir(sPATH & sKEY & "*.csv")
'if file is found
If Len(sOldFile) > 0 Then
'rename it
Name sPATH & sOldFile As sPATH & sNewFile
End If
EDIT 2: SOLVED
THANKYOU CHRIS :)
Having played around with the script and tidied mine up a bit, it is now fully functional
As the sheet name is already assigned to any new sheet via the backend, there was no need to set a name but in case anyone would like this, I've included and commented out an Input variation, so you just enter the sheetname and the rest is automated(simply uncomment those lines).
Obviously I have left out the exact type of import at the bottom as everyone would like to import different rows and to change a different filename, simply change the "sKEY" variable.
Thanks again Chris
Sub RenameandImportNewFile()
'Dim varInput As Variant
'varInput = InputBox("Rename this sheet and the File to be imported will be named accordingly or Cancel, vbCancel")
'If varInput = "" Then Exit Sub
'ActiveSheet.Name = varInput
Dim fso As FileSystemObject
Dim Fl As file
Dim vardirfull As String
Dim sPATH As String
Dim sKEY As String
Dim sNewFile As String
vardirfull = Left(ThisWorkbook.Name, InStr(1, ThisWorkbook.Name, ".", vbTextCompare) - 1)
vardir = UCase(vardirfull)
sPATH = "C:\magickeys\" & vardir & "\"
sKEY = "key"
sh = ActiveSheet.Name
sNewFile = sPATH & sh & ".csv"
ActiveSheet.Range("A2:C1050").ClearContents
Selection.Hyperlinks.Delete
'-----------------------------------------
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FileExists(sNewFile)) Then
GoTo Contin
Else
MsgBox "The File : " & sNewFile & " will now be created"
End If
sOldFile = sPATH & sKEY & "*.csv"
'------------------------------------------
Set fso = New FileSystemObject
Set Fl = FindFile(fso, "C:\magickeys\" & vardir & "\", "key*.csv")
If Fl Is Nothing Then
MsgBox "No Files Found"
Exit sub
Else
MsgBox "Found " & Fl.Name
If Len(sOldFile) > 0 Then
Name Fl As sNewFile
'------------------------------------------
Contin:
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & sNewFile, Destination:=Range("$A$2"))
'here the rows you want to import
end sub
include this function after the sub
Function FindFile(ByRef fso As FileSystemObject, FolderSpec As String, FileSpec As String) As file
Dim Fld As folder
Dim Fl As file
Set Fld = fso.GetFolder(FolderSpec)
For Each Fl In Fld.Files
If Fl.Name Like FileSpec Then
' return first matching file
Set FindFile = Fl
GoTo Cleanup:
End If
Next
Set FindFile = Nothing
Cleanup:
Set Fl = Nothing
Set Fld = Nothing
Set fso = Nothing
End Function
Running a batch file to do this is making your code unnecasarily complex. Do it all in VBA. One usefull tool is the FileSystemObject
Early bind by seting a reference to the Scripting type library (Scrrun.dll)
Dim fso as FileSystemObject
Set fso = New FileSystemObject
Late bind like
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
There is lots of info on SO, in the documentation and online
EDIT: FileSystemObject method to match a file using wildcard
Function to search a directory or files matching a pattern, return first matching file found
Function FindFile(ByRef fso As FileSystemObject, FolderSpec As String, FileSpec As String) As file
Dim Fld As Folder
Dim Fl As file
Set Fld = fso.GetFolder(FolderSpec)
For Each Fl In Fld.Files
If Fl.Name Like FileSpec Then
' return first matching file
Set FindFile = Fl
GoTo Cleanup:
End If
Next
Set FindFile = Nothing
Cleanup:
Set Fl = Nothing
Set Fld = Nothing
Set fso = Nothing
End Function
Example of Use
Sub DemoFindFile()
Dim fso As FileSystemObject
Dim Fl As file
Set fso = New FileSystemObject
Set Fl = FindFile(fso, "C:\temp", "File*.txt")
If Fl Is Nothing Then
MsgBox "No Files Found"
Else
MsgBox "Found " & Fl.Name
End If
Set Fl = Nothing
Set fso = Nothing
End Sub
I don't totally understand your workflow here, but hopefully the below will give you enough information to adapt it to your situation.
Sub ImportCSV()
Dim sOldFile As String
Dim sNewFile As String
Dim sh As Worksheet
Dim qt As QueryTable
Dim sConn As String
Const sPATH As String = "C:\Users\dick\TestPath\"
Const sKEY As String = "keyword"
'I'm not sure how your sheet gets named, so I'm naming
'it explicitly here
Set sh = ActiveSheet
sh.Name = "14"
sNewFile = sh.Name & ".csv"
'look for 'keyword' file
sOldFile = Dir(sPATH & sKEY & "*.csv")
'if file is found
If Len(sOldFile) > 0 Then
'rename it
Name sPATH & sOldFile As sPATH & sNewFile
'create connection string
sConn = "TEXT;" & sPATH & sNewFile
'import text file
Set qt = sh.QueryTables.Add(sConn, sh.Range("A2"))
'refresh to show data
qt.Refresh
End If
End Sub