Question

以下是我的Excel数据摘录

A   20160101
A   20160104
A   20160105
A   20160106
A   20160107
AA  20160108
AA  20160111
AA  20160112
AA  20160113
AA  20160114
AA  20160115
AA  20160118
AB  20160119
AB  20160120
AB  20160121
AB  20160122
AB  20160125
AB  20160126
AB  20160127
AB  20160128

就像我有超过10,000行

我正在尝试打印每个组的姓名，第一个日期，最后日期，例如

a  20160101 20160107   
aa 20160108 20160118
ab 20160119 20160128

我的代码

Sub stock_1():
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    for i = 2 To LastRow
        If Cells(i + 1, 1).Value <> Cells(i, 1).Value Then
            Set MyRange = Range("a" & i)
            LastRow_1 = MyRange.Row + MyRange.Rows.Count - 1
            firstRow = MyRange.row
end sub

我正在获得每个组的最后一行，但没有获得每个组的第一行。请检查并建议

Answer 1

删除/添加行时的技巧是，您需要从结尾（最后一行到第一行）开始循环，因为否则添加/删除行会更改行计数，您的循环计数错误。

以下是它的工作原理：

它开始从结尾lRow向后循环fRow。它会记住该行的值lVal并删除连续的行，直到A列中的值发生更改，然后将lVal写入C列，记住下一个lVal并继续。

Option Explicit

Public Sub CombineConsecutiveValues()
    Dim ws As Worksheet
    Set ws = ActiveSheet 'better define the workbook ThisWorkbook.Worksheets("Sheet1")

    Dim lRow As Long 'find last row
    lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim lVal As Variant 'remember last value (stop value)
    lVal = ws.Cells(lRow, "B").Value

    Const fRow As Long = 2 'define first data row
    Dim i As Long
    For i = lRow To fRow Step -1 'loop from last row to first row backwards

       If i <> fRow Then 'if we are on the first row there is no value before
            If ws.Cells(i, "A").Value = ws.Cells(i - 1, "A").Value Then 'if current value is same as one before
                ws.Rows(i).Delete 'delete current row
            Else
                ws.Cells(i, "C").Value = lVal 'write stop value in column B
                lVal = ws.Cells(i - 1, "B").Value 'remember next new stop value
            End If
       Else
            ws.Cells(i, "C").Value = lVal 'write stop value in column B (on first row)
       End If
    Next i
End Sub

Answer 2

你可以发布词典：

Option Explicit

Sub main()
    Dim vals As Variant
    Dim iVal As Long

    vals = Application.Transpose(Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value)

    With New Scripting.Dictionary
        For iVal = 1 To UBound(vals)
            .Item(vals(iVal)) = iVal
        Next

        Range("A1").Offset(0, 2).Resize(, 3) = Array(.Keys(0), Range("B1"), Range("B1").Offset(.Item(.Keys(0)) - 1))
        For iVal = 1 To UBound(.Keys)
            Range("A1").Offset(iVal, 2).Resize(, 3) = Array(.Keys(iVal), Range("B1").Offset(IIf(iVal = 0, 0, .Item(.Keys(iVal - 1)))), Range("B1").Offset(.Item(.Keys(iVal)) - 1))
        Next
    End With
End Sub

只需添加对＃34; Microsoft Scripting Runtime＆＃34;的引用库（在VBA IDE中单击工具 - ＆gt;参考 - ＆gt;滚动列表框并选择＆＃34; Microsoft Scripting Runtime＆＃34; - ＆gt;单击OK）

实际上，这样一种方法可以加快这一切：

避免IF-Then-Else阻止
使用数组限制范围访问

Answer 3

以下是代码的修改版本（使用ption Explicit并删除所有变量！）

Option Explicit
Sub stock_1()
    Dim LastRow As Long, i As Long, StartDate As String, EndDate As String, CellValue As String, Letters As String

    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    CellValue = Cells(1, 1).Value
    Letters = Left(CellValue, InStr(1, CellValue, " ") - 1)
    StartDate = Right(CellValue, Len(CellValue) - InStr(1, CellValue, " ") + 1)

    For i = 2 To LastRow
        CellValue = Cells(i, 1).Value
        If Letters <> Left(CellValue, InStr(1, CellValue, " ") - 1) Then
            Cells(i - 1, 2).Value = Letters
            Cells(i - 1, 3).Value = StartDate
            Cells(i - 1, 4).Value = EndDate
            StartDate = Right(CellValue, Len(CellValue) - InStr(1, CellValue, " ") + 1)
        Else
            EndDate = Right(CellValue, Len(CellValue) - InStr(1, CellValue, " ") + 1)
        End If
        Letters = Left(CellValue, InStr(1, CellValue, " ") - 1)
    Next

    Cells(i - 1, 2).Value = Letters
    Cells(i - 1, 3).Value = StartDate
    Cells(i - 1, 4).Value = EndDate
End Sub

Answer 4

试试此代码

Sub Test()
Dim a           As Variant
Dim r           As Range
Dim i           As Long
Dim s           As Long
Dim k           As Long

With Sheets("Sheet1")
    With .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row + 1)
        a = .Value: s = 1

        For i = LBound(a) To UBound(a) - 1
            If a(i, 1) <> a(i + 1, 1) Then
                Set r = .Range("A" & s).Resize(i - s + 1)

                k = k + 1
                .Range("D" & k).Value = r(1).Value
                .Range("E" & k).Value = r(1).Offset(, 1).Value
                .Range("F" & k).Value = r(r.Rows.Count).Offset(, 1).Value

                s = i + 1
            End If
        Next i
    End With
End With
End Sub

Answer 5

我建议将数据读入数组，然后将所需的值放入类似

的字典中

Option Explicit

Sub GetData()
Dim rg As Range
Dim vDat As Variant
Dim i As Long, nextIndex As Long, prevIndex As Long
Dim dict As Scripting.Dictionary

    Set rg = Range("A1:B20")
    Set dict = New Scripting.Dictionary

    vDat = rg
    nextIndex = LBound(vDat) + 1
    prevIndex = LBound(vDat) - 1

    For i = LBound(vDat) To UBound(vDat)

        If i = LBound(vDat) Then
            dict.Add vDat(i, 1), vDat(i, 2)
        End If
        If nextIndex <= UBound(vDat) Then
            If vDat(nextIndex, 1) = vDat(i, 1) Then
            Else
                dict(vDat(i, 1)) = dict(vDat(i, 1)) & ";" & vDat(i, 2)
            End If
        End If
        If prevIndex >= LBound(vDat) Then
            If vDat(prevIndex, 1) = vDat(i, 1) Then
            Else
                dict.Add vDat(i, 1), vDat(i, 2)
            End If
        End If

        If nextIndex > UBound(vDat) Then
            dict(vDat(i, 1)) = dict(vDat(i, 1)) & ";" & vDat(i, 2)
            'Exit For
        End If

        nextIndex = nextIndex + 1
        prevIndex = prevIndex + 1
    Next i

    Dim key As Variant
    For Each key In dict.Keys
        Debug.Print key, dict(key)
    Next key

End Sub

如何查找组的第一行和最后一行

5 个答案: