将细胞复制到下一个日期并重复

2 回答

• 1

  不是很漂亮：

  Sub eightAtATime()
  
  dim colLetter as string
  colLetter = "A"
  
  Dim r As Integer
  With ThisWorkbook.ActiveSheet
     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  End With
  
  Do Until r < 1
      Range(colLetter  & r + 1 & ":" & colLetter  & r + 8) = Range(colLetter & r)
      r = r - 9
  Loop
  
  End Sub
  

  虽然以下内容更有趣，但是无论是否为8个单元格都会填补空白：尽管它假定在最后一个单元格之后填充8：

  Sub quickAndFun()
  
  Dim lastRow As Integer
  With ThisWorkbook.ActiveSheet
     lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
  End With
  
  With Range("A1:A" & lastRow + 8).SpecialCells(xlCellTypeBlanks)
      .Value = "=R[-1]C1"
  End With
  
  End Sub
  

  如果第一个单元格是 B3 ，那么试试这个：

  Sub quickAndFun()
  
  Dim lastRow As Integer
  With ThisWorkbook.ActiveSheet
     lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
  End With
  
  With Range("B3:B" & lastRow + 8).SpecialCells(xlCellTypeBlanks)
      .Value = "=R[-1]C2" '<<<<now ok as it need to reference Column 2
  End With
  
  End Sub
  

  回复于 2024-05-03T22:51:50+08:00
• 1

  这样的事情应该做的工作：

  Dim wsh As Worksheet
  Dim i As Integer, sCol As String
  Dim cd Date, dd As Date
  
  'column name which stores dates
  sCol = "A"
  cd = Date 'get current date
  'Replace "Sheet1" with proper sheet name
  Set wsh = ThisWorkbook.Worksheets("Sheet1")
  'starting row
  i = 1 'if the first date is in 1. row
  'get first date
  dd = CDate(wsh.Range(sCol & i))
  'till the date from cell is less then current date 
  Do While dd<cd
      'till the next cell is empty
      Do While wsh.Range(sCol & i+1)=""
          wsh.Range(sCol & i) = dd
          i = i + 1
      Loop
      'get next date
      dd = CDate(wsh.Range(sCol & i))
  Loop
  
  'here add another loop, you have to define condition to recognize last empty cell - as whytheq mentioned in the comment to the my answer
  
  Set wsh = Nothing
  

  Note: 此代码不限于连续8个空单元格！

  回复于 2024-05-03T22:51:50+08:00