Import mulitple excelfiles with multiple sheets - issue with range - excel

I'm trying to import multiple Excelfiles with multiple sheets.
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
strFileName = "C:\SomeFile\File.xlsx"
Set objWorkbook = objExcel.Workbooks.Open(strFileName)
Set colWorksheets = objWorkbook.Worksheets
For Each objWorksheet in colWorksheets
Set objRange = objWorksheet.UsedRange
strWorksheetName = objWorksheet.Name & "!" & objRange.Address(False, False)
objAccess.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"Vulnerability", strFileName, True, strWorksheetName
Next
I have a problem with the range. The variable strWorksheetName = "BE900!A1:L1634".
I get a runtime-error '3011'. The "!" is replaced by "$" so the sheet isn't found.
Any ideas?
ALL of my code
Public Function ImportFiles()
Dim strFolder As String
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strFile As String
Dim strTable As String
Dim strExtension As String
Dim lngFileType As Long
Dim strSQL As String
Dim strFullFileName As String
Dim varPieces As Variant
With Application.FileDialog(3) ' msoFileDialogFolderPicker
.AllowMultiSelect = True
.Title = "Please select one or more files"
.Initialfilename = "*.xls*"
If .Show Then
strFullFileName = .SelectedItems(1)
Else
MsgBox "No folder specified!", vbCritical
Exit Function
End If
End With
strFile = Dir(strFolder)
Set db = CurrentDb()
strFile = Dir(strFolder & "*.xls*")
Do While Len(strFile) > 0
strTable = DetermineTable(strFile)
strSQL = "UPDATE [" & strTable & "] SET FileName=[pFileName]" & vbCrLf & _
"WHERE FileName Is Null OR FileName='';"
Set qdf = db.CreateQueryDef(vbNullString, strSQL)
varPieces = Split(strFile, ".")
strExtension = varPieces(UBound(varPieces))
Select Case strExtension
Case "xls"
lngFileType = acSpreadsheetTypeExcel9
Case "xlsx", "xlsm"
lngFileType = acSpreadsheetTypeExcel12Xml
Case "xlsb"
lngFileType = acSpreadsheetTypeExcel12
End Select
Set objexcel = CreateObject("Excel.Application")
Set objworkbook = objexcel.Workbooks.Open(strFullFileName)
Set colworksheets = objworkbook.Worksheets
For Each objWorksheet In colworksheets
Set objRange = objWorksheet.UsedRange
**strWorksheetName = objWorksheet.Name & "!" & objRange.Address(False, False)**
'strWorksheetName = objRange.Address(0, 0, external:=True)
DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
SpreadsheetType:=lngFileType, _
tableName:=strTable, _
FileName:=strFile, _
HasFieldNames:=False, _
**Range:=CStr(strWorksheetName)**
Next
colworksheets.Close
colworksheets = Nothing
objworkbook.Close
objworkbook = Nothing
objexcel.Close
objexcel = Nothing
Set db = CurrentDb()
Set tdf = db.TableDefs(strTable)
'Add the field to the table.
If FieldExistsInTable(strTable, "FileName") = True Then
'Do nothing
Else
tdf.Fields.Append tdf.CreateField("FileName", dbText, 255)
'tdf.fields.append tdf.createField("SheetName", dbText, 255)
End If
'Supply the parameter value for the UPDATE and execute it ...
qdf.Parameters("pFileName").Value = strFile
qdf.Execute 'dbFailOnError
'Move to the next file
strFile = Dir
Loop
Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
'rstTable.Close
Set rstTable = Nothing
End Function

Macro does not have an error, works well in my PC.
You can try a PC restart.
I this does not help, you may define strWorksheetName2, replace $ in strWorksheetName with !. Then give it to access object.

Rebuilded the code from scratch in a new db, now it works.
Thanks for the assistance.

Related

Consolidate data from closed workbooks adodb approach

