This example of the code was for a shared comment history used in mutliple workbooks – also see "Requesting, Storing, And Retrieving User Settings" under the User Interfaces category of this site.


Option Explicit
Option Base 1

'the code in this module requires a reference to zaksCollection.dll
'the dll can be found here: http://www.zaks.demon.co.uk/code/cpts/coll/

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength&, ByVal lpBuffer$) As Long

Private Sub PopCommentGVs()
On Error Resume Next

    gvTestComments = 1

'    gvReportType = Entity
    gvCommentsFile = ThisWorkbook.Path & "\Report Files\Comments\CommentHistory.csv"
    gvCOBDate = Date - sStart.[DaysPriorForRoX] 'sStart.[DaysPriorForRoX]

    'find columns on 'T+1 (Values Only)' ws
    With wsDS(1)
        gvColNum1 = cMatch(ColName1, .Name)
        gvColNum2 = cMatch(ColName2, .Name)
        gvColNum3 = cMatch(ColName3, .Name)
        gvColNum4 = cMatch(ColName4, .Name)
        gvColNum5 = cMatch(ColName5, .Name)
        gvColNum6 = cMatch(ColName6, .Name)
        gvColNum7 = cMatch(ColName7, .Name)
        gvColNum8 = cMatch(ColName8, .Name)
    End With
    If (Application.Min(gvColNum1, gvColNum2, gvColNum3, gvColNum4, gvColNum5) <= 0) Then
        'this is just for development
        MsgBox ("Wrong sheet"): Stop
    End If

End Sub

Public Sub RunSaveComments(Optional CalledByVBA As Boolean)
 Dim subN&:  subN = SubStart(Updating, , , , "Saving Comments...", Not CalledByVBA)
On Error Resume Next
'don't need to close and re-open file during savecomments loop, but only writing to file so doesn't really matter

    Dim i As Byte, ws, tempInt& ', sStatusBar$

    ThisWorkbook.Activate

    If Not gvTestComments Then PopCommentGVs

    tempInt = myUBound(wsPendingComments)
    If CBool(tempInt) Then
        For i = 1 To tempInt
            SaveComments (i)
        Next
    Else
        SaveComments
    End If

    Call RefreshComments(True)

'    Application.StatusBar = sStatusBar

 SubEnd (subN)
End Sub

Private Sub SaveComments(Optional i As Byte)
On Error Resume Next

    If Not gvTestComments Then PopCommentGVs

    Dim GetCommentSheet As Worksheet, sUserName$:  sUserName = GetUserName()
    If (i > 0) Then Set GetCommentSheet = wsPendingComments(i) Else Set GetCommentSheet = ActiveSheet

    If (GetCommentSheet.Name <> sT1ValuesOnly.Name) Then
        'get column numbers for relevant ws
        With GetCommentSheet
            gvColNum1 = cMatch(ColName1, .Name)
            gvColNum2 = cMatch(ColName2, .Name)
            gvColNum3 = cMatch(ColName3, .Name)
            gvColNum4 = cMatch(ColName4, .Name)
            gvColNum5 = cMatch(ColName5, .Name)
            gvColNum6 = cMatch(ColName6, .Name)
            gvColNum7 = cMatch(ColName7, .Name)
            gvColNum8 = cMatch(ColName8, .Name)
        End With
        If (Application.Min(gvColNum1, gvColNum2, gvColNum3, gvColNum4, gvColNum5) <= 0) Then
            'this is just for development
            MsgBox ("Wrong sheet"): Stop
        End If
        gvTestComments = 0 'reset gvTestComments so column gvs will be reset before they are used again
    End If

    Dim iRow&, iLastRow&, sComment$, FileOpened As Boolean

    iLastRow = GetCommentSheet.Cells(1, 1).End(xlDown).Row
    If (iLastRow = 65536) Then Exit Sub

    For iRow = 2 To iLastRow
        sComment = GetCommentSheet.Cells(iRow, gvGetCommentCol)
        If TestLen(sComment) Then
