Advertisement

09.25.2008 at 07:41AM PDT, ID: 23762602
[x]
Attachment Details
[x]
The Solution Rating System

With so many solutions, how can you tell which solutions are most likely to help you and which ones are not? To provide you with a tool to use, we rate our solutions based on various elements that most accurately determine if a solution is a quality solution. To explain what factors affect the solution rating, here are the elements we take into consideration when formulating our solution rating.

  • The Grade of the Solution
  • The Zone Rank of the Expert Providing the Solution
  • The Number of Author and Expert Comments
  • The Number of Experts Contributing
  • The Feedback of the Community

Your Input Matters
Because of the way the system is set up, the most important variable in this equation is you. As a member of Experts Exchange, you are able to cast your vote on the quality of the solutions in regard to how complete, accurate, helpful and easy to understand each solution is. When you provide your feedback, each rating is adjusted accordingly. So, if you see a solution that has a poor rating that you think is a good solution, let us know by rating it. As you do, the rating will be adjusted and will become more accurate for other members of our site.

If you have any suggestions that you would like to make for our rating system, please ask a question in the Suggestions Zone of Community Support.

Thank you!
9.3

Find method using criterion of "3-Sep" is resolving to "13-Sep"

Asked by shambalad in Microsoft Excel Spreadsheet Software, Microsoft Access Database

Tags: , , ,

I am trying to load data to specific cells in a spreadsheet with a procedure running in an Access database. In order to identify the specific cell to be updated, I am trying to create a column range, then a row range, where the target cell is the intersection of the two.
The column Find is for a date string. The cells are formatted using the "d-mmm' pattern (e.g. '09/03/2008' is displayed as '3-Sep' and '09/24/2008' is displayed as '24-Sep'. The Find is working OK for dates where the day portion of the date is 2 digits (e.g. '12-Sep', '26-Sep') but is not finding the correct column for single digit day values such as '3-Sep' or '5-Sep'. What is happening is that the Find for '4-Sep' is "finding" '24-Sep', and '9-Sep' is "finding "29-Sep".
At first I though it was an offset error, so I activate cell 'A1" before executing the Find. This isn't fixing it, though.
Attached below is the code I am working with. I am also attaching the database and the worksheet. Note that there is a named range ("Target") that is being used for the Finds. For the purposes of this prototype, the routine is hard coded to find the workbook in "C:\" but that can easily be changed in the module code (it's a privately scoped constant defined at the top of the module).
Any help in how to resolve this error would be most appreciated.

Thanks
Todd


Attachments:

Snippet:
VBA module "basLoadAuditCounts"

Images:
1. Snapshot of the worksheet. The range "Target" has been selected ($A$2:$Y$10)
2. Snapshot of the query data from the Access database.
3. Image of the results of the 'Finds'. After each find, the VBA code executes a 'Debug.Print' of the Rep Name and the Date being used for the find, along with the cell found.

Files:
Access Database:  "MapData.mdb"
Excel Workbook: "Workflow Tracker.xls"

Start Free Trial 
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:

Option Explicit
Option Compare Database
Private Const strModule As String = "basLoadAuditCounts"
 
' Location of workbook
Private Const strPath As String = "C:\Workflow Tracker.xls"
 