I have found a code and modified to suit my files. The code is supposed to loop through closed workbooks (7 files) and import specific columns (myHeading) to ThisWorkbook
Sub Consolidate()
Dim a, ws As Worksheet, myDir As String, myHeading As String, sFile As String, cn As Object, rs As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder"
.InitialFileName = ThisWorkbook.Path & "\"
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
Set ws = ThisWorkbook.Worksheets("Sheet1")
a = Array("Accrued Date", "Description", "Amount Accrued (LC)", "Product", "Account Description", "Product Charge Code", "Country")
Application.ScreenUpdating = False
With ws
.Range("A1").Resize(, UBound(a) + 1).Value = a
With .Cells(1).CurrentRegion
myHeading = "`" & Join(.Parent.Evaluate(.Rows(1).Address & "&"""""), "`, `") & "`"
.Offset(1).ClearContents
End With
End With
sFile = Dir(myDir & "*.xlsx")
Do While sFile <> ""
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
With cn
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;"
.Open myDir & sFile
End With
rs.Open "Select " & myHeading & " From `MyReport$`;", cn
ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rs
rs.Close: cn.Close
Set cn = Nothing: Set rs = Nothing
sFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
The code takes too long time (about 5 minutes) although the files are only 7 and I have used ADODB approach which I know is more faster than opening the excel files directly.
Any ideas how to make it faster and what may obstacles the code and make it slow?
Can you try this (I couldn't test the code):
EDIT:
Commands can only be used if connected to an actual Database.
Sub Consolidate()
Dim a, ws As Worksheet, myDir As String, myHeading As String, sFile As String, cn As Object, rs As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder"
.InitialFileName = ThisWorkbook.Path & "\"
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
Set ws = ThisWorkbook.Worksheets("Sheet1")
a = Array("Accrued Date", "Description", "Amount Accrued (LC)", "Product", "Account Description", "Product Charge Code", "Country")
Application.ScreenUpdating = False
With ws
.Range("A1").Resize(, UBound(a) + 1).Value = a
With .Cells(1).CurrentRegion
myHeading = "`" & Join(.Parent.Evaluate(.Rows(1).Address & "&"""""), "`, `") & "`"
.Offset(1).ClearContents
End With
End With
sFile = Dir(myDir & "*.xlsx")
Set cn = CreateObject("ADODB.Connection")
With cn
.Open "Provider=Microsoft.Ace.OLEDB.12.0;Persist Security Info=False;"
End With
Do While sFile <> ""
Set rs = CreateObject("ADODB.Recordset")
rs.Open = "Select " & myHeading & " From [Excel 12.0 Xml; HDR = Yes;Database=" & myDir & sFile & "].[" & "MyReport$];"
ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rs
Set rs = Nothing
sFile = Dir
Loop
cn.Close: Set cn = Nothing
Application.ScreenUpdating = True
End Sub

ADO stream concert to binary

This is the code that I use to upload file into database using VBA, but this loop can only run once. During the second loop it will give error, the error is
Operation is not allowed in this context
Can anybody suggest me what to do?
The error is in the line adoStream.Type = adTypeBinary
Dim stCon As String 'SQL Connection string
Dim stProcName As String 'Stored Procedure name
Dim strCmd As String
Dim adoStream As Object
Dim adocmd As Object
Dim strFilePath As String
Dim adoCon As Object
Set adoCon = CreateObject("ADODB.Connection")
Set adoStream = CreateObject("ADODB.Stream")
Set adocmd = CreateObject("ADODB.Command")
adoCon.CursorLocation = adUseClient
adoCon.Open "Provider=SQLOLEDB; " & _
"Data Source=#########; " & _
"Initial Catalog=#######;" & _
"User ID=#######; Password=########;"
For Each fl In fld.Files
If fl.name Like Mask Then
strInput = fl.name
strFilePath = fld.path & "\" & fl.name
MsgBox (strFilePath)
adoStream.Type = adTypeBinary
adoStream.Open
adoStream.LoadFromFile strFilePath 'It fails if file is open
With adocmd
.CommandText = "INSERT INTO dbo.coc_upload(Data) " & _
"VALUES (?)"
.CommandType = adCmdText
'---adding parameters
.Parameters.Append .CreateParameter("#Data", adVarBinary, adParamInput, adoStream.Size, adoStream.Read)
'---
End With
adocmd.ActiveConnection = adoCon
adocmd.Execute
adoCon.Close
MsgBox ("Done")
End If
Next

