I am comfortable with using VBA to import excel sheets into access, and to loop through a given folder to bring back everything in there. However, I want to loop through a folder and only import a selection of the files. Can someone help? Each file is called REPORT1 etc and runs to REPORT67. I only want to pick 1-47.
Code below works fine, but this just copies everything in from the specified location.
Sub Sample2()
Const cstrFolder As String = "F:\TCB_HR_KPI\Data View\"
Dim strFile As String
Dim i As Long
strFile = Dir(cstrFolder & "*.xls")
If Len(strFile) = 0 Then
MsgBox "No Files Found"
Else
Do While Len(strFile) > 0
Debug.Print cstrFolder & strFile
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strFile, cstrFolder & strFile, True
i = i + 1
strFile = Dir()
Loop
MsgBox i & " Files are imported"
End If
End Sub
I just replaced your code, "Do While Len(strFile) > 0" into "Do While Int(Mid(strFile, 7)) < 48", hope it helps.
Sub Sample2()
Const cstrFolder As String = "F:\TCB_HR_KPI\Data View\"
Dim strFile As String
Dim i As Long
strFile = Dir(cstrFolder & "*.xls")
If Len(strFile) = 0 Then
MsgBox "No Files Found"
Else
Do While Int(Mid(strFile, 7)) < 48
Debug.Print cstrFolder & strFile
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strFile, cstrFolder & strFile, True
i = i + 1
strFile = Dir()
Loop
MsgBox i & " Files are imported"
End If
End Sub
I would do:
Dir$()
DoWhile Val(Mid(filename, 7, 2))<48
Import the file
Dir$()
Loop
Related
I have the following Module in Access:
On Error Resume Next
Dim strDir As String
Dim strFile As String
Dim I As Long
I = 0
strDir = "C:\excelTest\"
strFile = Dir(strDir & "*.xlsx")
While strFile <> ""
I = I + 1
strFile = strDir & strFile
Debug.Print "importing " & strFile
DoCmd.TransferSpreadsheet acImport, , "mainTable", strFile, False 'has columnheaders
strFile = Dir()
Wend
MsgBox "Load Finished"
importExcelSheets = I
End Function
This imports the data from the xlsx files within the directory (C:\excelTest). This all works fine, but how can I add an additional field which stores the directory and file?
ie. If I have a file test.xlsx during the import a field is created and the path C:\excelTest\test.xlsx is stored.
After records are imported, run an SQL UPDATE action with criteria that distinguishes those new records from previously existing, possibly a date value. Something like:
CurrentDb.Execute "UPDATE tablename SET fieldname = '" & strFile & "' WHERE datefield = #" & <some date input here> & "#"
I'm trying to create a list of files in a specific directory folder where I am renaming the files, but because there is a chance some files should not be renamed, I only need to rename the PDF files that begin with the letters "AB".
The renaming works fine, I just need to make sure it only renames specific files.
Private Sub CMD_RENAME_FILES_Click()
On Error GoTo CMD_RENAME_FILES_ERR
Dim varDir As String
varDir = Me.TXT_BILLING_STATEMENT_PATH
If MsgBox("Are you sure you want to rename all of the files in the directory " & "'" & varDir & "'", vbYesNo, "Confirm") = vbNo Then
Exit Sub
Else
Dim strFileName, varDateString As String
Dim strFolder As String: strFolder = Nz(Me.TXT_BILLING_STATEMENT_PATH, "Z:\")
Dim strFileSpec As String: strFileSpec = strFolder & "*.pdf"
Dim FileList() As String
Dim intFoundFiles As Integer
DoCmd.RunSQL ("UPDATE tblDirFileList SET tblDirFileList.RenameSelection = -1 WHERE FileName LIKE 'AB*'")
strFileName = Dir(strFileSpec, "AB*.PDF") 'THIS AB* DOESN'T WORK"
varDateString = Format(Date, "mmddyy")
Do While Len(strFileName) > 0
ReDim Preserve FileList(intFoundFiles)
FileList(intFoundFiles) = strFileName
intFoundFiles = intFoundFiles + 1
varLoanNumString = Mid(strFileName, 4, 9)
varNewStrFile = varLoanNumString & " - BILL STMT - " & varDateString & ".pdf"
On Error Resume Next
Name strFolder & strFileName As strFolder & varNewStrFile
strFileName = Dir
Loop
Call CMD_GET_FILE_NAMES_Click
End If
CMD_RENAME_FILES_ERR_EXIT:
Exit Sub
CMD_RENAME_FILES_ERR:
Call LogError(Err.Number, Err.Description, "CMD_RENAME_FILES_Click()")
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
Resume CMD_RENAME_FILES_ERR_EXIT
End Sub
I have mutiple folders (appox. 400 and could increase up in some cases) and each of these folders contains some files. I wanted to zip all these folders with their contents and create 400 zip files. I wanted to automate this with VBA. I tried with the following code. The standard one which uses shell application.
Sub Zip_All_Files_in_Folder_Browse()
Dim FileNameZip, FolderName, oFolder
Dim strDate As String, DefPath As String
Dim oApp As Object
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"
Set oApp = CreateObject("Shell.Application")
'Browse to the folder
Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
If Not oFolder Is Nothing Then
'Create empty Zip File
NewZip (FileNameZip)
FolderName = oFolder.Self.Path
If Right(FolderName, 1) <> "\" Then
FolderName = FolderName & "\"
End If
'Copy the files to the compressed folder
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).Items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).Items.Count = _
oApp.Namespace(FolderName).Items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
Sub NewZip(sPath)
'Create empty Zip File
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
I can call the above code in loop to create mutiple zip folders. However, I was wondering if this is really an effcient process! Is there any alternative for this procedure? Sometimes my count of folders to be zipped may go beyound 1000. So I would really appreciate your suggestions and ideas on this.
Thank you in advance
Well, if you don't need everything separated into 400 different folders, you can combine them all into one zipped folder.
Sub Zip_All_Files_in_Folder_Browse()
Dim FileNameZip, FolderName, oFolder
Dim strDate As String, DefPath As String
Dim oApp As Object
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"
Set oApp = CreateObject("Shell.Application")
'Browse to the folder
Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
If Not oFolder Is Nothing Then
'Create empty Zip File
NewZip (FileNameZip)
FolderName = oFolder.Self.Path
If Right(FolderName, 1) <> "\" Then
FolderName = FolderName & "\"
End If
'Copy the files to the compressed folder
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = _
oApp.Namespace(FolderName).items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
https://www.rondebruin.nl/win/s7/win001.htm
Is there anyway to modify Ron De Bruin's code to export the current workbook to a password-protected zip file. I've looked around for quite some time, and can't figure out how to enable such an option.
Code is here: http://www.rondebruin.nl/win/s7/win001.htm
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Sub Zip_ActiveWorkbook()
Dim strDate As String, DefPath As String
Dim FileNameZip, FileNameXls
Dim oApp As Object
Dim FileExtStr As String
DefPath = "C:\Users\Ron\test\" '<< Change
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create date/time string and the temporary xl* and Zip file name
If Val(Application.Version) < 12 Then
FileExtStr = ".xls"
Else
Select Case ActiveWorkbook.FileFormat
Case 51: FileExtStr = ".xlsx"
Case 52: FileExtStr = ".xlsm"
Case 56: FileExtStr = ".xls"
Case 50: FileExtStr = ".xlsb"
Case Else: FileExtStr = "notknown"
End Select
If FileExtStr = "notknown" Then
MsgBox "Sorry unknown file format"
Exit Sub
End If
End If
strDate = Format(Now, " yyyy-mm-dd h-mm-ss")
FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & ".zip"
FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & FileExtStr
If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
'Make copy of the activeworkbook
ActiveWorkbook.SaveCopyAs FileNameXls
'Create empty Zip File
NewZip (FileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNameXls
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the temporary xls file
Kill FileNameXls
MsgBox "Your Backup is saved here: " & FileNameZip
Else
MsgBox "FileNameZip or/and FileNameXls exist"
End If
End Sub
I've found an accepted answer for this on another site using 7Zip......
strDestFileName = "c:\temp\TestZipFile.zip"
strSourceFileName = "c:\temp\test.pdf"
str7ZipPath = "C:\Program Files\7-Zip\7z.exe"
strPassword = "MyPassword"
strCommand = str7ZipPath & " -p" & strPassword & " a -tzip """ & strDestFileName & """ """ & strSourceFileName & """"
Shell strCommand
I am using the DIR function to import a set of excel files into access. I then pass the attributes of the DIR to make the name of the table in access the same as the excel file. The only problem is that I also get xls in the name how I can I stop this?
Code below:
Sub Sample2()
Const cstrFolder As String = "F:\TCB_HR_KPI\Data View\"
Dim strFile As String
Dim i As Long
strFile = Dir(cstrFolder & "*.xls")
If Len(strFile) = 0 Then
MsgBox "No Files Found"
Else
Do While Len(strFile) > 0
Debug.Print cstrFolder & strFile
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strFile, cstrFolder & strFile, True
i = i + 1
strFile = Dir()
Loop
MsgBox i & " Files are imported"
End If
End Sub
Strip it off as necessary with a helper function...
Function StripFileExt(FileName As String) As String
Dim Pos As Long
Pos = InStrRev(FileName, ".")
If (Pos > 0) And (Pos > InStrRev(FileName, "\")) Then
StripFileExt = Left$(FileName, Pos - 1)
Else
StripFileExt = FileName
End If
End Function
Use the Split Function to split on ".", and take the first element of that array for your table name.
Split(strFile, ".")(0)
You could store that result in a intermediate variable. Or just use the expression directly in the TransferSpreadsheet statement.
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
Split(strFile, ".")(0), cstrFolder & strFile, True
Note: Based on your previous question, I assumed the workbook file names contain only a single dot: names from REPORT1.xls thru REPORT67.xls However if the file names you're dealing with this time can include more than one dot, my first suggestion is inappropriate.
In that case, you can still use an expression which includes Split(), but that expression would not be as simple.
Left(strFile, Len(strFile) - Len(Split(strFile, ".")(1)) -1)
Notice that approach would accommodate any of the other Excel file extensions in addition to .xls
Do you want this ?
Sub Sample2()
'
Const cstrFolder As String = "F:\TCB_HR_KPI\Data View\"
'
Dim i As Long, lng As Long
'
Dim strExt As String, strFile As String, strTable As String
'
strExt = ".xls"
lng = Len(strExt)
strFile = Dir(cstrFolder & "*" & strExt)
'
If Len(strFile) = 0 Then
MsgBox "No Files Found"
Else
Do While Len(strFile) > 0
'
' Debug.Print cstrFolder & strFile
'
strTable = Left(strFile, Len(strFile) - lng)
'
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strTable, cstrFolder & strFile, True
i = i + 1
strFile = Dir()
Loop
MsgBox i & " Files are imported"
End If
'
End Sub
As this a file like Sample1.xls will be improrted as the table Sample1.