Hey all,
I have code working for some workers here ,who used to save excel files in a folder and my databse upload those files into database and then do the rest.I am looking for a code in vba which,on upload button matches the file in table and if the file already exists ,it should not upload again in the table and if it does not exists it should upload . I have attached my code below :
I have code working for some workers here ,who used to save excel files in a folder and my databse upload those files into database and then do the rest.I am looking for a code in vba which,on upload button matches the file in table and if the file already exists ,it should not upload again in the table and if it does not exists it should upload . I have attached my code below :
Code:
Private Sub Command0_Click()
Dim strcPath As String
strcPath = "O:\QA Files\QC Reporting\Pending Review\"
Dim strcNewPath As String
strcNewPath = "O:\QA Files\QC Reporting\MovedFiles\" & Format(Now, "yyyy-mm-dd h-mm-ss") _
& " Excel Files" & "\"
strDatabaseFilePath = "O:\QA Files\QC Reporting\Pending_Review_Database_Files\"
FileExt = "*.xl*"
Set FSO = CreateObject("Scripting.FileSystemObject")
' FSO.CreateFolder (strDatabaseFilePath)
FSO.CopyFile Source:=strcPath & FileExt, Destination:=strDatabaseFilePath
Dim strPath As String
Dim strNewPath As String
Dim strFile As String
Dim strFileList() As String
Dim intFile As Integer
Dim strFullPath As String
Dim strFullNewPath As String
Dim msgstr As String
Dim lot As String
Dim strSQl As String
Dim SQL As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim ctl As Control
Dim varItem As Variant
Dim strFileBracket As String
Dim strDate As String
Dim strDateList() As String
Dim intDate As Integer
Dim strDateResult As String
Dim InsertStrDb As String
' On Error GoTo ErrorHandler
' See if path constant ends in a backslash:
If Right(strcPath, 1) = "\" Then
strcPath = strcPath
Else
strcPath = strcPath & "\"
End If
' See if new path constant ends in a backslash:
If Right(strcNewPath, 1) = "\" Then
strNewPath = strcNewPath
Else
strNewPath = strcNewPath & "\"
End If
[COLOR=darkred] ' Loop through the Excel files in the folder
' (if any) and build file list:[/COLOR]
strFile = Dir(strcPath & "*.xlsm")
' strDate = Dir(strcPath & "*.xlsm")
While strFile <> ""
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
For intFile = 1 To UBound(strFileList)
'Reads the substring(the Lot# from the name of the file)
intpos = InStr(1, strFile, ")")
'intDate = InStr(1, strFile, ".")
intDatePos = InStr(1, strFile, "(")
If intpos > 0 Then
' : found, so take up to :
If strFile = "" Then
' MsgBox ("There is no file")
Else
strResult = Left(strFile, intpos)
' strDateResult = Left(strFile, intDate - 1)
strLotFinalResult = Left(strResult, intpos - 1)
' strNewDate = Right(strFile, intDate - 1)
' strRight = Right(strFile, intDatePos - 8)
strNewDate = Mid(strFile, intDatePos)
strRight = Left([strNewDate], InStrRev([strNewDate], ".") - 1)
strFinalDate = Right(strRight, 8)
strDate1 = Left(strFinalDate, 2)
strDate2 = Mid(strFinalDate, 3, 2)
strDate3 = Right(strFinalDate, 4)
InsertStrDb = (strDate1) & "/" & (strDate2) & "/" & (strDate3)
' Initialise paths:
[COLOR=red]strFullPath[/COLOR] = strcPath & strFile
[SIZE=5][COLOR=red]
"Something HERE maybe for matching the file name before inserting"[/COLOR][/SIZE]
Set db = CurrentDb()
DoCmd.SetWarnings (False)
strSQl = "INSERT INTO tblExcelLocation(LotNumber,ExcelPathLocation,SearchByDate) VALUES ( " & " (' " & strLotFinalResult & "')" & ",(' " & Replace([SIZE=4][COLOR=red]strFullPath[/COLOR][/SIZE], "'", "''") & "'),(' " & Replace(InsertStrDb, "'", "''") & " '))"
DoCmd.RunSQL (strSQl)
DoCmd.SetWarnings (False)
db.Close
End If
Else
' : not found, so take whole string
strResult = strFile
' MsgBox (strResult)
End If
If strFile = "" Then
' MsgBox ("There is no file")
Else
strFile = Dir()
End If
' MsgBox UBound(strFileList) & " file(s) were imported", _
vbOKOnly + vbInformation, "Program Finished"
' Next
Next
Wend
FileExt = "*.xl*"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strcPath) Then
answer = MsgBox("File already exists in this location. " _
& "Are you sure you want to continue? If you continue " _
& "the file at destination will be deleted!", _
vbInformation + vbYesNo)
If answer = vbNo Then
Exit Sub
End If
' Kill strcNewPath
End If
'FSO.CreateFolder (strDatabaseFilePath)
FSO.CopyFile Source:=strcPath & FileExt, Destination:=strDatabaseFilePath
Set FSO = Nothing
'Code for deleting .xlsm files from pending review folder 'but i dont need this at the point
'del_xlsm
' See if any files were found:
' MsgBox (strFullPath)
' Import into Access:
'DoCmd.TransferSpreadsheet acImport, _
' acSpreadsheetTypeExcel97, strcTableName, _
'strFullPath, True
MsgBox " All file(s) imported ", _
vbOKOnly + vbInformation, "Program Finished"
End Sub