VBA

Rows(1).Insert '在第1行前插入1行

Private Sub Worksheet_Activate()
    myrow = ActiveWorkbook.ActiveSheet.UsedRange.Rows.Count
    Dim idx As Integer
    Dim j As Integer
    idx = 4
    For j = 3 To myrow
        Debug.Print Worksheets("sheet2").Cells(j, 1).Value
        idx = processValue(idx, Worksheets("sheet2").Cells(j, 1))
    Next j
End Sub

Function processValue(idx As Integer, val As Range)
    Dim i As Integer
    Dim b As Boolean
    For i = 1 To idx
        b = Worksheets("sheet1").Cells(i, 1).Value = val.Value
        If b Then
            Worksheets("sheet1").Cells(i, 2).Value = Worksheets("sheet1").Cells(i, 2).Value + 1
            Exit For
        End If
    Next i
    If b Then
        processValue = idx
    Else
        Worksheets("sheet1").Cells(idx, 1).Value = val.Value
        Worksheets("sheet1").Cells(idx, 2).Value = 1
        processValue = idx + 1
    End If
End Function

Private Sub Worksheet_Activate()
    Application.ScreenUpdating = False
    Dim buffer As New Collection
    Dim index As Long
    Dim first As Long
    Dim last As Long
    Dim counter As Long
    Dim current As Range
    Dim ws As Worksheet
   
    first = 4
    Set ws = Application.Worksheets("基础数据表")
    last = ws.UsedRange.Rows.Count
       
    For counter = first To last
        Set current = ws.Range("D" & counter)
        Call analyze(buffer, current, counter)
    Next counter
    Application.ScreenUpdating = True
End Sub
Function analyze(ByRef buffer As Collection, ByRef cluster As Range, rownum As Long)
    Dim exist As Boolean
    Dim rowset As Collection
   
    exist = False
   
    If Not (IsError(cluster.value) Or IsEmpty(cluster.value) Or cluster.value = "") Then
    On Error GoTo nextStep
        Set rowset = buffer.Item(CStr(cluster.value))
        exist = True
nextStep:
    If Not exist Then
        Set rowset = New Collection
        buffer.Add rowset, CStr(cluster.value)
    End If
    rowset.Add rownum
End If
End Function