TryAgain:
            If Not FileOpened Then
                On Error Resume Next
                Open gvCommentsFile For Append Lock Write As #1
                If (err.Number = 70) Then
                    Close #1
                    With Application
                        .StatusBar = "Comments file is locked by another user. Retrying in 5 secs..."
                        .Wait Now + TimeValue("00:00:05")
                    End With
                    GoTo TryAgain
                ElseIf (err.Number <> 0) Then
                    MsgBox "Failed to Open Comments File : " & gvCommentsFile & ". Please confirm you have persmissions to lock the file"
                    Exit Sub
                End If
            End If
            FileOpened = 1
            With GetCommentSheet
                Print #1, cq(.Cells(iRow, gvColNum1)) & "," & _
                    "'" & cq(.Cells(iRow, gvColNum2)) & "," & _
                    sUserName & "," & _
                    Round(.Cells(iRow, gvColNum3), 2) & "," & _
                    Round(.Cells(iRow, gvColNum4), 2) & "," & _
                    cq(DateValue(Format(Date, "mm/dd/yyyy"))) & "," & _
                    cq(.Cells(iRow, gvColNum5)) & "," & _
                    cq(.Cells(iRow, gvColNum6)) & "," & _
                    cq(.Cells(iRow, gvColNum7))
            End With
        End If
    Next
    If FileOpened Then Close #1

End Sub

Public Sub RefreshComments(Optional CalledByVBA As Boolean)
 Dim subN&:  subN = SubStart(Updating, Events, , Calculation, "Refreshing Comments...", Not CalledByVBA) 'need to disable events for DistributeComments sub
On Error Resume Next

    If Not gvTestComments Then PopCommentGVs

    ThisWorkbook.Activate

    Dim iRow&, lCommentHist$, lRange As Range
    Set zCommentHist = LoadComments(gvCommentsFile, Array(1, 2))
    Set lRange = RangeArea(wsDS(1).Cells(2, 1))
    For iRow = 1 To lRange.Rows.Count
        lRange.Cells(iRow, gvGetCommentCol) = ""
        lCommentHist = GetCommentsHist("'" & lRange.Cells(iRow, gvColNum1) _
                                        , "'" & lRange.Cells(iRow, gvAccountCol))
        With lRange.Cells(iRow, gvHistCommentCol)
            If TestLen(lCommentHist) Then
                .ClearFormats
                .Value = lCommentHist
                .WrapText = False
            Else
                .ClearFormats
                .Value = " " 'space is prevent new comments from spilling over into comment history column
            End If
        End With
'        'not doing this now:
'        lActiveComments = getActiveComments("'" & lRange.Cells(iRow, gvColNum1) _
'                          , "'" & lRange.Cells(iRow, gvColNum2) _
'                          , (lRange.Cells(iRow, gvColNum3) <> 0) _
'                          , lRange.Cells(iRow, gvColNum3))
'        lRange.Cells(iRow, gvColNum4) = lActiveComments
'        lRange.Cells(iRow, gvColNum5) = Left$(lActiveComments, 10)
    Next

    Call DistributeCommentsToOtherSheets

 SubEnd (subN)
End Sub

Public Function CheckForNewComments(Optional CalledByVBA As Boolean) As Byte
 Dim subN&:  subN = SubStart(Updating, Events, , , , Not CalledByVBA)
On Error Resume Next
'set wsPendingComments gv for sheets with pending comments
'and call RunSaveComments if any pending comments are found and user chooses to save them

    If Not wsGVTest Then PopEventGVs 'make sure aWSOut is set

    Dim c As Byte, ws
    Erase wsPendingComments
    For Each ws In aWSOut
        If CheckSheetForNewComments(ws.Name) Then
            c = c + 1
            ReDim Preserve wsPendingComments(c)
            Set wsPendingComments(c) = ws
        End If
    Next
    If (c > 0) Then
        If (MsgBox("There are pending comments. Save them now?", vbYesNo, "") = vbYes) Then
            Call RunSaveComments(True)
            CheckForNewComments = 1 'return 1
        Else
            CheckForNewComments = 2 'return 2
        End If
    End If
    Erase wsPendingComments

 SubEnd (subN)
End Function

Private Function CheckSheetForNewComments(sName$) As Boolean
On Error Resume Next

    Dim tempStr$
    With Sheets(sName)
        '(using string reference to avoid selecting ws)
        tempStr = ColumnLetter(cMatch(NewComment, sName))
        tempStr = tempStr & "2:" & tempStr & Application.Max(.UsedRange.Rows.Count, 2)
        If (Application.CountA(.Range(tempStr)) > 0) Then CheckSheetForNewComments = 1
    End With

End Function

Private Sub DistributeCommentsToOtherSheets()
On Error Resume Next

    If Not wsGVTest Then PopEventGVs

    Dim i&, s As Byte, CommentHistCol&, ColOut&(), NewCommentCol&(), tempStr$, tempVar ', sNames, aWSOut() As Worksheet
    Dim ActiveWS$:  ActiveWS = ActiveSheet.Name

    ReDim ColOut(UBound(aWSOut)), NewCommentCol(UBound(aWSOut))
    For i = 2 To UBound(aWSOut) 'skipping 'T+1 (Values Only)' ws
        With aWSOut(i)
            If (Application.CountA(.Columns(1)) > 1) Then 'make sure there's data on the ws
                ColOut(i) = cMatch(CommentHistory, .Name)
                NewCommentCol(i) = cMatch(NewComment, .Name)
                If (ColOut(i) = 0) Then Stop    'header not found
                'clear old comment data
                '(using string reference to avoid selecting ws)
                tempStr = ColumnLetter(ColOut(i))
                tempStr = tempStr & 2 & ":" & tempStr & Application.CountA(.Columns(1))
                .Range(tempStr).Clear
            End If
        End With
    Next

    With wsDS(1)
        CommentHistCol = cMatch(CommentHistory, .Name)
        For i = 2 To Application.CountA(.Columns(1)) 'skipping 'T+1 (Values Only)' ws
            tempStr = .Cells(i, CommentHistCol)
            If TestLen(tempStr) Then
                For s = 2 To UBound(aWSOut)
                    tempVar = Application.Match(.Cells(i, 1), aWSOut(s).Columns(1), 0)
                    If IsNumeric(tempVar) Then
                        If (tempVar > 1) Then 'just in case
                            With aWSOut(s).Cells(tempVar, ColOut(s))
                                .Value = tempStr
                                .WrapText = False
                            End With
                            aWSOut(s).Cells(tempVar, NewCommentCol(s)).ClearContents
                        End If
                    End If
                Next
            End If
        Next
    End With

    With Sheets(ActiveWS)
        If (ActiveSheet.Name <> ActiveWS) And .Visible Then .Select
    End With

End Sub

Private Function LoadComments(sFile$, aKeys, Optional aReorder) As zaksColl
On Error Resume Next
'read comments file and store data in a dictionary

    Dim zRes As New zaksColl, sStatusBar$:  sStatusBar = Application.StatusBar
    Dim aRow, sRow$, aRow2, i&, maxKey&, iRow&, sKey$, iMaxCols&

    For i = 1 To UBound(aKeys)
        If (aKeys(i) > maxKey) Then maxKey = aKeys(i)
    Next
    Dim fs As Scripting.FileSystemObject, a As Scripting.TextStream
    Set fs = CreateObject("Scripting.FileSystemObject")
    On Error GoTo FileNotFound
    Set a = fs.OpenTextFile(sFile, ForReading, False)
    iRow = 0
    Do While Not a.AtEndOfStream
        iRow = iRow + 1
        sRow = a.ReadLine()
        aRow = ParseRow(sRow, ",")
        If (iRow Mod 1000 = 0) Then Application.StatusBar = "Loading " & sFile & " row " & iRow
        If (UBound(aRow, 2) >= maxKey) Then
            sKey = ""
            For i = 1 To UBound(aKeys)
                sKey = sKey & Trim(aRow(1, aKeys(i)))
            Next
            If IsArray(aReorder) Then 'Reorder the columns
                iMaxCols = Application.Max(UBound(aRow, 2), UBound(aReorder))
                ReDim aRow2(1 To 1, 1 To iMaxCols)
                For i = 1 To iMaxCols
                    On Error Resume Next
                    If (aReorder(i) > 0) Then aRow2(1, i) = aRow(1, aReorder(i))
                Next
                aRow = aRow2
            End If
            If IsEmpty(zRes(sKey)) Then zRes(sKey) = New Collection
            zRes(sKey).Add aRow
        End If
    Loop
    a.Close
    Set LoadComments = zRes
    Application.StatusBar = sStatusBar

    Exit Function
FileNotFound:
    Application.StatusBar = sStatusBar
    MsgBox "File '" & sFile & "' does not exist. Please check the directory : " & err.Description
End Function

Private Function ParseRow(sRow$, sDelim$)
On Error Resume Next
'parse CSV line and create array of fields

    Dim iPos&, iPrePos&, iToken&

    ReDim aRes(1 To 1, 1 To 30)
    Do
        iPos = InStr(iPos + 1, sRow, sDelim)
        If (iPos > 0) Then
            iToken = iToken + 1
            aRes(1, iToken) = Mid(sRow, iPrePos + 1, iPos - iPrePos - 1)
            iPrePos = iPos
        Else
            iToken = iToken + 1
            aRes(1, iToken) = Right(sRow, Len(sRow) - iPrePos)
        End If
    Loop Until (iPos = 0)
    ReDim Preserve aRes(1 To 1, 1 To iToken)
    ParseRow = aRes

End Function

Private Function cq(s$)
    cq = WorksheetFunction.Substitute(s, ",", "|")
End Function

Private Function GetCommentsHist$(sSec, sAcct)
On Error Resume Next

    Dim sRet$, i&, sKey$, sTrimSec$, sTrimAcct$
    Dim lColl As Collection

    sTrimAcct = Mid(sAcct, 2, 1000)
    sTrimSec = Mid(sSec, 2, 1000)
    sKey = sTrimAcct & "'" & sTrimSec
'    sKey = Trim(sAcct) & Trim(sSec) 'this didn't work

    If IsEmpty(zCommentHist(sKey)) Then Exit Function

    Set lColl = zCommentHist(sKey)
    For i = 1 To lColl.Count
        sRet = PrintComment(lColl(i)) & vbCrLf & sRet
    Next
    If Right(sRet, 1) = Chr(10) Then sRet = Left(sRet, Len(sRet) - 1) 'remove extra line break
    GetCommentsHist = Trim$(sRet)

End Function

Private Function PrintComment$(aComment)
On Error Resume Next

    On Error GoTo ExitNow

    Dim sRet$
    sRet = Format(aComment(1, 6), "yyyy:mm:dd") 'date
    sRet = sRet & " " & Bullet & " " & aComment(1, 3)
    sRet = sRet & " " & Bullet & " " & aComment(1, 2)
    sRet = sRet & " " & Bullet & " " & aComment(1, 1)
    sRet = sRet & " " & Bullet & " " & aComment(1, 7)
    sRet = sRet & " " & Bullet & " " & aComment(1, 8)
    sRet = sRet & " " & Bullet & " " & aComment(1, 9)
    sRet = sRet & " " & Bullet & " " & aComment(1, 4)
    sRet = sRet & " " & Bullet & " " & aComment(1, 5)
    PrintComment = Trim$(sRet)
    PrintComment = Application.Substitute(PrintComment, "|", ",")

ExitNow:
End Function

Private Function GetUserName$()
On Error Resume Next

    Dim tempVar, tempStr$
    tempStr = Environ("USERNAME")
    tempVar = Application.VLookup(tempStr, sUserNames.[UserNames], 2, 0)
    If (VarType(tempVar) = vbString) Then GetUserName = tempVar Else GetUserName = tempStr

End Function

Private Function RangeRight(rngStart As Range) As Range
On Error Resume Next
'returns the rightmost cell from the start with continuous data
    If IsEmpty(rngStart) Or IsEmpty(rngStart.Offset(0, 1)) Then _
        Set RangeRight = rngStart Else Set RangeRight = rngStart.End(xlToRight)
End Function

Private Function RangeDown(rngStart As Range) As Range
On Error Resume Next
'return the downmost cell from the start with continuous data
    If IsEmpty(rngStart) Or IsEmpty(rngStart.Offset(1, 0)) Then _
        Set RangeDown = rngStart Else Set RangeDown = rngStart.End(xlDown)
End Function

Private Function RangeArea(rngStart As Range) As Range
On Error Resume Next
'get the area down and to the left of the start. End(xlDown) and xlLeft have problems if used on empty or single cells
    With rngStart
        Set RangeArea = Range(.Offset(0, 0), .Offset(RangeDown(rngStart).Row - .Row, RangeRight(rngStart).Column - .Column))
    End With
End Function