delete blue and empty cells from xlsx with vbscript

I've got a vbscript that converts a specific range of rows to a csv file.
My problem is it also copies empty rows and not needed blue rows. How can I delete this complete empty rows before copying or exclude them from copying?
My code:
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile
Dim objExcel, objWorkbook, wsSource, wsTarget
myFile = "source_file.xlsx"
SaveName = "test.csv"
With CreateObject("Scripting.FilesystemObject")
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
Set wsTarget = objWorkbook.Sheets.Add()
With wsTarget
.Cells(1,1).Value = "ID"
.Cells(1,2).Value = "NAME"
.Cells(1,3).Value = "DESC"
End With
With wsSource
.Range("F7", .Range("F" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("A2")
.Range("A7", .Range("A" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("B2")
.Range("E7", .Range("E" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("C2")
End With
objWorkbook.SaveAs WorkingDir & SaveName, xlCSV
objWorkbook.Close True
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
call xlsToCsv()
Option explicit
'// Define the blue color here
dim ibluecolor: ibluecolor = 15652797 ' this is 40% Accent1
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile, myFolder
Dim objExcel, objWorkbook, wsSource, wsTarget
myFile = "source_file.xlsx"
SaveName = "test.csv"
With CreateObject("Scripting.FilesystemObject")
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
Set wsTarget = objWorkbook.Sheets.Add()
With wsTarget
.Cells(1,1).Value = "ID"
.Cells(1,2).Value = "NAME"
.Cells(1,3).Value = "DESC"
End With
dim Fcol, Acol, Ecol
With wsSource
set Fcol = .Range("F7", .Range("F" & .Rows.Count).End(xlUp))
set Acol = .Range("A7", .Range("A" & .Rows.Count).End(xlUp))
set Ecol = .Range("E7", .Range("E" & .Rows.Count).End(xlUp))
End With
With wsTarget
Fcol.Copy .Range("A2")
Acol.Copy .Range("B2")
Ecol.Copy .Range("C2")
End With
dim Frc, Arc, Erc
Frc = Fcol.Rows.Count
Arc = Acol.Rows.Count
Erc = Ecol.Rows.Count
dim rowcount
rowcount = Max(Arc, Frc, Erc)
dim ix
with wsTarget
for ix = rowcount + 1 to 2 step -1
if Len(.cells(ix,1))=0 and len(.cells(ix,2))=0 and len(.cells(ix,3))=0 then
.rows(ix).delete
'//Check for blue rows assuming all cells in the row have the same color
elseif .cells(ix, 1).Interior.Color = iBlueColor then
.rows(ix).delete
end if
next
End With
objWorkbook.SaveAs WorkingDir & SaveName, xlCSV
objWorkbook.Close True
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
call xlsToCsv()
Function Max(v1, v2, v3)
select case true
case v1 => v2 and v1 => v3
Max = v1
case v2 => v3
Max = v2
case else
Max = v3
end select
end function
This is an alternative approach to my original in an attempt to improve performance. In this case, instead of using Excel to create the csv file, the VBScript code writes the csv file directly using a text file created by FileSystemObject. I have tested this with a larger set of source data and it seems to be quite a bit quicker than the original - about 40 seconds for 1500 rows. There is still an overhead of opening the Excel application (about 5-10 seconds) but there's not much you can do about that. If performance is important to you there may be other improvements that you could do.
If you have numeric values in the spreadsheet, you may need to do some formatting to convert to string values suitable for csv output, because Excel tends to use exponential notation for numbers converted to text, which is not always what you want. I have also used quotation marks and comma separators but you could use different formatting conventions for your CSV output. You may want to change the use of WriteLine because this appends a CrLf after the last line, which might be interpreted downstream as a blank row.
Option explicit
'// Define the blue color here
dim ibluecolor: ibluecolor = 15652797 ' this is 40% Accent1
msgbox "starting"
call xlsToCsv()
msgbox "finished"
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile, myFolder
Dim objExcel, objWorkbook, wsSource, wsTarget
Dim oOutputFile
myFile = "source_file.xlsx"
SaveName = "test2.csv"
With CreateObject("Scripting.FilesystemObject")
'// Check that the input file exists
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
'// Create a text file to be the output csv file
'// Overwrite v v False=ASCII format use True for Unicode format
set oOutputFile = .CreateTextFile( WorkingDir & SaveName, True, False)
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
oOutputFile.WriteLine """ID"",""NAME"",""DESC"""
'// Get the three column ranges, starting at cells in row 7
dim Fcol, Acol, Ecol
With wsSource
set Fcol = .Range("F7", .Range("F" & .Rows.Count).End(xlUp))
set Acol = .Range("A7", .Range("A" & .Rows.Count).End(xlUp))
set Ecol = .Range("E7", .Range("E" & .Rows.Count).End(xlUp))
End With
'// Get the number of rows in each column
dim Frc, Arc, Erc
Frc = Fcol.Rows.Count
Arc = Acol.Rows.Count
Erc = Ecol.Rows.Count
'// Rowcount is the max row of the three
dim rowcount
rowcount = Max(Arc, Frc, Erc)
dim AVal, FVal, EVal
dim ix
for ix = 1 to rowcount
'// Note - row 1 of each column is actually row 7 in the workbook
AVal = REPLACE(ACol.Cells(ix, 1), """", """""")
EVal = REPLACE(ECol.Cells(ix, 1), """", """""")
FVal = REPLACE(FCol.Cells(ix, 1), """", """""")
'// Check for an empty row
if Len(AVal)=0 and len(EVal)=0 and len(FVal)=0 then
'// skip this row
'// Check for a blue row
elseif ACol.cells(ix,1).Interior.Color = iBlueColor then
'// skip this row
else
'// Write the line to the csv file
oOutputFile.WriteLine """" & FVal & """,""" & AVal & """,""" & EVal & """"
end if
next
'// Close the output file
oOutputFile.Close
'// Close the workbook
objWorkbook.Close True
objExcel.Quit
'// Clean up
Set oOutputFile = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
Function Max(v1, v2, v3)
select case true
case v1 >= v2 and v1 >= v3
Max = v1
case v2 >= v3
Max = v2
case else
Max = v3
end select
end function

can't delete empty rows from xlsx with vbscript

I've got a vbscript that converts a specific range of rows to a csv file.
My problem is it also copies empty rows. How can I delete complete empty rows before copying or exclude them from copying?
My code:
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile
Dim objExcel, objWorkbook, wsSource, wsTarget
myFile = "source_file.xlsx"
SaveName = "test.csv"
With CreateObject("Scripting.FilesystemObject")
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
Set wsTarget = objWorkbook.Sheets.Add()
With wsTarget
.Cells(1,1).Value = "ID"
.Cells(1,2).Value = "NAME"
.Cells(1,3).Value = "DESC"
End With
wsSource.Activate
wsSource.Range("A:F").Cells.SpecialCells(xlCellTypeBlanks).‌​EntireRow.Delete
With wsSource
.Range("F7", .Range("F" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("A2")
.Range("A7", .Range("A" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("B2")
.Range("E7", .Range("E" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("C2")
End With
objWorkbook.SaveAs WorkingDir & SaveName, xlCSV
objWorkbook.Close True
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
call xlsToCsv()
With this command "wsSource.Range("A:F").Cells.SpecialCells(xlCellTypeBlanks).‌​EntireRow.Delete" ended with the error code 800A0408 - invalid chars.

How to add file name when importing multiple Excel files to one Access table

I am using Access VBA to import multiple Excel files into my Access database. This will be a monthly process with 20-50 files and 10-60K records. I need to include an "Application name" that isn't included within the spreadsheet file itself, but is in its file name. Rather than manually adding the application name to the Excel file I'd like to have it added via my VBA code.
I'm not proficient with Access and have pieced most of this together from searches on how to complete. This "works" but when I run it on larger batches I receive an error "Run-time error '3035': System resource exceeded.' When I remove the section that adds the file name (loop records) it runs fine. I think it's because the steps aren't ordered efficiently? Any help would be appreciated.
Public Function Import_System_Access_Reports()
Dim strFolder As String
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim rstTable As DAO.Recordset
Dim strFile As String
Dim strTable As String
Dim lngPos As Long
Dim strExtension As String
Dim lngFileType As Long
Dim strSQL As String
Dim strFullFileName As String
With Application.FileDialog(4) ' msoFileDialogFolderPicker
If .Show Then
strFolder = .SelectedItems(1)
Else
MsgBox "No folder specified!", vbCritical
Exit Function
End If
End With
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
lngPos = InStrRev(strFile, ".")
strTable = "RawData"
'MsgBox "table is:" & strTable
strExtension = Mid(strFile, lngPos + 1)
Select Case strExtension
Case "xls"
lngFileType = acSpreadsheetTypeExcel9
Case "xlsx", "xlsm"
lngFileType = acSpreadsheetTypeExcel12Xml
Case "xlsb"
lngFileType = acSpreadsheetTypeExcel12
End Select
DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
SpreadsheetType:=lngFileType, _
TableName:=strTable, _
FileName:=strFolder & strFile, _
HasFieldNames:=True ' or False if no headers
'Add and populate the new field
'set the full file name
strFullFileName = strFolder & strFile
'Initialize
Set db = CurrentDb()
Set tdf = db.TableDefs(strTable)
'Add the field to the table.
'tdf.Fields.Append tdf.CreateField("FileName", dbText, 255)
'Create Recordset
Set rstTable = db.OpenRecordset(strTable)
rstTable.MoveFirst
'Loop records
Do Until rstTable.EOF
If (IsNull(rstTable("FileName")) Or rstTable("FileName") = "") Then
rstTable.Edit
rstTable("FileName") = strFile
rstTable.Update
End If
rstTable.MoveNext
Loop
strFile = Dir
'Move to the next file
Loop
'Clean up
Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
'rstTable.Close
Set rstTable = Nothing
End Function
The code is simpler and run-time performance should be much better if you eliminate the Recordset. You can execute an UPDATE after each TransferSpreadsheet
Dim strFolder As String
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strFile As String
Dim strTable As String
Dim strExtension As String
Dim lngFileType As Long
Dim strSQL As String
Dim strFullFileName As String
Dim varPieces As Variant
' --------------------------------------------------------
'* I left out the part where the user selects strFolder *'
' --------------------------------------------------------
strTable = "RawData" '<- this could be a constant instead of a variable
Set db = CurrentDb()
' make the UPDATE a parameter query ...
strSQL = "UPDATE [" & strTable & "] SET FileName=[pFileName]" & vbCrLf & _
"WHERE FileName Is Null OR FileName='';"
Set qdf = db.CreateQueryDef(vbNullString, strSQL)
strFile = Dir(strFolder & "*.xls*")
Do While Len(strFile) > 0
varPieces = Split(strFile, ".")
strExtension = varPieces(UBound(varPieces))
Select Case strExtension
Case "xls"
lngFileType = acSpreadsheetTypeExcel9
Case "xlsx", "xlsm"
lngFileType = acSpreadsheetTypeExcel12Xml
Case "xlsb"
lngFileType = acSpreadsheetTypeExcel12
End Select
strFullFileName = strFolder & strFile
DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
SpreadsheetType:=lngFileType, _
TableName:=strTable, _
FileName:=strFullFileName, _
HasFieldNames:=True ' or False if no headers
' supply the parameter value for the UPDATE and execute it ...
qdf.Parameters("pFileName").Value = strFile
qdf.Execute dbFailOnError
'Move to the next file
strFile = Dir
Loop

Resources