Over come 255 Character Limit with VBA - Question

[Rx_]

Problem: VBA Code in MS Access 2007 (or 2010) creates recordset.
The "Comment" field exceeds 255 characters.
The CopyFromRecordset method does not work for Memo fields (i.e. larger than 255 characters).
Objective: User CustomerID in a custom function and concat all the memo fields for a CustomerID into one Excel field. (note: Wells ID is actually Customer ID)

What I need help with is: Should I use the copyfromrecordset and populate the Excel worksheet, then loop through each cell to retrieve the long comment string?
The last column is the CustomerID, it needs to be replaced with the long comment string. On the Excel sheet, the column name is known, the start row and the end row. Any code examples would be helpful.

Line 600 CopyFromRecordset puts the correct fields into Excel, with the last field being the CustomerID. The last field is the Funcition parameter that can run the function and return the very long string.

strSQLComments = "SELECT Wells_Areas.Area, Wells.Well_Name AS [Well Name], Last(Wells_Status1.Status1) AS [Well Status], Last(Comments.Date) AS LastOfDate1, Last(Comments.[User ID]) AS [LastOfUser ID], Last(Wells.ID_Wells) AS LastOfID_Wells "
strSQLComments = strSQLComments & " FROM ((States INNER JOIN Wells_Areas ON States.ID_State = Wells_Areas.ID_State) INNER JOIN (Wells_Status1 INNER JOIN Wells ON Wells_Status1.ID_WellStatus1 = Wells.ID_WellsStatus1) ON Wells_Areas.ID_Area = Wells.ID_Area) INNER JOIN Comments ON Wells.ID_Wells = Comments.ID_Wells "
strSQLComments = strSQLComments & " GROUP BY Wells_Areas.Area, Wells.Well_Name, Well_Name_Sorted([Well_Name]), Wells.ID_Area "
strSQLComments = strSQLComments & " HAVING (((Last(Wells.Activity))='A') AND ((Wells.ID_Area) " & ID_Area & ")) "
strSQLComments = strSQLComments & " ORDER BY Wells_Areas.Area, Well_Name_Sorted([Well_Name]), Last(Comments.Date) DESC; "
 
          Debug.Print "strSQLComments = " & strSQLComments
540       Call LogUsage("Comments Report", "Open Dynaset", "Line") ' Log success
550       ObjXL.Visible = False
          'Debug.Print " sql string =  " & strSQLComments   ' for test purposes
 
 
560         Set rsDataSundries = CurrentDb.OpenRecordset(strSQLComments, dbOpenSnapshot, dbReadOnly) ' suggestion was this could be faster but it is not
570         intRowPos = 6                                                                                 'Sets starting Row to 6 for data returned to Excel 
590         ObjXL.DisplayAlerts = False                                                       ' Turn off Display Alerts
600         ObjXL.Worksheets(intWorksheetNum).Cells(intRowPos, 1).CopyFromRecordset rsDataSundries
620         intMaxRecordCount = rsDataSundries.RecordCount - 1                                                      ' - use for max rows returned in formatting later

The ConcatComments takes the WellID (a.k.a. CustomerID) and returns a long string of comments with dates and delimiters into one string variable

Function ConcatComments(intPrimaryKeyID As Integer) As String ' Wells Primary ID passed in
      Dim dbCommentsCodes   As DAO.Database
      Dim rsCommentsCodes   As DAO.Recordset
      Dim CommentString     As String                      ' Output String
      Dim strCriteria       As String, strsCommentsCodesQL      As String
      ' Change SQL statement to accept intPrimaryKeyID as shown below
10      strsCommentsCodesQL = "SELECT CStr([Date]) & ' : '  & [Comments] & ' |'   AS Comment " & _
                        "FROM Wells INNER JOIN Comments ON Wells.ID_Wells = Comments.ID_Wells " & _
                        "WHERE (((Wells.ID_Wells) = " & intPrimaryKeyID & ")) " & _
                        "ORDER BY Comments.Date DESC , Wells.ID_Wells;"
20    On Error GoTo Err_ConcatComments
30    CommentString = ""
40        Set dbCommentsCodes = CurrentDb
50        Set rsCommentsCodes = dbCommentsCodes.OpenRecordset(strsCommentsCodesQL, dbOpenSnapshot)             ' snapshots run faster
60        With rsCommentsCodes
70            If .RecordCount <> 0 Then
80                Do While Not rsCommentsCodes.EOF
90                    CommentString = CommentString & rsCommentsCodes("Comment") & " "    ' <-- Field to concat and delimiter
100                   .MoveNext
110               Loop
120           End If
130       End With
Exit_ConcatComments:
          'ConcatComments = Null
150       If Not rsCommentsCodes Is Nothing Then
160           rsCommentsCodes.Close
170           Set rsCommentsCodes = Nothing
180       End If
190       Set dbCommentsCodes = Nothing
200   Exit Function
 
Err_ConcatComments:
210        Resume Exit_ConcatComments
 
 End Function

 

[Ken Hudson]

You probably want to post this to the Access part of the Forum.

 

[Rx_]

Since Access has no means to transfer data to Excel, perhaps a loop using Excel Objects would work? The function will work in Excel.

 

[Rx_]

I had time to figure it out. Hope this helps someone else.

This worked. The data in Excel starts on row 6.
On Row 6 Column F - the query returns the CustomerID
This code highlights the CustomerID - then uses that number in the custom function shown above. The custom function finds all comments for the CustomerID and concat them into one huge string (with some delimer symbols). Sometimes the string is 3,000 characters long.
Finally, the string replaces the CustomerID on ColumnF then moves down one row. The For Next loop knows when to quit since the Recordset Count is checked (see code above).

' loop to column F where CustomerID is at - Take CustomerID, put it in custom function that returns a long string
'   then replace the customerID with the long string.
ObjXL.Range("F" & intRowPos).Select
Dim strComment      As String
Dim lngID           As Long
Dim lngCurRec       As Long
Dim CounterX        As Long
For CounterX = 1 To intMaxRecordCount
    lngCurRec = ObjXL.ActiveCell.Value
        ObjXL.ActiveCell.Value = ConcatComments(lngCurRec)    ' Take WellID into custom function - return a really large string
        'lngCurRec = lngCurRec * 1000            ' substitute custom function here this is just for testing
    'ObjXL.ActiveCell.Value = lngCurRec
    ObjXL.ActiveCell.Offset(1, 0).Select
Next