Exporting data from excel to access-VBA - vba

I am trying to upload a dataset from excel to an access database using the following code.
However i keep getting the Run time error 3078- Application defined or object defined error. i am using the dao for this and have added the follwing references:
Microsoft office 16.0 access database engine object library,
Microsoft access 16.0 library.
i am unable to add the Microsoft DAO 3.6 object library (Name conflicts with existing module, project or object libary
here is the code:
Sub access_upload()
Dim strMyPath As String, strDBName As String, strDB As String
Dim i As Long, n As Long, lLastRow As Long, lFieldCount As Long
Dim daoDB As DAO.Database
Dim recSet As DAO.Recordset
strDBName = "Database8.accdb"
'presume to be in the same location as the host workbook:
strMyPath = ThisWorkbook.Path
strDB = strMyPath & "\" & strDBName
Set daoDB = DBEngine.Workspaces(0).OpenDatabase(strDB)
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet2")
Set recSet = daoDB.OpenRecordset("Database8")
lFieldCount = recSet.Fields.Count
lLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lLastRow
recSet.AddNew
For n = 0 To lFieldCount - 1
recSet.Fields(n).Value = ws.Cells(i, n + 1)
Next n
recSet.Update
Next i
recSet.Close
daoDB.Close
Set daoDB = Nothing
Set recSet = Nothing
End Sub
Please let me know what i am missing here. Thanks!


From Excel to Access . . .
Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
Dim blnHasFieldNames As Boolean
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = False
' Replace C:\Documents\ with the real path to the folder that
' contains the EXCEL files
strPath = "C:\Documents\"
' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "tablename"
strFile = Dir(strPath & "*.xls")
Do While Len(strFile) > 0
strPathFile = strPath & strFile
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strTable, strPathFile, blnHasFieldNames
' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile
strFile = Dir()
Loop


also if the path and excel name are fixed; you can step thru the import manually using the External features from the ribbon - at the end of which will be a prompt to save those steps as a defined import.
you can then rerun the import just by a docmd to run the saved import

Related

The command or action 'TransferText' isn't available now

I've a bunch of folders with one .accdb DB in each folder. I want to export a number of tables from them to delimited text. The tables are specified in the array arr.
Sub ExtractDBs(tableList as String)
Dim objAccess As Access.Application
Dim db As DAO.Database
Dim fp As String
Dim fso As Object
Dim fsoFolder As Object, fsoSubFolder As Object, fsoFolders As Object
Dim fsoFiles As Object, fsoFile As Object
Dim x As Integer
Dim txtStream As Object
Dim arr() as string
Set objAccess = New Access.Application
arr = Split(tableList, ";")
fp = "\\SomeFilePath"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fsoFolder = fso.GetFolder(fp)
Set fsoFolders = fsoFolder.SubFolders
For Each fsoSubFolder In fsoFolders
Set fsoFiles = fsoSubFolder.Files
For Each fsoFile In fsoFiles
Set db = objAccess.DBEngine.OpenDatabase(fsoFile.Path, False, True, ";PWD=SomePassword")
For x = 0 To UBound(arr) - 1
objAccess.DoCmd.TransferText acImportDelim, TableName:=arr(x), _
Filename:=fp & "\" & Replace(fsoFile.Name, ".accdb", "") & "\" & arr(x) & ".txt", _
HasFieldNames:=True
Next x
db.Close
Next fsoFile
Next fsoSubFolder
objAccess.Quit
Set objAccess = Nothing
End Sub
The line beginning objAccess.DoCmd.TransferText yields the error
The command or action 'TransferText' isn't available now.
...Which is pretty useless. I can't find an explanation online of what is required to resolve this error.

You haven't actually opened any database.
Application.OpenCurrentDatabase opens a database in the current Access application.
Application.DbEngine.OpenDatabase opens a database using the database engine of the current Access application, but doesn't actually open it in the application.
So, use the following:
objAccess.OpenCurrentDatabase fsoFile.Path, False, "SomePassword"

Excel VBA open workbook with part of its name

I want to open, using VBA, a workbook from a certain path that includes a number, for example 2. Any variation I tried is not working.
The name of the workbook is in Hebrew except for the number, so I want the VBA code to base the file name on the number to open the file.
I have 4 letters in hebrew before the number. In Hebrew we write from right to left.
Here is my code:
Set WB1 = Workbooks.Open("C:\RESULTS\" 2 & ".xlsx")
Thanks for helping.

Try this
Dim sFound As String, fPath As String
fPath = "C:\RESULTS\"
sFound = Dir(fPath & "*2*.xlsx") 'get the first file in dir
If sFound <> "" Then
Set WB1 = Workbooks.Open(fPath & sFound)
End If

This works for me:
Option Explicit
Sub TestMe()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim wbs As Workbook
Dim strExtension As String
Dim lngNumber As String
Dim lngAdditional As Long
Dim lngLenFile As Long
strExtension = ".xlsx"
lngNumber = 20
lngAdditional = 4
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\Desktop\")
lngLenFile = Len(strExtension) + Len(lngNumber) + lngAdditional
For Each objFile In objFolder.Files
If Left(objFile.Name, Len(lngNumber)) = lngNumber And _
Right(objFile, Len(strExtension)) = strExtension And _
Len(objFile.Name) = lngLenFile Then
Debug.Print objFile.Name
Set wbs = Workbooks.Open(objFile)
End If
Next objFile
End Sub
The idea of the code is to make it flexible, thus, lngNumber and strExtension are added. It checks always for the size, as well as for right and left. Thus 24Some.xlsx would be different than 2Some.xlsx.
Debug.Print is added to see the file that is opened.
lngAdditional is added, for the additional 4 chars.

Excel VBA - movefile syntax

Please help with the code for copying files one by one to the destination folder. I tried with "for Each loop but it is copying all the files at once to the destination folder. I am new to to vba and would be helpful if someone could crack the code for me. thanks in advance. here's the code i have managed to come up with.
I am getting run time error 53, File not found,e highlighting the below syntax.
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Sub Example1()
'Extracting file names Dim objFSO As Object Dim objFolder As Object Dim newobjFile As Object
Dim lastID As Long Dim myRRange As Range Dim Maxvalue As Integer
Dim sFolder As String Dim dFolder As String
Sub Example1()
'Extracting file names
Dim FSO
Dim objFolder As Object
Dim newobjFile As Object
Dim FromDir As String
Dim ToDir As String
Dim lastID As Long
Dim myRRange As Range
Dim Maxvalue As Integer
Dim Fname As String
FromDir = "C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\"
ToDir = "C:\Users\wazeer.ahamed\Documents\TcktIDfolder\"
Fname = Dir(FromDir)
If Len(FromDir) = 0 Then
MsgBox "No files"
Exit Sub
End If
Set myRange = Worksheets("Sheet1").Range("C:C")
Maxvalue = Application.WorksheetFunction.Max(myRange)
lastID = Maxvalue
'finding the next availabe row
erow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Extracting file names
'Create an instance of the FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = FSO.GetFolder("C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro")
'loops through each file in the directory and prints their names and path
For Each newobjFile In objFolder.Files
'print file name
Cells(erow, 1) = Fname
'print file path
Cells(erow, 2) = newobjFile.Path
'PrintUniqueID
Cells(erow, 3) = lastID + 1
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Cells(erow, 5) = "file succesfully copied"
Next newobjFile
Set FSO = Nothing
Set newobjFile = Nothing
Set objFolder = Nothing
End Sub

I think that the code can be more simple and dynamic if you play with your own excel file.
Use "A1" range to put the source folder.
Use "B:B" range to put the
name of the files.
Use "C:C" range to concatenate the previous
columns.
Use "D1" range to put the destination folder.
Sub copyFiles()
'Macro for copy files
'Set variable
Dim source As String
Dim destination As String
Dim x As Integer
Dim destinationNumber As Integer
destinationNumber = WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet1").Range("C:C"))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Create the folder if not exist
If Dir(ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1"), 16) = "" Then
MkDir ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1")
End If
'Run the loop to copy all the files
For x = 1 To destinationNumber
source = ThisWorkbook.Sheets("Sheet1").Range("C" & x)
destination = ThisWorkbook.Sheets("Sheet1").Range("D1")
FileCopy source, destination
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
With this you can change the folders' paths and file names whenever you want. I've used FileCopy to preserve your files in the source but if you need to delete it's better use other method.

reading and writing a csv file using FileSystemObject

Is it possible to read and write csv files using FileSystemObject in VBA?

It certainly is.
Basic syntax such as
Set objFSO = CreateObject("scripting.filesystemobject")
'create a csv file
Set objTF = objFSO.createtextfile("C:\test\myfile.csv", True, False)
'open an existing csv file with writing ability
Set objTF = objFSO.OpenTextFile("C:\test\myfile.csv", 8)
will create/open a CSV with FSO.
The CSV can then be modified by writing to it
While this is an Excel example you can use the same technique to write records from Outlook, Access, Word etc
Const sFilePath = "C:\test\myfile.csv"
Const strDelim = ","
Sub CreateCSV_FSO()
Dim objFSO
Dim objTF
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim strTmp As String
Dim lFnum As Long
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile(sFilePath, True, False)
For Each ws In ActiveWorkbook.Worksheets
'test that sheet has been used
Set rng1 = ws.UsedRange
If Not rng1 Is Nothing Then
'only multi-cell ranges can be written to a 2D array
If rng1.Cells.Count > 1 Then
X = ws.UsedRange.Value2
'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column
For lCol = 1 To UBound(X, 2)
'write initial value outside the loop
strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol))
For lRow = 2 To UBound(X, 1)
'concatenate long string & (short string with short string)
strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol)))
Next lRow
'write each line to CSV
objTF.writeline strTmp
Next lCol
Else
objTF.writeline IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value)
End If
End If
Next ws
objTF.Close
Set objFSO = Nothing
MsgBox "Done!", vbOKOnly
End Sub

