使excel vba根据自定义条件在行之间插入自定义数据行数

Question

我不确定如何解释这个问题，但我会尽我所能解释我需要完成的逻辑。希望在这个网站的任何辉煌的人可以投入一些想法:)

我有数据记录，其中包含有关不同项目的信息。每行都包含项目信息，例如项目名称，创建日期项目，完成日期项目，项目完成的估计日期以及插入/更新估计的时间戳。如果项目具有更新的项目完成预计日期，则将此更新记录在新行中。这就是数据在excel中的样子。

我需要擅长以检查是否有一天，在预计完成日期（即该项目停留在轨道），那么出类拔萃，直到达到一天一个包含更新创建行没有变化通过。下面的图片显示了我需要如何根据上面的初始行添加自定义行。

请让帮我出任何想法.. VBA建议。

Answer 1

我相信这应该实现自己的目标：

Sub FillCompletionDays() 

Dim LLoop As Long 
Dim LLRow As Long 
Dim DateEnd As Date 
Dim DateNext As Date 
Dim DateNow As Date 

LLoop = Range("A:A").Find(what:="Project name").Row + 1 
LLRow = Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row 

If LLRow <= LLoop Then Exit Sub 

Do 
    'Only proceed if there is a valid date in column E 
    If Range("E" & LLoop).Value2 <> vbNullString Then 
     DateNow = Range("E" & LLoop).Value2 
     DateEnd = Range("C" & LLoop).Value2 
     'Check if another date is needed 
     If DateEnd > DateNow Then 
      'Check if next row is this project 
      If Range("A" & LLoop + 1).Value2 = Range("A" & LLoop).Value2 Then 
       'Check if a new date is needed 
       DateNext = DateSerial(Year(Range("E" & LLoop + 1).Value2), Month(Range("E" & LLoop + 1).Value2), _ 
       Day(Range("E" & LLoop + 1).Value2)) 
       If DateNext <> DateNow + 1 Then 
        'Insert a row 
        Rows(LLoop + 1).Insert shift:=xlShiftDown 
        Range("A" & LLoop + 1 & ":D" & LLoop + 1).Value2 = Range("A" & LLoop & ":D" & LLoop).Value2 
        Range("E" & LLoop + 1).Value2 = DateNow + 1 
        Range("B" & LLoop + 1 & ": E" & LLoop + 1).NumberFormat = "yyyy-mm-dd" 
        LLRow = LLRow + 1 
       End If 

      Else 
       'Next row is another project; insert a row for this one 
       Rows(LLoop + 1).Insert shift:=xlShiftDown 
       Range("A" & LLoop + 1 & ":D" & LLoop + 1).Value2 = Range("A" & LLoop & ":D" & LLoop).Value2 
       Range("E" & LLoop + 1).Value2 = DateNow + 1 
       Range("B" & LLoop + 1 & ": E" & LLoop + 1).NumberFormat = "yyyy-mm-dd" 
       LLRow = LLRow + 1 
      End If 
     End If 
    End If 
    LLoop = LLoop + 1 
Loop Until LLoop > LLRow 

End Sub 

Answer 2

这里是答案编辑@Nick Peranzi回答适合我的请求后，我的问题，我不知道如何标记/提他，但是这是他的用户链接 https://stackoverflow.com/users/5472502/nick-peranzi

Sub FillCompletionDays() 

Dim LLoop As Long 
Dim LLRow As Long 
Dim DateEnd As Date 
Dim DateNext As Date 
Dim DateNow As Date 

LLoop = Range("A:A").Find(what:="Project name").Row + 1 
LLRow = Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row 

If LLRow <= LLoop Then Exit Sub 

Do 
'Only proceed if there is a valid date in column E 
If Range("E" & LLoop).Value2 <> vbNullString Then 
    DateNow = DateSerial(Year(Range("E" & LLoop).Value2), Month(Range("E" & LLoop).Value2), _ 
      Day(Range("E" & LLoop).Value2)) 
    DateEnd = DateSerial(Year(Range("D" & LLoop).Value2), Month(Range("D" & LLoop).Value2), _ 
      Day(Range("D" & LLoop).Value2)) 
    'Check if another date is needed 
    If DateEnd > DateNow Then 
     'Check if next row is this project 
     If Range("A" & LLoop + 1).Value2 = Range("A" & LLoop).Value2 Then 
      'Check if a new date is needed 
      DateNext = DateSerial(Year(Range("E" & LLoop + 1).Value2), Month(Range("E" & LLoop + 1).Value2), _ 
      Day(Range("E" & LLoop + 1).Value2)) 
      If DateNext = DateNow Then 
      Else 
      If DateNext <> DateNow + 1 Then 
       'Insert a row 
       Rows(LLoop + 1).Insert shift:=xlShiftDown 
       Range("A" & LLoop + 1 & ":D" & LLoop + 1).Value2 = Range("A" & LLoop & ":D" & LLoop).Value2 
       Range("E" & LLoop + 1).Value2 = DateNow + 1 
       Range("B" & LLoop + 1 & ": E" & LLoop + 1).NumberFormat = "yyyy-mm-dd" 
       LLRow = LLRow + 1 
      End If 
      End If 

     Else 
      'Next row is another project; insert a row for this one 
      Rows(LLoop + 1).Insert shift:=xlShiftDown 
      Range("A" & LLoop + 1 & ":D" & LLoop + 1).Value2 = Range("A" & LLoop & ":D" & LLoop).Value2 
      Range("E" & LLoop + 1).Value2 = DateNow + 1 
      Range("B" & LLoop + 1 & ": E" & LLoop + 1).NumberFormat = "yyyy-mm-dd" 
      LLRow = LLRow + 1 
     End If 
    End If 
End If 
LLoop = LLoop + 1 
Loop Until LLoop > LLRow 


End Sub