Public Function fnLoadAuditCounts()
   Dim xlsApp As Excel.Application
   Dim xlsSheet As Excel.Worksheet
   Dim xlsBook As Excel.Workbook
   Dim strProcedure As String
   Dim strRngTarget As String
   Dim rngCell As Excel.Range
   Dim rst As DAO.Recordset
   Dim db As DAO.Database
   Dim strSheet As String
   Dim strDate As String
   Dim strRep As String
   Dim strMsg As String
   Dim strQry As String
   Dim dteDate As Date
   Dim lngQty As Long
   
   On Error GoTo ErrorHandler
   strProcedure = "fnLoadAuditCounts"
   
   ' Load the Audit counts to the spreadsheet
   
   ' Range to find the target cells
   strRngTarget = "Target"
   
   ' Data query
   strQry = "qryRepAuditCounts"
   
   ' Worksheet to update
   strSheet = "Personnel Tracker"
   
   ' Open the recordset
   Set db = CurrentDb()
   Set rst = db.OpenRecordset(strQry, dbOpenForwardOnly)
   
   ' Open Excel, workbook, worksheet
   Set xlsApp = New Excel.Application
   xlsApp.Workbooks.Open strPath, , True
   Set xlsSheet = xlsApp.ActiveWorkbook.Sheets(strSheet)
      
   With rst
      Do Until .EOF
         strRep = .Fields("Rep")
         dteDate = .Fields("Date")
         ' Convert date to string in "d-mmm" format
         strDate = CStr(Format(dteDate, "d-mmm"))
         lngQty = .Fields("Qty")
         
         'Set the range for the target cell (rngCell)
         If fnSetDataRange(rngCell, _
                  xlsApp, strRngTarget, _
                  strSheet, strDate, strRep) Then
            With xlsSheet
               ' Activate the cell
               rngCell.Activate
               
   ' ********* Debug
   Dim strCell As String
   strCell = xlsApp.ActiveCell.Address
   Debug.Print "Rep: '" & strRep & "'", "Date: '" & strDate & "' ", "Cell: '" & strCell & "'"
   ' **********
               
               ' Update the cell
               ' rngCell.Value = lngQty
               
            End With 'With xlsSheet
         Else
            MsgBox "Error setting range"
            GoTo ExitFunction
         End If      'If fnSetDataRange(rngCell
         .MoveNext
      Loop           'Do Until .EOF
   End With          'With rst
   
   fnLoadAuditCounts = True
   
   MsgBox "Stop!"
   
ExitFunction:
   On Error Resume Next
   
   rst.Close
   Set rst = Nothing
   Set db = Nothing
   Set rngCell = Nothing
   
   xlsApp.DisplayAlerts = False
   If Not xlsBook Is Nothing Then
      xlsBook.Close savechanges:=True
      Set xlsBook = Nothing
   End If         'If Not xlsBook Is Nothing
   
   If Not xlsApp Is Nothing Then
      xlsApp.Quit
      Set xlsApp = Nothing
   End If         'If Not xlsApp = Nothing
   
   Exit Function
   
ErrorHandler:
   
   On Error Resume Next
   xlsApp.DisplayAlerts = False
   
   strMsg = "Module: " & strModule & vbCrLf & _
            "Procedure: " & strProcedure & vbCrLf & _
            "Error: " & Err.Description & _
            " (" & Err.Number & ")"
   Debug.Print strMsg
   MsgBox strMsg
   Resume ExitFunction
End Function
 
