在字符串值的子集中选择第一个和最后一个值

Question

​

​

VBA代码：

Sub Example():

    Dim i As Double
    Dim Letter As String
    Dim var1 As Long
    Dim var2 As Long
    Dim Row_For_Table As Integer
    Row_For_Table = 1
    
For i = 1 To 12

    If Cells(i + 1, 1).Value <> Cells(i, 1).Value Then
        'MsgBox ("different")
        Letter = Cells(i, 1).Value
        
        var2 = Cells(i, 3).Value
        
        var1 = Cells(i, 2).Value
        
        Range("F" & Row_For_Table).Value = Letter
        
        Range("G" & Row_For_Table).Value = var2 - var1
        
        Row_For_Table = Row_For_Table + 1
    Else
        'MsgBox ("same")
    End If
Next i
        
End Sub

我想创建A、B和C的汇总表，其值为(14-1)、(12-5)和(4-1)。我想写这是VBA作为一个更大的项目的模板。

谢谢。

Answer 1

这使用字典来做你想要的事情。它假定您的表按列A排序。

    Dim i As Long
    Dim lr As Long
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    With Sheets("Sheet1") 'Change as needed
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row 'Lastrow
        For i = 1 To lr + 1
            If Not dict.exists(.Cells(i, 1).Value) Then 'Key doesn't exist
                dict.Add .Cells(i, 1).Value, .Cells(i, 2).Value 'Add key and first value
                If i > 1 Then 'Avoid out of range errors
                    dict(.Cells(i - 1, 1).Value) = .Cells(i - 1, 3).Value - dict(.Cells(i - 1, 1).Value) 'Subtract old value from new value
                End If
            End If
        Next i
        
        Dim key As Variant
        i = 1
        For Each key In dict
            .Cells(i, 6).Value = key 'place values
            .Cells(i, 7).Value = dict(key)
            i = i + 1
        Next key
    End With

Answer 2

这也使用字典，并且应该适用于多个列。

Option Explicit

Sub StuffDo()
Dim rng As Range
Dim arrData As Variant
Dim ky As Variant
Dim dicLetters As Object
Dim arrNumbers()
Dim cnt As Long
Dim idxCol As Long
Dim idxRow As Long

    arrData = Sheets("Sheet1").Range("A1").CurrentRegion.Value

    Set dicLetters = CreateObject("Scripting.Dictionary")

    For idxRow = LBound(arrData, 1) To UBound(arrData, 1)
        For idxCol = LBound(arrData, 2) + 1 To UBound(arrData, 2)
            ky = arrData(idxRow, 1)

            If Not dicLetters.exists(ky) Then
                arrNumbers = Array(arrData(idxRow, idxCol))
            Else
                arrNumbers = dicLetters(ky)
                cnt = UBound(arrNumbers) + 1
                ReDim Preserve arrNumbers(cnt)
                arrNumbers(cnt) = arrData(idxRow, idxCol)
            End If
            dicLetters(ky) = arrNumbers
        Next idxCol
    Next idxRow

    Set rng = Range("A1").Offset(, Range("A1").CurrentRegion.Columns.Count + 2)
    
    For Each ky In dicLetters.keys
        arrNumbers = dicLetters(ky)
        rng.Value = ky
        rng.Offset(, 1) = arrNumbers(UBound(arrNumbers))
        rng.Offset(, 2) = arrNumbers(0)
        Set rng = rng.Offset(1)
    Next ky
    
End Sub

​

​