It seems possible.
The FileSystemObject (FSO) provides an API to access the Windows filesystem, providing access to files, drives, text streams etc. The FSO is embedded within the Microsoft Scripting run-time, and is available to stand-alone applications (coded using Visual Basic, for example), to web page designers using VBScript or JScript and to users of Microsoft Office applications using Visual Basic for Applications (VBA).
Some references:-
Using The FileSystemObject With VB and VBA
How do I use FileSystemObject in VBA?

how to load a sectioned CSV file to an excel sheet?

CSV file:
#3GMACRO,,,,,,,,,,,,,,
,,,,,,,,,,,,,,
IMSI,IMEI,Date,Time,UMTS MACRO-UARFCNDL,UMTS MACRO-PrimaryScramblingCode,UMTS MACRO-CPICHTxPower,UMTS MACRO-PLMNCellId,UMTS MACRO- RNCId,UMTS MACRO-MCC,UMTS MACRO-MNC,UMTS MACRO - LAC,UMTS MACRO - RAC,UMTS MACRO - MaxUETxPower,UMTS MACRO - MeasuredRSCP
2.6275E+14,3.57539E+14,20100107,160000,10662,11,-99,268435456,0,0,0,1,0,0,-74
,,,,,,,,,,,,,,
#3GFEMTO,,,,,,,,,,,,,,
,,,,,,,,,,,,,,
IMSI,IMEI,Date,Time,UMTS FEMTOS-UARFCNDL,UMTS FEMTOS-PrimaryScramblingCode,UMTS FEMTOS-CPICHTxPower,UMTS FEMTOS-PLMNCellId,UMTS FEMTOS-RNCId,UMTS FEMTOS-MCC,UMTS FEMTOS-MNC,UMTS FEMTOS-LAC,UMTS FEMTOS-RAC,UMTS FEMTOS-MaxUETxPower,UMTS FEMTOS- MeasuredRSCP
2.6275E+14,3.57539E+14,20100107,160000,10687,252,-24,61,0,610,3956,486,11,5,-102
,,,,,,,,,,,,,,
#2GMACRO,,,,,,,,,,,,,,
,,,,,,,,,,,,,,
IMSI,IMEI,Date,Time,GSM MACRO_CellID,GSM MACRO-MCC,GSM MACRO-MNC,GSM MACRO-LAC,GSM MACRO-RAC,GSM MACRO-Max permitted UE Tx power (SIB3),GSM MACRO-Measure RSSI,,,,
2.6275E+14,3.57539E+14,20100107,160000,GSM_Cell_Id=1,2,3,4,5,6,7,,,,
i want this csv file to be loaded into an excel sheet as an individual section when I click load only once (ie each section should go to separate worksheet in excel)
CSV file contain Section name , header and data
Below are the section names in CSv file
3GMACRO
3GFEMTO
2GMACRO
Below are the Header names in CSv file
IMSI,IMEI,Date,Time,GSM MACRO_CellID,GSM MACRO-MCC,GSM MACRO-MNC............ etc
3 worksheets should have headers and data after loading CSV file.
Please help me in doing so.
Thanks in advance
hi
this is what the code i tried but its not working perfectly as needed.
Sub loadData()
'Runtime error handling
'On Error Resume Next
'Unprotect the password protected sheet for loading csv data
ActiveSheet.Unprotect Password:=pass
'Variable declaration
Dim strFilePath As String, strFilename As String, strFullPath As String
Dim lngCounter As Long
Dim oConn As Object, oRS As Object, oFSObj As Object
'Get a text file name
strFullPath = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...")
'MsgBox "stringfullpath" & strFullPath
If strFullPath = "False" Then Exit Sub 'User pressed Cancel on the open file dialog
'This gives us a full path name e.g. C:tempfolderfile.txt
'We need to split this into path and file name
Set oFSObj = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
strFilePath = oFSObj.GetFile(strFullPath).ParentFolder.Path
strFilename = oFSObj.GetFile(strFullPath).Name
'Open an ADO connection to the folder specified
Set oConn = CreateObject("ADODB.CONNECTION")
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strFilePath & ";" & _
"Extended Properties=""text;HDR=Yes;FMT=Delimited"""
Set oRS = CreateObject("ADODB.RECORDSET")
'Now actually open the text file and import into Excel
'oRS.Open "SELECT * FROM " & strFilename & " , oConn"
oRS.Open "SELECT * FROM " & strFilename, oConn
While Not oRS.EOF
Sheets("Neighbour3GMacro").Range("A3").CopyFromRecordset oRS
'Sheets.Add Type:=Application.GetOpenFilename & " *.csv"
Sheets("Neighbour3GFemto").Range("A2").CopyFromRecordset oRS
Sheets("Neighbour2GMacro").Range("A2").CopyFromRecordset oRS
Wend
oRS.Close
oConn.Close
End Sub

You can use the Split function to get an array and use this array to fill a Row. Here is a simple solution.
You will need to change Sheet1, Sheet2, Sheet3 to your worksheet-names and might want to add functionality to ignore header lines. If you have a fix ColumnCount you can also replace the Ubound function with an integer variable.
Sub loadData2()
Dim strFullPath As String
Dim oFSOBj As Object 'Scripting.FileSystemObject'
Dim oFileStream As Object 'Scripting.TextStream'
Dim targetSheet As Worksheet
Dim iRow As Long
Dim startRow As Long
Dim startColumn As Integer
Dim line As String
'Please insert Error Handling etc.'
'Get a text file name '
strFullPath = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...")
If strFullPath = "False" Then Exit Sub 'User pressed Cancel on the open file dialog'
Set oFSOBj = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
Set oFileStream = oFSOBj.GetFile(strFullPath).OpenAsTextStream(ForReading)
Set targetSheet = Sheet1
iRow = 0
startRow = 3
startColumn = 1
While (Not oFileStream.AtEndOfStream)
line = oFileStream.ReadLine
If (Left(line, 1) = "#") Then
iRow = 0
If (Left(line, 8) = "#3GMACRO") Then Set targetSheet = Sheet1
If (Left(line, 8) = "#3GFEMTO") Then Set targetSheet = Sheet2
If (Left(line, 8) = "#2GMACRO") Then Set targetSheet = Sheet3
ElseIf Trim(line) <> vbNullString Then 'Else Block: line has content'
csline = Split(line, ",")
targetSheet.Range(targetSheet.Cells(startRow + iRow, startColumn), targetSheet.Cells(startRow + iRow, startColumn + UBound(csline))).Value2 = csline
iRow = iRow + 1
End If
Wend
oFileStream.Close
Set oFileStream = Nothing
Set oFSOBj = Nothing
End Sub