Private Function fnSetDataRange( _
         ByRef rngCell As Excel.Range, _
         xlsApp As Excel.Application, _
         strRngTarget As String, _
         strSheet As String, _
         strDate As String, _
         strRep As String) _
         As Boolean
   
   ' Sets range of cell to be loaded with data
   
   Dim xlsSheet As Excel.Worksheet
   Dim rngColumn As Excel.Range
   Dim strProcedure As String
   Dim rngRow As Excel.Range
   'Dim strSheet As String
   Dim strCell As String
   Dim strMsg As String
   
   strProcedure = "fnSetDataRange"
   
   If Not rngCell Is Nothing Then
      Set rngCell = Nothing
   End If   'If Not rngCell Is Nothing
   
   Set xlsSheet = xlsApp.ActiveWorkbook.Sheets(strSheet)
   xlsSheet.Activate
   
   If Not fnRangeExists(xlsSheet, strRngTarget) Then
      strMsg = "Error: Range '" & strRngTarget & "' not found"
      GoTo ExitFunction
   End If
   
   ' Need to place cursor at "A1" prior
   ' to finding the range in order to
   ' avoid an off-set error
   xlsSheet.Range("A1").Select
   
   On Error Resume Next
   
   ' Get the column
   Set rngColumn = xlsSheet.Range( _
            strRngTarget).Cells.Find(strDate, _
            LookIn:=xlValues, _
            SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious _
            ).EntireColumn
   
   If rngColumn Is Nothing Then
      strMsg = "Module: " & strModule & vbCrLf & _
            "Procedure: " & strProcedure & vbCrLf & _
            "Date: '" & strDate & "' not found in range '" & _
            strRngTarget & "'" & vbCrLf & "Error: '" & _
            Err.Description & " (" & Err.Number & ")'"
      Debug.Print strMsg
      MsgBox strMsg
      GoTo ExitFunction
   End If   'If rngColumn Is Nothing
  
   ' Need to place cursor at "A1" prior
   ' to finding the range in order to
   ' avoid an off-set error
   xlsSheet.Range("A1").Select
   
   ' Get the Row
   Set rngRow = xlsSheet.Range( _
            strRngTarget).Cells.Find(strRep, _
            LookIn:=xlValues, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious _
            ).EntireRow
   
   If rngRow Is Nothing Then
      strMsg = "Module: " & strModule & vbCrLf & _
            "Procedure: " & strProcedure & vbCrLf & _
            "Rep: '" & strRep & "' not found in range '" & _
            strRngTarget & "'" & vbCrLf & "Error: '" & _
            Err.Description & " (" & Err.Number & ")'"
      Debug.Print strMsg
      MsgBox strMsg
      GoTo ExitFunction
   End If   'If rngRow Is Nothing
  
   ' Need to place cursor at "A1" prior
   ' to finding the range in order to
   ' avoid an off-set error
   xlsSheet.Range("A1").Select
   
   ' The target cell is the intersection of the column and row
   Set rngCell = xlsApp.Intersect( _
            rngColumn, _
            rngRow)
     
   If rngCell Is Nothing Then
      strMsg = "Module: " & strModule & vbCrLf & _
            "Procedure: " & strProcedure & vbCrLf & _
            "Target cell for Date: '" & strDate & "' " & _
            "And Rep: '" & strRep & "' not found in range '" & _
            strRngTarget & "'" & vbCrLf & "Error: '" & _
            Err.Description & " (" & Err.Number & ")'"
      Debug.Print strMsg
      MsgBox strMsg
      GoTo ExitFunction
   End If   'If rngCell Is Nothing
   
   fnSetDataRange = True
   
ExitFunction:
     ' Cleanup
   On Error Resume Next
   Set rngRow = Nothing
   Set rngColumn = Nothing
   Set xlsSheet = Nothing
   
   On Error GoTo 0
   Exit Function
   
ErrorHandler:
   strMsg = "Module: " & strModule & vbCrLf & _
        "Procedure: " & strProcedure & vbCrLf & _
        "Error: " & Err.Description & _
        " (" & Err.Number & ")"
   Debug.Print strMsg
   MsgBox strMsg
   Resume ExitFunction
End Function
 
Private Function fnRangeExists( _
         xlsSheet As Excel.Worksheet, _
         strRange As String) As Boolean
   Dim xlsRange As Excel.Range
   On Error Resume Next
   Set xlsRange = xlsSheet.Range(strRange)
   On Error GoTo 0
   If Not xlsRange Is Nothing Then
      fnRangeExists = True
   End If
End Function
Attachments:
 
Workflow-Tracker.bmp (921 KB) (File Type Details) 
Worksheet image
Worksheet image
 
 
Rep-Audit-Data.bmp (135 KB) (File Type Details) 
Query data
Query data
 
 
Rep-Audit-Find-Results.bmp (188 KB) (File Type Details) 
Find results
Find results
 
 
Workflow-Tracker.xls (112 KB) (File Type Details) 
Workbook
 
 
MapData.mdb (544 KB) (File Type Details) 
Access database
 
[+][-]09.25.2008 at 08:03AM PDT, ID: 22569962

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]09.25.2008 at 11:12AM PDT, ID: 22572269

View this solution now by starting your 7-day free trial. Setting up your free trial is quick, easy, and secure. We will return you to this solution, unlocked, when you're done.

 

About this solution

Zones: Microsoft Excel Spreadsheet Software, Microsoft Access Database
Tags: Microsoft, Excel, 2003, Range Access VBA
Sign Up Now!
Solution Provided By: lynx20
Participating Experts: 1
Solution Grade: A
 
 
[+][-]09.25.2008 at 11:26AM PDT, ID: 22572391

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
 
Loading Advertisement...
20080716-EE-VQP-32 - Hierarchy / EE_QW_2_20070628