Question

我在列中有日期。每个日期由8个单元格分隔，这8个单元格为空。我期待用第一个日期填充8个空单元格到达下一个日期时，我希望在下一个日期清空接下来的8个空白单元格，然后重复，直到达到最后一个日期，之后以下8个空单元格填充最后一个日期。

我不认为我的问题很清楚，因为我还没有正确的答案

应该变成

这是我从whyq的quickandfun方法获得的输出

我也尝试将公式更改为

.Value = "=R[-1]C1"

求助于以下答案

lastRow1 = Sheets(myValue).Cells(Sheets(myValue).Rows.Count, "B").End(xlUp).Row + 7

For r = 2 To lastRow1
If Sheets(myValue).Cells(r, 2) = vbNullString Then
Sheets(myValue).Cells(r, 2) = Sheets(myValue).Cells(r, 2).Offset(-1, 0)

End If
Next

Answer 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

注意： 此代码不限于连续8个空单元格！

Answer 2

不太漂亮：

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

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

2 个答案: