C
C Hayes
I currently have a piece of vba that exports information from an Excel
spreadsheet into an Access db. It's complex, places info in different tables
as neccessary, loops through each record of the spreadsheet, checks for
duplicates, etcetera.
This all occurs in Excel, I want to have this all happen in Access. My goal
is to have a pop up file locator, locate the sheet to import and then do the
work in Access.
I've encluded the vba to show you what is occuring:
Private Sub FirstGiving()
Dim rsID As Long
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsDonors As DAO.Recordset
Dim rsAddresses As DAO.Recordset
Dim rsContributions As DAO.Recordset
Dim rsIdentities As DAO.Recordset
Dim strSQL As String
Dim blnFound As Boolean
' strings for data on spreadsheet
Dim strName As String
Dim strWholeAddress As String
Dim strEmail As String
' strings for database
Dim strFirstName As String
Dim strMiddleName As String
Dim strLastName As String
Dim strAddress As String
Dim strCity As String
Dim strState As String
Dim strZip As String
' email address can go just as it is on the spreadsheet
' variables for contribution
Dim strCode As String
Dim lngKey As Long
Dim strDescription As String
Dim strCaptain As String
Dim strContributionDate As String
Dim dtContributionDate As Date
Dim curAmount As Currency
Dim lngGLCode As Long
Dim strGLCode As String
Const strCheck As String = "CC"
Dim strYear As String
Dim strBatch As String
strContributionDate = Range("A3")
strContributionDate = Right(strContributionDate, Len(strContributionDate) -
15)
strDescription = InputBox("Which Walk is this for?", "Which Walk?",
"Nashville")
strDescription = strDescription & " Walk - "
'capture the GL Code from the user
Do While lngGLCode = 0
strGLCode = InputBox("Please enter the proper GL Code" & vbCrLf & _
"55100 for Nashville" & vbCrLf & _
"55200 for Murfreesboro" & vbCrLf & _
"55300 for Clarksville" & vbCrLf & _
"55400 for Columbia" & vbCrLf & _
"55500 for Hendersonville" & vbCrLf & _
"51200 for Transplant Games", "Select GL Code")
lngGLCode = Val(strGLCode)
If lngGLCode = 0 Then
MsgBox "You entered an invalid GL Code" & vbCrLf & _
"Please try again.", vbOKOnly
End If
Loop
strBatch = CheckBatch(strContributionDate)
dtContributionDate = FormatDateTime(strContributionDate, vbShortDate)
'integers for calculating the first and second space in a name
Dim intFS As Integer
Dim intSS As Integer
'start the loop through the records on the sheet
Dim i As Integer
'initiate i as the first record on a normal firstgiving report (the fifth row)
i = 5
Set db = OpenDatabase("C:\Contributions_FrontEnd.mdb")
Do
'name = the 'f' column and the row number
strName = Range("H" & i)
If strName = "" Then Exit Do
'break the name apart
'calculate first and second space location
intFS = InStr(1, strName, " ") - 1
intSS = InStr(intFS + 2, strName, " ")
strFirstName = Left(strName, intFS)
If intSS <> 0 Then
strLastName = Trim(Right(strName, Len(strName) - (intSS)))
Else
strLastName = Trim(Right(strName, Len(strName) - (intFS)))
End If
'if there is a second space there is a middle initial, capture the middle
initial
If intSS <> 0 Then
strMiddleName = Mid(strName, intFS + 2, 1)
End If
'address = the 'G' column and the row number
strWholeAddress = Trim(Range("I" & i))
intFS = InStr(1, strWholeAddress, " ")
If intFS = 0 Then
strWholeAddress = InputBox("I need help telling the difference" & vbCrLf & _
"between the ADDRESS LINE and the CITY STATE ZIP" & vbCrLf & vbCrLf & _
"Please add extra spaces (2 or 3)" & _
vbCrLf & _
"between the ADDRESS LINE and the CITY STATE ZIP", _
"Add spaces to help delimit", strWholeAddress)
intFS = InStr(1, strWholeAddress, " ")
End If
'capture the first address line and then eliminate it from strWholeAddress
strAddress = Left(strWholeAddress, intFS)
strWholeAddress = Trim(Right(strWholeAddress, (Len(strWholeAddress) - intFS)))
'capture the City
strCity = Left(strWholeAddress, Len(strWholeAddress) - 9)
'capture the state and zip
strZip = Right(strWholeAddress, 5)
strState = Mid(strWholeAddress, Len(strWholeAddress) - 7, 2)
'capture email
strEmail = Range("J" & i)
'check for duplicate entries in database
'create a sql string that pulls identical records
strSQL = "SELECT * " & _
"FROM qryDonorAddresses " & _
"WHERE LastName Like '" & Left(strLastName, 3) & "*' " & _
"AND Address1 Like '" & Left(strAddress, 5) & "*'"
'set the recordset to such
Set rs = db.OpenRecordset(strSQL)
Set rsDonors = db.OpenRecordset("tblDonors")
Set rsAddresses = db.OpenRecordset("tblAddresses")
'loop through the records (if there are any) and inform the user
Do Until rs.EOF
'if the address is obviously the same (10 characters) then don't inform the
user
If Left(strAddress, 10) = Left(rs.Fields("Address1"), 10) Then
blnFound = True
rsID = rs![tblDonors.DonorID]
Exit Do
End If
If MsgBox("This record exists:" & vbCrLf & _
rs.Fields("FirstName") & " " & rs.Fields("LastName") & vbCrLf & _
rs.Fields("Address1") & vbCrLf & vbCrLf & _
"Your Record is:" & vbCrLf & _
strFirstName & " " & strLastName & vbCrLf & _
strAddress & vbCrLf & vbCrLf & _
"Is this the same person?", vbYesNo + vbQuestion) = vbYes Then
'if a record IS found then update the email ONLY
'if blnFound is true then the AddNew will not occur
blnFound = True
rs.Edit
rs!Emailaddress = strEmail
rs.Update
Exit Do
End If
rs.MoveNext
Loop
Debug.Print i
Debug.Print strFirstName
Debug.Print strMiddleName
Debug.Print strLastName
Debug.Print strAddress
Debug.Print strCity
Debug.Print strState
Debug.Print strZip
Debug.Print strEmail
'if no record was found then add the record to the db
If blnFound = False Then
With rsDonors
.AddNew
rsDonors!FirstName = strFirstName
rsDonors!LastName = strLastName
rsDonors!MiddleName = strMiddleName
rsDonors!Emailaddress = strEmail
.Update
End With
rsDonors.Bookmark = rsDonors.LastModified
rsID = rsDonors!DonorID
With rsAddresses
.AddNew
rsAddresses!DonorID = rsID
rsAddresses!Address1 = strAddress
rsAddresses!City = strCity
rsAddresses!State = strState
rsAddresses!Zip = strZip
.Update
End With
End If
'add the contribution record to the db
strDescription = strDescription & Range("D" & i)
strDescription = Left(strDescription, Len(strDescription) - 7)
lngKey = rsID
strSQL = "SELECT * FROM tblContributions"
Set rsContributions = db.OpenRecordset(strSQL)
With rsContributions
.AddNew
rsContributions!DonorID = lngKey
rsContributions!Date = dtContributionDate
rsContributions!Description = strDescription
rsContributions!Amount = Range("L" & i)
rsContributions!GLCode = lngGLCode
rsContributions!Batch = strBatch
rsContributions!CheckNumber = strCheck
rsContributions!EventYear = Right(strContributionDate, 4)
.Update
End With
rsContributions.Bookmark = rsContributions.LastModified
rsID = rsContributions!ContributionID
Select Case lngGLCode
Case 55100, 55200, 55300, 55400, 55500
strCode = "WLK-SPONS"
Case 51200
strCode = "TRANSPLANT"
End Select
Set rsIdentities = db.OpenRecordset("tblContributionIdentities")
With rsIdentities
.AddNew
rsIdentities!ContributionID = rsID
rsIdentities!ContributionCode = strCode
.Update
End With
'reset description string
intFS = InStr(1, strDescription, "-")
intFS = Len(strDescription) - intFS
strDescription = Left(strDescription, Len(strDescription) - intFS + 1)
'zero out capture strings
strName = ""
strWholeAddress = ""
'blnFound to false RESET
blnFound = False
'increment to next row
i = i + 1
Loop
'zero out db variables
Set db = Nothing
Set rs = Nothing
Set rsDonors = Nothing
Set rsAddresses = Nothing
Set rsContributions = Nothing
Set rsIdentities = Nothing
End Sub
Private Function CheckBatch(strCD As String) As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
'Used for checking on open batch numbers
'date for filtering SQL
Dim dtCheckDate As Date
'making date a string for SQL
dtCheckDate = FormatDateTime(strCD, vbShortDate)
'SQL for recordset
Dim strSQL As String
strSQL = "SELECT tblContributions.Batch, " & _
"tblContributions.Date " & _
"FROM tblContributions GROUP BY tblContributions.Batch, " & _
"tblContributions.Date " & _
"HAVING tblContributions.Date = " & Chr(35) & _
dtCheckDate & Chr(35) & " ORDER BY tblContributions.Batch;"
'record set variable
Set db = OpenDatabase("C:\Contributions_FrontEnd.mdb")
Set rs = db.OpenRecordset(strSQL)
'create a batch date style date MMDDYY
Dim strBDMonth As String
Dim strBDDay As String
Dim strBDYear As String
strBDYear = Right(strCD, 2)
Dim intFM As Integer
Dim intSM As Integer
intFM = InStr(1, strCD, "/")
intSM = InStr(intFM + 1, strCD, "/")
If intFM = 2 Then
strBDMonth = "0" & Left(strCD, 1)
Else
strBDMonth = Left(strCD, 2)
End If
If (intFM - intSM) = 2 Then
strBDDay = "0" & Mid(strCD, intFM + 1, 1)
Else
strBDDay = Mid(strCD, intFM + 1, 2)
End If
'check for records
'if none than let the user know and kick out of code
If rs.EOF Then
CheckBatch = "FG" & strBDMonth & _
strBDDay & strBDYear & "01"
Set db = Nothing
Set rs = Nothing
Exit Function
End If
'if there are records, loop through and build the correct/highest sequence
Dim strSequence As String
Do While Not rs.EOF
If Val(Right(rs.Fields(0), 1)) > Val(strSequence) Then
strSequence = Val(Right(rs.Fields(0), 1))
rs.MoveNext
Else
rs.MoveNext
End If
Loop
CheckBatch = "FG" & strBDMonth & _
strBDDay & strBDYear & "0" & Val(strSequence) + 1
Set db = Nothing
Set rs = Nothing
End Function
spreadsheet into an Access db. It's complex, places info in different tables
as neccessary, loops through each record of the spreadsheet, checks for
duplicates, etcetera.
This all occurs in Excel, I want to have this all happen in Access. My goal
is to have a pop up file locator, locate the sheet to import and then do the
work in Access.
I've encluded the vba to show you what is occuring:
Private Sub FirstGiving()
Dim rsID As Long
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsDonors As DAO.Recordset
Dim rsAddresses As DAO.Recordset
Dim rsContributions As DAO.Recordset
Dim rsIdentities As DAO.Recordset
Dim strSQL As String
Dim blnFound As Boolean
' strings for data on spreadsheet
Dim strName As String
Dim strWholeAddress As String
Dim strEmail As String
' strings for database
Dim strFirstName As String
Dim strMiddleName As String
Dim strLastName As String
Dim strAddress As String
Dim strCity As String
Dim strState As String
Dim strZip As String
' email address can go just as it is on the spreadsheet
' variables for contribution
Dim strCode As String
Dim lngKey As Long
Dim strDescription As String
Dim strCaptain As String
Dim strContributionDate As String
Dim dtContributionDate As Date
Dim curAmount As Currency
Dim lngGLCode As Long
Dim strGLCode As String
Const strCheck As String = "CC"
Dim strYear As String
Dim strBatch As String
strContributionDate = Range("A3")
strContributionDate = Right(strContributionDate, Len(strContributionDate) -
15)
strDescription = InputBox("Which Walk is this for?", "Which Walk?",
"Nashville")
strDescription = strDescription & " Walk - "
'capture the GL Code from the user
Do While lngGLCode = 0
strGLCode = InputBox("Please enter the proper GL Code" & vbCrLf & _
"55100 for Nashville" & vbCrLf & _
"55200 for Murfreesboro" & vbCrLf & _
"55300 for Clarksville" & vbCrLf & _
"55400 for Columbia" & vbCrLf & _
"55500 for Hendersonville" & vbCrLf & _
"51200 for Transplant Games", "Select GL Code")
lngGLCode = Val(strGLCode)
If lngGLCode = 0 Then
MsgBox "You entered an invalid GL Code" & vbCrLf & _
"Please try again.", vbOKOnly
End If
Loop
strBatch = CheckBatch(strContributionDate)
dtContributionDate = FormatDateTime(strContributionDate, vbShortDate)
'integers for calculating the first and second space in a name
Dim intFS As Integer
Dim intSS As Integer
'start the loop through the records on the sheet
Dim i As Integer
'initiate i as the first record on a normal firstgiving report (the fifth row)
i = 5
Set db = OpenDatabase("C:\Contributions_FrontEnd.mdb")
Do
'name = the 'f' column and the row number
strName = Range("H" & i)
If strName = "" Then Exit Do
'break the name apart
'calculate first and second space location
intFS = InStr(1, strName, " ") - 1
intSS = InStr(intFS + 2, strName, " ")
strFirstName = Left(strName, intFS)
If intSS <> 0 Then
strLastName = Trim(Right(strName, Len(strName) - (intSS)))
Else
strLastName = Trim(Right(strName, Len(strName) - (intFS)))
End If
'if there is a second space there is a middle initial, capture the middle
initial
If intSS <> 0 Then
strMiddleName = Mid(strName, intFS + 2, 1)
End If
'address = the 'G' column and the row number
strWholeAddress = Trim(Range("I" & i))
intFS = InStr(1, strWholeAddress, " ")
If intFS = 0 Then
strWholeAddress = InputBox("I need help telling the difference" & vbCrLf & _
"between the ADDRESS LINE and the CITY STATE ZIP" & vbCrLf & vbCrLf & _
"Please add extra spaces (2 or 3)" & _
vbCrLf & _
"between the ADDRESS LINE and the CITY STATE ZIP", _
"Add spaces to help delimit", strWholeAddress)
intFS = InStr(1, strWholeAddress, " ")
End If
'capture the first address line and then eliminate it from strWholeAddress
strAddress = Left(strWholeAddress, intFS)
strWholeAddress = Trim(Right(strWholeAddress, (Len(strWholeAddress) - intFS)))
'capture the City
strCity = Left(strWholeAddress, Len(strWholeAddress) - 9)
'capture the state and zip
strZip = Right(strWholeAddress, 5)
strState = Mid(strWholeAddress, Len(strWholeAddress) - 7, 2)
'capture email
strEmail = Range("J" & i)
'check for duplicate entries in database
'create a sql string that pulls identical records
strSQL = "SELECT * " & _
"FROM qryDonorAddresses " & _
"WHERE LastName Like '" & Left(strLastName, 3) & "*' " & _
"AND Address1 Like '" & Left(strAddress, 5) & "*'"
'set the recordset to such
Set rs = db.OpenRecordset(strSQL)
Set rsDonors = db.OpenRecordset("tblDonors")
Set rsAddresses = db.OpenRecordset("tblAddresses")
'loop through the records (if there are any) and inform the user
Do Until rs.EOF
'if the address is obviously the same (10 characters) then don't inform the
user
If Left(strAddress, 10) = Left(rs.Fields("Address1"), 10) Then
blnFound = True
rsID = rs![tblDonors.DonorID]
Exit Do
End If
If MsgBox("This record exists:" & vbCrLf & _
rs.Fields("FirstName") & " " & rs.Fields("LastName") & vbCrLf & _
rs.Fields("Address1") & vbCrLf & vbCrLf & _
"Your Record is:" & vbCrLf & _
strFirstName & " " & strLastName & vbCrLf & _
strAddress & vbCrLf & vbCrLf & _
"Is this the same person?", vbYesNo + vbQuestion) = vbYes Then
'if a record IS found then update the email ONLY
'if blnFound is true then the AddNew will not occur
blnFound = True
rs.Edit
rs!Emailaddress = strEmail
rs.Update
Exit Do
End If
rs.MoveNext
Loop
Debug.Print i
Debug.Print strFirstName
Debug.Print strMiddleName
Debug.Print strLastName
Debug.Print strAddress
Debug.Print strCity
Debug.Print strState
Debug.Print strZip
Debug.Print strEmail
'if no record was found then add the record to the db
If blnFound = False Then
With rsDonors
.AddNew
rsDonors!FirstName = strFirstName
rsDonors!LastName = strLastName
rsDonors!MiddleName = strMiddleName
rsDonors!Emailaddress = strEmail
.Update
End With
rsDonors.Bookmark = rsDonors.LastModified
rsID = rsDonors!DonorID
With rsAddresses
.AddNew
rsAddresses!DonorID = rsID
rsAddresses!Address1 = strAddress
rsAddresses!City = strCity
rsAddresses!State = strState
rsAddresses!Zip = strZip
.Update
End With
End If
'add the contribution record to the db
strDescription = strDescription & Range("D" & i)
strDescription = Left(strDescription, Len(strDescription) - 7)
lngKey = rsID
strSQL = "SELECT * FROM tblContributions"
Set rsContributions = db.OpenRecordset(strSQL)
With rsContributions
.AddNew
rsContributions!DonorID = lngKey
rsContributions!Date = dtContributionDate
rsContributions!Description = strDescription
rsContributions!Amount = Range("L" & i)
rsContributions!GLCode = lngGLCode
rsContributions!Batch = strBatch
rsContributions!CheckNumber = strCheck
rsContributions!EventYear = Right(strContributionDate, 4)
.Update
End With
rsContributions.Bookmark = rsContributions.LastModified
rsID = rsContributions!ContributionID
Select Case lngGLCode
Case 55100, 55200, 55300, 55400, 55500
strCode = "WLK-SPONS"
Case 51200
strCode = "TRANSPLANT"
End Select
Set rsIdentities = db.OpenRecordset("tblContributionIdentities")
With rsIdentities
.AddNew
rsIdentities!ContributionID = rsID
rsIdentities!ContributionCode = strCode
.Update
End With
'reset description string
intFS = InStr(1, strDescription, "-")
intFS = Len(strDescription) - intFS
strDescription = Left(strDescription, Len(strDescription) - intFS + 1)
'zero out capture strings
strName = ""
strWholeAddress = ""
'blnFound to false RESET
blnFound = False
'increment to next row
i = i + 1
Loop
'zero out db variables
Set db = Nothing
Set rs = Nothing
Set rsDonors = Nothing
Set rsAddresses = Nothing
Set rsContributions = Nothing
Set rsIdentities = Nothing
End Sub
Private Function CheckBatch(strCD As String) As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
'Used for checking on open batch numbers
'date for filtering SQL
Dim dtCheckDate As Date
'making date a string for SQL
dtCheckDate = FormatDateTime(strCD, vbShortDate)
'SQL for recordset
Dim strSQL As String
strSQL = "SELECT tblContributions.Batch, " & _
"tblContributions.Date " & _
"FROM tblContributions GROUP BY tblContributions.Batch, " & _
"tblContributions.Date " & _
"HAVING tblContributions.Date = " & Chr(35) & _
dtCheckDate & Chr(35) & " ORDER BY tblContributions.Batch;"
'record set variable
Set db = OpenDatabase("C:\Contributions_FrontEnd.mdb")
Set rs = db.OpenRecordset(strSQL)
'create a batch date style date MMDDYY
Dim strBDMonth As String
Dim strBDDay As String
Dim strBDYear As String
strBDYear = Right(strCD, 2)
Dim intFM As Integer
Dim intSM As Integer
intFM = InStr(1, strCD, "/")
intSM = InStr(intFM + 1, strCD, "/")
If intFM = 2 Then
strBDMonth = "0" & Left(strCD, 1)
Else
strBDMonth = Left(strCD, 2)
End If
If (intFM - intSM) = 2 Then
strBDDay = "0" & Mid(strCD, intFM + 1, 1)
Else
strBDDay = Mid(strCD, intFM + 1, 2)
End If
'check for records
'if none than let the user know and kick out of code
If rs.EOF Then
CheckBatch = "FG" & strBDMonth & _
strBDDay & strBDYear & "01"
Set db = Nothing
Set rs = Nothing
Exit Function
End If
'if there are records, loop through and build the correct/highest sequence
Dim strSequence As String
Do While Not rs.EOF
If Val(Right(rs.Fields(0), 1)) > Val(strSequence) Then
strSequence = Val(Right(rs.Fields(0), 1))
rs.MoveNext
Else
rs.MoveNext
End If
Loop
CheckBatch = "FG" & strBDMonth & _
strBDDay & strBDYear & "0" & Val(strSequence) + 1
Set db = Nothing
Set rs = Nothing
End Function