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

Vba 如何查找组的第一行和最后一行,vba,excel,Vba,Excel,下面是我的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 A

下面是我的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
就像我有超过10000行

我试着打印每个小组的名字,第一个日期,最后一个日期

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
子库存_1():
使用ActiveSheet
LastRow=.Cells(.Rows.Count,“A”).End(xlUp).Row
以
对于i=2到最后一行
如果单元格(i+1,1)。给单元格(i,1)赋值。然后给单元格赋值
设置MyRange=Range(“a”和“i”)
LastRow_1=MyRange.Row+MyRange.Rows.Count-1
firstRow=MyRange.row
端接头
我得到每组的最后一行,但不是每组的第一行。
请检查并建议

删除/添加行时的技巧是,需要从末尾(最后一行到第一行)开始循环,否则添加/删除行会更改行数,循环计数错误

以下是它的工作原理:

它开始从末尾
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
选项显式
公共子组合secutivevalues()
将ws设置为工作表
设置ws=ActiveSheet'更好地定义工作簿ThisWorkbook.Worksheets(“Sheet1”)
只要“找到最后一行”,就将lRow变暗
lRow=ws.Cells(ws.Rows.Count,“A”).End(xlUp).Row
尺寸lVal作为变量“记住最后一个值(停止值)
lVal=ws.Cells(lRow,“B”).值
Const fRow As Long=2'定义第一个数据行
我想我会坚持多久
对于i=lRow To fRow Step-1'循环,从最后一行向后循环到第一行
如果我在前面,那么‘如果我们在第一行,前面就没有价值了。’
如果ws.Cells(i,“A”).Value=ws.Cells(i-1,“A”).Value,那么“如果当前值与之前的值相同
ws.Rows(i).删除“删除当前行”
其他的
ws.Cells(i,“C”).Value=lVal'在B列中写入停止值
lVal=ws.Cells(i-1,“B”).Value‘记住下一个新的停止值’
如果结束
其他的
ws.Cells(i,“C”).Value=lVal'在B列(第一行)中写入停止值
如果结束
接下来我
端接头

删除/添加行的诀窍是,需要从末尾(最后一行到第一行)开始循环,否则添加/删除行会更改行数,循环计数错误

以下是它的工作原理:

它开始从末尾
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
选项显式
公共子组合secutivevalues()
将ws设置为工作表
设置ws=ActiveSheet'更好地定义工作簿ThisWorkbook.Worksheets(“Sheet1”)
只要“找到最后一行”,就将lRow变暗
lRow=ws.Cells(ws.Rows.Count,“A”).End(xlUp).Row
尺寸lVal作为变量“记住最后一个值(停止值)
lVal=ws.Cells(lRow,“B”).值
Const fRow As Long=2'定义第一个数据行
我想我会坚持多久
对于i=lRow To fRow Step-1'循环,从最后一行向后循环到第一行
如果我在前面,那么‘如果我们在第一行,前面就没有价值了。’
如果ws.Cells(i,“A”).Value=ws.Cells(i-1,“A”).Value,那么“如果当前值与之前的值相同
ws.Rows(i).删除“删除当前行”
其他的
ws.Cells(i,“C”).Value=lVal'在B列中写入停止值
lVal=ws.Cells(i-1,“B”).Value‘记住下一个新的停止值’
如果结束
其他的
ws.Cells(i,“C”).Value=lVal'在B列(第一行)中写入停止值
如果结束
接下来我
端接头

这是您的代码的修改版本(使用
并删除所有变量!)

选项显式
子库存_1()
Dim LastRow为长,i为长,StartDate为字符串,EndDate为字符串,CellValue为字符串,字母为字符串
使用ActiveSheet
LastRow=.Cells(.Rows.Count,“A”).End(xlUp).Row
以
CellValue=单元格(1,1)。值
字母=左(CellValue,InStr(1,CellValue,“”)-1)
StartDate=右(CellValue,Len(CellValue)-InStr(1,CellValue,“”)+1)
对于i=2到最后一行
CellValue=单元格(i,1)。值
如果字母为左(CellValue,InStr(1,CellValue,“”)-1),则
单元格(i-1,2)。值=字母
单元格(i-1,3)。值=起始日期
单元格(i-1,4)。值=结束日期
StartDate=右(CellValue,Len(CellValue)-InStr(1,CellValue,“”)+1)
其他的
EndDate=右(CellValue,Len(CellValue)-InStr(1,CellValue,“”)+1)
如果结束
字母=左(CellValue,InStr(1,CellValue,“”)-1)
下一个
单元格(i-1,2)。值=字母
单元格(i-1,3)。值=起始日期
单元格(i-1,4)。值=结束日期
端接头

这是您的代码的修改版本(使用
并删除所有变量!)

选项显式
子库存_1()
Dim LastRow为长,i为长,StartDate为字符串,EndDate为字符串,CellValue为字符串,字母为字符串
使用ActiveSheet
LastRow=.Cells(.Rows.Count,“A”).End(xlUp).Row
以
CellValue=单元格(1,1)。值
字母=左(CellValue,InStr(1,CellValue,“”)-1)
StartDate=右(CellValue,Len(CellValue)-InStr(1,CellValue,“”)+1)
对于i=2到最后一行
CellValue=单元格(i,1)。值
如果字母为左(CellValue,InStr(1,CellValue,“”)-1),则
单元格(i-1,2)。值=字母
单元格(i-1,3)。值=起始日期
单元格(i-1,4)。值=结束日期
StartDate=右侧(单元格值,
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
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
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