ca1358
asked on
Transfering Text From Excel to Access
Excel VBA
I have this piece of code and it works great, now I need to take and add a field to the txt file before transfering to Access.
I need to copy C2 and put it into A1 of the Text file and then add the rest starting in B2 of the Text file. Is this possible?
Any help would greatly be appreciated!
////////////////////////// ////////// ////////// ////////// /
Private Sub cmdTransferToSRP_Click()
'Copy Data and transfer to New Workbook
Dim rngToCopy As Range
Dim rngToPaste As Range
Dim r
r = Range("E65536").End(xlUp). Row
Range("D25:D" & r).FillDown
‘Add to A1???????
‘C2 to A1
‘Paste this starting in B2
Set rngToCopy = Range("D25:J" & Cells(Rows.Count, "D").End(xlUp).Row)
'Open new workbook to create text file
Workbooks.Add
rngToCopy.Copy
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Sheet3").Select
ActiveWindow.SelectedSheet s.Delete
Sheets("Sheet2").Select
ActiveWindow.SelectedSheet s.Delete
Application.CutCopyMode = False
'Export Text File
ADOFromExcelToAccess
' Turns off "Do you want to replace this file?"
Application.DisplayAlerts = False
'Saves as a text file
ActiveWorkbook.SaveAs Filename:="\\Dtcnas-ilsp00 2\mandator y\Analysts - Working Files\Carol\SRP\SRPTansfer File.txt" _
, FileFormat:=xlText, CreateBackup:=False
ActiveWorkbook.Close
'opens access
OpenAccess
End Sub
'///////////////////////// ////////// ////////// ///
Sub OpenAccess()
Const cDatabaseToOpen = "\\Dtcnas-ilsp002\mandator y\Analysts - Working Files\Carol\SRP\SRPtwo.mdb "
Dim oApp As Object
Dim LPath As String
Dim LCategoryID As Long
'Path to Access database
LPath = "\\Dtcnas-ilsp002\mandator y\Analysts - Working Files\Carol\SRP\SRPtwo.mdb "
'Open Access and make visible
Set oApp = CreateObject("Access.Appli cation")
oApp.Visible = True
'Open Access database as defined by LPath variable and , false, dbpwd for password
oApp.OpenCurrentDatabase LPath, False, False
If oApp.CurrentProject.FullNa me <> "" Then
oApp.UserControl = True
Else
oApp.Quit
MsgBox "Failed to open '" & cDatabaseToOpen & "'."
End If
End Sub
'///////////////////////// ////////// ////////// ////////// ////////// ////////// /
Sub ADOFromExcelToAccess()
'Transfer data to the TransferFile
'///////////////////////// /////
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
' connect to the Access database
Set cn = New ADODB.Connection
'''''''''''''''''''''''''' '''''''''' ''''
'Workgroup Security
cn.Provider = "Microsoft Jet 4.0 OLE DB Provider"
cn.ConnectionString = "\\Dtcnas-ilsp002\mandator y\Analysts - Working Files\Carol\SRP\SRPtwo.mdb "
cn.Properties("Jet OLEDB:System database") = "C:\Program Files\Microsoft Office\system.mdw"
cn.Open
'''''''''''''''''''''''''
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "DATA", cn, adOpenKeyset, adLockOptimistic, adCmdTable
cn.Execute "delete * from DATA"
' all records in a table
r = 25 ' the start row in the worksheet
Do While Len(Range("D" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("CompanyID") = Range("D" & r).Value
.Fields("LoanID") = Range("E" & r).Value
.Fields("ProrptyState") = Range("F" & r).Value
.Fields("LoanAmt") = Range("G" & r).Value
.Fields("NoteDate") = Range("H" & r).Value
.Fields("NoteRate") = Range("I" & r).Value
.Fields("LoanTerm") = Range("J" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
I have this piece of code and it works great, now I need to take and add a field to the txt file before transfering to Access.
I need to copy C2 and put it into A1 of the Text file and then add the rest starting in B2 of the Text file. Is this possible?
Any help would greatly be appreciated!
//////////////////////////
Private Sub cmdTransferToSRP_Click()
'Copy Data and transfer to New Workbook
Dim rngToCopy As Range
Dim rngToPaste As Range
Dim r
r = Range("E65536").End(xlUp).
Range("D25:D" & r).FillDown
‘Add to A1???????
‘C2 to A1
‘Paste this starting in B2
Set rngToCopy = Range("D25:J" & Cells(Rows.Count, "D").End(xlUp).Row)
'Open new workbook to create text file
Workbooks.Add
rngToCopy.Copy
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Sheet3").Select
ActiveWindow.SelectedSheet
Sheets("Sheet2").Select
ActiveWindow.SelectedSheet
Application.CutCopyMode = False
'Export Text File
ADOFromExcelToAccess
' Turns off "Do you want to replace this file?"
Application.DisplayAlerts = False
'Saves as a text file
ActiveWorkbook.SaveAs Filename:="\\Dtcnas-ilsp00
, FileFormat:=xlText, CreateBackup:=False
ActiveWorkbook.Close
'opens access
OpenAccess
End Sub
'/////////////////////////
Sub OpenAccess()
Const cDatabaseToOpen = "\\Dtcnas-ilsp002\mandator
Dim oApp As Object
Dim LPath As String
Dim LCategoryID As Long
'Path to Access database
LPath = "\\Dtcnas-ilsp002\mandator
'Open Access and make visible
Set oApp = CreateObject("Access.Appli
oApp.Visible = True
'Open Access database as defined by LPath variable and , false, dbpwd for password
oApp.OpenCurrentDatabase LPath, False, False
If oApp.CurrentProject.FullNa
oApp.UserControl = True
Else
oApp.Quit
MsgBox "Failed to open '" & cDatabaseToOpen & "'."
End If
End Sub
'/////////////////////////
Sub ADOFromExcelToAccess()
'Transfer data to the TransferFile
'/////////////////////////
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
' connect to the Access database
Set cn = New ADODB.Connection
''''''''''''''''''''''''''
'Workgroup Security
cn.Provider = "Microsoft Jet 4.0 OLE DB Provider"
cn.ConnectionString = "\\Dtcnas-ilsp002\mandator
cn.Properties("Jet OLEDB:System database") = "C:\Program Files\Microsoft Office\system.mdw"
cn.Open
'''''''''''''''''''''''''
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "DATA", cn, adOpenKeyset, adLockOptimistic, adCmdTable
cn.Execute "delete * from DATA"
' all records in a table
r = 25 ' the start row in the worksheet
Do While Len(Range("D" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("CompanyID") = Range("D" & r).Value
.Fields("LoanID") = Range("E" & r).Value
.Fields("ProrptyState") = Range("F" & r).Value
.Fields("LoanAmt") = Range("G" & r).Value
.Fields("NoteDate") = Range("H" & r).Value
.Fields("NoteRate") = Range("I" & r).Value
.Fields("LoanTerm") = Range("J" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER