So, thanks to all the great insight on this board I have gone from a complete access newbie to having pieced together what could be a pretty great database to track our quality scores... While the macro I have put together works in pieces, when I try to run the full 18 loops that are needed it starts giving me virtual memory errors, and something about an excel OLE object already in use. I thought I heeded the warnings about closing everything I open but I just can't find my problem.
Oh, in addition to the virtual memory errors I get occasional debug errors on various parts of the code that works in excel... It does work, just not every time... And I don't know why!!!
As a last ditch effort before I give up on having access import this data and just do the organizing with an excel macro rather then an access macro I thought I would post my code in it's entirety to see if anyone had any insight.
For each of the 18 or so items in the query the appropriate file is opened, the data is organized into an appropriate format and imported into a temp tbl. If I get this to work future steps will include checking for doubles (with errors returned if there are) and copying the data into the main table.
So, here's the code:
If you look at any of this wondering why I did it a certain way, the reason is probably that it was just the way I found to do it.
I'd really appreciate any help that could be offered.
Oh, in addition to the virtual memory errors I get occasional debug errors on various parts of the code that works in excel... It does work, just not every time... And I don't know why!!!
As a last ditch effort before I give up on having access import this data and just do the organizing with an excel macro rather then an access macro I thought I would post my code in it's entirety to see if anyone had any insight.
For each of the 18 or so items in the query the appropriate file is opened, the data is organized into an appropriate format and imported into a temp tbl. If I get this to work future steps will include checking for doubles (with errors returned if there are) and copying the data into the main table.
So, here's the code:
Code:
Sub gatherdata()
'set variables
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim varpath As String
Dim numofrecords As Long
Dim getpath As String
Dim getlob As String
Dim getsite As String
Dim getsurvey As String
Dim i As Integer
Dim xlApp As New Excel.Application
Dim wb As workbook
Dim ws As worksheet
Dim lastrow As Long
Dim GroupName As String
Dim AgentName As String
Dim AgentID As String
Dim counter2 As Integer
Dim surveynum As Long
'Prep code
Set db = CurrentDb
Set rs = db.OpenRecordset("qryActiveSurveys")
db.Execute "Delete * from tbltemp"
xlApp.Visible = False
'gets the number of records in query (usually about 18)
rs.MoveLast
numofrecords = rs.RecordCount
'starts loop that cycles through entries in the query
For i = 1 To numofrecords
If i = 1 Then
rs.MoveFirst
Else
rs.MoveNext
End If
'sets the variables to the data in the current row
getpath = rs("Path")
getlob = rs("LoB")
getsite = rs("Site")
getsurvey = rs("Survey")
'Open File and set to variables
Set wb = xlApp.workbooks.Open(getpath)
Set ws = wb.ActiveSheet
'Begin altering data
'checks to make sure surveys are present. If no surveys are present there will be 6 cells with data in column A
ws.Range("C1") = "=COUNTA(A:A)"
If ws.Range("C1") = 6 Then
xlApp.DisplayAlerts = False
'ActiveWindow.Close
xlApp.DisplayAlerts = True
'wb.Activate
GoTo endfile
End If
'Reset formatting [COLOR=Red]This is one area that often gives the debug error[/COLOR]
ws.Cells.Font.Name = "MS Sans Serif"
ws.Cells.Font.Size = 10
ws.Cells.Font.Strikethrough = False
ws.Cells.Font.Superscript = False
ws.Cells.Font.Subscript = False
ws.Cells.Font.OutlineFont = False
ws.Cells.Font.Shadow = False
ws.Cells.Font.Underline = xlUnderlineStyleNone
ws.Cells.Font.ColorIndex = xlAutomatic
ws.Cells.Font.Bold = False
ws.Cells.Font.Italic = False
ws.Cells.Font.Underline = xlUnderlineStyleNone
ws.Cells.HorizontalAlignment = xlGeneral
ws.Cells.VerticalAlignment = xlBottom
ws.Cells.WrapText = False
ws.Cells.Orientation = 0
ws.Cells.AddIndent = False
ws.Cells.IndentLevel = 0
ws.Cells.ShrinkToFit = False
ws.Cells.ReadingOrder = xlContext
ws.Cells.MergeCells = False
ws.Cells.Borders(xlDiagonalDown).LineStyle = xlNone
ws.Cells.Borders(xlDiagonalUp).LineStyle = xlNone
ws.Cells.Borders(xlEdgeLeft).LineStyle = xlNone
ws.Cells.Borders(xlEdgeTop).LineStyle = xlNone
ws.Cells.Borders(xlEdgeBottom).LineStyle = xlNone
ws.Cells.Borders(xlEdgeRight).LineStyle = xlNone
ws.Cells.Borders(xlInsideVertical).LineStyle = xlNone
ws.Cells.Borders(xlInsideHorizontal).LineStyle = xlNone
'finds the last row in the book to determine how many times to run loop.
If xlApp.WorksheetFunction.CountA(Cells) > 0 Then
lastrow = Cells.Find(what:="*", after:=[A1], _
searchorder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End If
'removes and adds columns as needed [COLOR=Red]This is another area that often gives the debug error[/COLOR]
ws.Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
ws.Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
ws.Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
ws.Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
ws.Columns("A:G").Select
Selection.Insert Shift:=xlToRight
ws.Columns("B:B").Select
Selection.NumberFormat = "@"
'Adds a space in front of AM/PM in time stamp to turn the cell from text to actual Time
ws.Columns("H:H").Select
Selection.Replace what:="AM", Replacement:=" AM", LookAt:=xlPart, _
searchorder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace what:="PM", Replacement:=" PM", LookAt:=xlPart, _
searchorder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'runs through each row looking for a new agent and puts agent name and
'survey name in Col A&B
GroupName = "unknown"
For counter2 = 1 To lastrow
Range("C" & counter2).Select
ActiveCell.FormulaR1C1 = "=IF(LEFT(RC[5],6)=""Group:"",MID(RC[5],9,30),"""")"
If Range("C" & counter2) <> "" Then GroupName = Range("C" & counter2)
If Range("H" & counter2) = "Agent:" Then
If Range("I" & counter2) = "" Then
AgentName = "unknown"
AgentID = "na"
Else
Range("D" & counter2).Select
ActiveCell.FormulaR1C1 = "=IF(iserror(LEFT(RC[5],6)*1),""na"",LEFT(RC[5],6)*1)"
Range("E" & counter2).Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]=""na"",RC[4],MID(RC[4],8,35))"
AgentName = Range("E" & counter2)
AgentID = Range("D" & counter2)
End If
GoTo mark1
End If
If Range("H" & counter2) > 0 And Range("H" & counter2) < 100000 Then
Range("B" & counter2) = AgentID
Range("C" & counter2) = AgentName
Range("D" & counter2) = getsite
Range("E" & counter2) = getlob
Range("F" & counter2) = GroupName
Range("G" & counter2) = getsurvey
End If
mark1:
Next
'Removes a space in front of AM/PM in Group Name
xlApp.DisplayAlerts = False
ws.Columns("F:F").Select
Selection.Replace what:=" AM", Replacement:="am", LookAt:=xlPart, _
searchorder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace what:=" PM", Replacement:="pm", LookAt:=xlPart, _
searchorder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
xlApp.DisplayAlerts = True
'Sorts the surveys
Cells.Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range("H1") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
'Create a count formula so we know how many rows are actually surveys
Range("z1") = "=counta(B:B)"
surveynum = Range("z1") + 1
'delete excess rows and columns
ws.Rows(surveynum & ":" & lastrow).Select
Selection.Delete Shift:=xlUp
ws.Columns("N:AA").Select
Selection.Delete Shift:=xlToLeft
ws.Shapes("Picture 1").Select
Selection.Delete
ws.Rows("1:1").Select
Selection.Insert Shift:=xlDown
'set header names to ease importing
Range("A1") = "Index_#"
Range("B1") = "Agent_ID"
Range("C1") = "Agent_Name"
Range("D1") = "Site"
Range("E1") = "Line_of_Business"
Range("F1") = "Group_Name"
Range("G1") = "Survey"
Range("H1") = "Timestamp"
Range("I1") = "Q1"
Range("J1") = "Q2"
Range("K1") = "Q3"
Range("L1") = "Q4"
Range("M1") = "Q5"
Range("H2:H5000").Select
Selection.NumberFormat = "[$-409]mm/dd/yyyy h:mm:ss AM/PM;@"
' delete column A because i figured out it's not needed.
ws.Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
'Save xpls book as temp xls file
xlApp.DisplayAlerts = False
wb.SaveAs Filename:="C:\txt\etalktemp.xls", FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
endfile:
'close excel object
xlApp.DisplayAlerts = False
wb.Close
xlApp.DisplayAlerts = True
xlApp.Quit
Set ws = Nothing
Set wb = Nothing
Set xlApp = Nothing
'Import from temp xls file to temp table
DoCmd.SetWarnings False
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, _
"tblTemp", "C:\txt\etalktemp.xls", True
DoCmd.SetWarnings True
Next
Set rs = Nothing
Set db = Nothing
End SubIf you look at any of this wondering why I did it a certain way, the reason is probably that it was just the way I found to do it.
I'd really appreciate any help that could be offered.
