按开始年份自动填充缺失年份行

秦哥

单位里有大量的这样数据，要求按姓名，按开始年份到结束年份自动增加缺失年份的行。因为有上万行，不可能手工增加。特求助各位大神，在此谢谢了。

liulang0808

楼主结合附件再进一步描述下，补充日期的原则，是根据哪一列什么原则补充的
效果表对应关系看不大明白

秦哥

比方说某人开始年份是不一定的，开始时间取其姓名后的B列的开始时间，结束的年份都是2019年。例如一个人开始时间是2009年，其实际发生的只有2015-2018年，那么就要补齐2009年到2014年的行和2019年的行。
还有一些人实际发生的年并不连续，例如 实际发生了2015、2017、2018年，那么中间的2016年的行也要补上。

网海遨游

不知这样是否达到要求？

秦哥

网海遨游 发表于 2019-9-24 10:00
不知这样是否达到要求？

非常好，我研究一下，太谢谢你了。

liangmutou01

Sub bnf()
  Dim h As Long
  Set d = CreateObject("scripting.dictionary")
  Application.ScreenUpdating = False
  For h = [a65536].End(3).Row To 2 Step -1
    qh = hs(h)
    For n = Cells(qh, 2) To Cells(qh, 3)
      d(Trim(Str(n))) = 1
    Next n
    For Each n In d.keys
      Set qn = Range(Cells(qh, 4), Cells(h, 4)).Find(n)
      If qn Is Nothing Then
        Rows(h + 1).Insert xlShiftDown
        Cells(h + 1, 1) = Cells(qh, 1): Cells(h + 1, 1).Offset(0, 4) = "'" & n
      End If
    Next n
    d.RemoveAll
    h = h - (h - qh)
  Next h
  For h = 2 To [a65536].End(3).Row
    If Cells(h, 4) <> "" Then Cells(h, 5) = "'" & Cells(h, 4)
  Next h
  Range("a1:e" & [a65536].End(3).Row).Sort key1:="姓名", key2:="缺失时间", Header:=xlYes
  For h = 2 To [a65536].End(3).Row
    If Cells(h, 4) = "" Then
      Cells(h, 1) = ""
    Else
      Cells(h, 5) = ""
    End If
  Next h
  Application.ScreenUpdating = True
End Sub
Function hs(h As Long) As Long
  For i = h To 1 Step -1
    If Cells(i, 2) <> Cells(i - 1, 2) Then Exit For
  Next
  hs = i
End Function

秦哥

liangmutou01 发表于 2019-9-24 17:34
Sub bnf()
  Dim h As Long
  Set d = CreateObject("scripting.dictionary")

谢谢你的帮助，我用你的代码测试还是有点问题，楼上那位大师的非常完美。