Macro Add Texts On Double-Click-CodePudding

I made the following code that adds a text when double-clicking a cell. But i need a routine where if i double-click again in the same cell it will add a different text, if i click a third time it will add another text, and so on. This loop should continue for 6 different texts. Thanks in advance for any help.

Private Sub Worksheet_BeforeDoubleClick( _ 
            ByVal Target As Range, Cancel As Boolean)
    Dim rInt As Range
    Dim rCell As Range

    Set rInt = Intersect(Target, Range("H2:H2000"))
    If Not rInt Is Nothing Then
        For Each rCell In rInt
            rCell.Value = "Info"
        Next
    End If

    Set rInt = Nothing
    Set rCell = Nothing
    Cancel = True

End Sub

CodePudding user response：

You'll need to test what the cell already has in it, and add the required word based on that

Private Sub Worksheet_BeforeDoubleClick( _ 
            ByVal Target As Range, Cancel As Boolean)
    Dim Words(0 To 5) As String

    Words(0) = "1st word"
    ' etc to fill array

    Dim rInt As Range

    Set rInt = Intersect(Target, Me.Range("H2:H2000"))
    If Not rInt Is Nothing Then
        Select Case Target.Value2
            Case Words(5)
                'Already has last word
            Case Words(4)
                Target.Value2 = Words(5)
            Case 'etc for other Words 3..0

            Case Else
                Target.Value2 = Words(0)

        End Select
        Cancel = True
    End If
End Sub

CodePudding user response：

Cycle Array Values on Double-Click

Option Explicit

Private Sub Worksheet_BeforeDoubleClick( _
        ByVal Target As Range, Cancel As Boolean)
    
    Const fcAddress As String = "H2"
    Dim Strings As Variant
    Strings = VBA.Array("One", "Two", "Three", "Four", "Five", "Six")
    
    With Me.Range(fcAddress)
        With .Resize(Me.Rows.Count - .Row   1)
            If Intersect(.Cells, Target) Is Nothing Then Exit Sub
        End With
    End With
    
    Cancel = True
    
    Dim IsFound As Boolean
    
    Dim siValue As Variant: siValue = Target.Value
    If Not IsError(siValue) Then
        If Len(siValue) > 0 Then
            Dim siIndex As Variant
            siIndex = Application.Match(siValue, Strings, 0)
            If IsNumeric(siIndex) Then
                If siIndex <= UBound(Strings) Then
                    IsFound = True
                End If
            End If
        End If
    End If
    
    If IsFound Then
        Target.Value = Strings(siIndex)
    Else
        Target.Value = Strings(0)
    End If
        
End Sub