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

Posted 2023-03-27

【中文标题】选择字符串值子集中的第一个和最后一个值

【英文标题】：Select the First and Last Values in a Subset of String Values

【发布时间】：2022-01-23 20:53:34

【问题描述】：

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

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

谢谢。

【问题讨论】：

必须是VBA吗？如果您有 Office 365，则可以使用公式；或者，根据您的项目的性质，这是 Power Query 的一项简单任务（在 Excel 2010+ 中可用

【参考方案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

【参考方案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