宏用于在列范围内查找日期、插入行并粘贴数据

Question

我想要做的是有一个宏可以：

1. 检测页面（“原始”）上单元格的值（$E8，日期）
2. 转到另一个页面（“转移”），（页面名称各不相同，但相应的页面名称出现在“原始”$Z$1 中。）
3. 查看“转学”的 A 列，其中列出了每个星期一（日期范围从 A20 开始，文字如上）。
4. 查找 $E8 日期之前的星期一（因此对于 $E8 = 星期六 17 日，它将查找星期一 12 日）
5. 在星期一行下方插入一行（即在显示星期一 19 日的行之前）
6. 删除该行（因此该行为周一至 12 号、空白、周一至 19 号
7. 从（“原始 $E8”）剪切/复制范围 A8:H8
8. 进入“转账”页面
9. 将 A8:H8 选择内容插入到在第 5 处创建的行中。
10. 循环回去并对 $E9 执行相同的操作，直到所有信息都输入到“传输”中。

我提供的单元格是正确的单元格，是我刚刚编造的日期（无论如何，每个帐户的日期都不同）。

Eric非常好心的给我提供了我修改过的代码，如下：

 Public Sub do_stuff()
 Dim date_to_look_for As String
 Dim row As Integer

 date_to_look_for = Range("'Original'!K8").Value
                    '^L: This is the cell that you are reading from. Ensure it is the MONDAY formula
 row = 20
 '^L: This is where the Transfer date values start

 Do Until row = Range("'Transfer'!A1").End(xlDown).row + 1  'create our loop.
 'Notice that the .end function will find the end of the data in a column

If Range("'Transfer'!A" & row).Value = date_to_look_for Then
        '^L: Look for Original (X) Value specified above (make sure it's Monday).

    Range("'Transfer'!" & row + 1 & ":" & row + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
          '^L: Once

    Range("'Transfer'!A" & row + 1 & ":H" & row + 1).Value = Range("'Original'!A8:H8").Value

         '^L:This is WHERE it will paste                           '^L: This is what will copy
    Exit Sub 'no sense in running loop more if already found
End If
 row = row + 1
 Loop

 'If code gets here then the date was never found! so tack to end of list
 Dim endrow As Integer
 endrow = Range("'Transfer'!A1").End(xlDown).row

 Range("'Transfer'!A" & endrow & ":H" & endrow).Value = 
 Range("'Original'!A8:H8").Value
 '^L: What is this?

 End Sub

（L：信息是我在弄清楚每个部分的作用时做的笔记 - 如果我误解了，请随时纠正我。其他绿色的注释是 Eric 的，我不确定我是否理解了那些部分。不过，只要它能工作，我真的不需要，但如果你想教我编码，请随意 :D）

我现在的问题是如何让它循环，以便它按照原始值向下工作（在本例中是 K 列，因此它会转到 K9、K10 等，并执行相同的操作？另外，它可以剪切而不是复制，并在转移后从原始表中删除吗？

感谢所有提供帮助的人，你们太棒了！

Answer 1

这应该能满足您的要求。我注释了代码，以便您可以准确了解正在发生的事情。请注意，此代码使用 Range 类型变量，这意味着变量 rTransfer 和 rOriginal 引用工作表中的实际单元格。

希望这有帮助，祝你好运！

Sub TransferMyData()
'Declare the variables to be used in the code
Dim wsTransfer As Worksheet, wsOriginal As Worksheet
Dim rTransfer As Range, rOriginal As Range, rCopyRange As Range
Dim dMonday As Variant
Dim iRow As Integer

'Set the worksheet variable, this makes is easier than constantly referencing each sheet in the code all the time
Set wsTransfer = ThisWorkbook.Worksheets("Transfer")
Set wsOriginal = ThisWorkbook.Worksheets("Original")

'Set rOriginal to reference range E8, the first cell we are checking for a date to transfer
Set rOriginal = wsOriginal.Range("E8")

'Run this loop over and over until the cell referenced in rOriginal is blank.
'At the bottom of the loop we shift rOriginal down by one
Do While rOriginal <> ""
    'Find the Monday of the week for rOriginal
    dMonday = rOriginal - Weekday(rOriginal, 3)

    'Format dMonay to match the Transfer worksheet - Commented out
    'dMonday = Format(dMonday, "dd-mm-yy")

    'Set the cell of rTransfer using the Find function (Search range A:A in wsTransfer for the monday we figured out above)
    Set rTransfer = wsTransfer.Range("A:A").Find(dMonday)

    'Error check. If rTransfer returns nothing then no match was found
    If rTransfer Is Nothing Then
        MsgBox ("Can't find the Monday for ") & rOriginal & ". Searching for Value " & dMonday
        Exit Sub
    End If

    'Check if there was already some data transfered in for that week (rTransfer.Offset(1,4) references the 'E' column of the row below).
    'If there is a value there, shift down by one and check again
    Do Until rTransfer.Offset(1, 4) = ""
        Set rTransfer = rTransfer.Offset(1, 0)
    Loop

    'Insert a blank row below rTransfer using the offset function
    rTransfer.Offset(1, 0).EntireRow.Insert

    'Set iRow to be the row number of rOriginal to be used below
    iRow = rOriginal.Row

    'Set the range rCopyRange to be the range A:H of the row for iRow (See https://www.mrexcel.com/forum/excel-questions/48711-range-r1c1-format-visual-basic-applications.html for explanation)
    Set rCopyRange = wsOriginal.Range(Cells(iRow, 1).Address, Cells(iRow, 8).Address)

    'Copy the range rCopyRange into the blank row we added
    rCopyRange.Copy rTransfer.Offset(1, 0)

    'Offset our rOriginal cell down by one and restart the loop
    Set rOriginal = rOriginal.Offset(1, 0)

    'Clear out the copied range. Can replace with rCopyRange.Delete if you want to delete the cells and have everything shift up
    rCopyRange.Clear

    'Simple error check, if for some reasone you're stuck in an endless loop this will break out
    If rOriginal.Row > 999 Then
        MsgBox "Error! Stuck in Loop!"
        Exit Sub
    End If
Loop

End Sub

Answer 2

因此，这里有一个我认为可以概括您一般要做的事情的例子。我在工作簿上设置了两个标签，分别标记为“转移”和“原始”。我将“原始”选项卡设置为如下所示：

A、B、C、D 中的数据实际上并不重要。我有 F 列和 G 列来确定哪个日期是“上一个星期一”。这当然可以在一个单元格中完成，但我将其分开，以便您更好地理解。因此，在此示例中，我的 F2 单元格具有 =WEEKDAY(A2)-2，因为 WEEKDAY 函数以数字形式返回星期几。我将 G2 设置为 =A2-F2 以实际显示“上一个星期一的日期”。

我的转帐单如下所示：

因此，从这里开始，我们必须让宏从“转移”选项卡中查找哪一行是最后一个星期一的日期。我们还必须确保它存在。在我的示例中，如果它不存在，我会将其粘贴到底部...

这是我为我的例子所写的，其中包含很多评论：

Public Sub do_stuff()
Dim date_to_look_for As String
Dim row As Integer

date_to_look_for = Range("'Original'!G2").Value
row = 2 'whichever row is your start row for the data on the Transfer tab

Do Until row = Range("'Transfer'!A1").End(xlDown).row + 1  'create our loop.
'Notice that the .end function will find the end of the data in a column

    If Range("'Transfer'!A" & row).Value = date_to_look_for Then
        'row found for Monday! Do our magic here!

        'insert a blank spot at the row found + 1
        Range("'Transfer'!" & row + 1 & ":" & row + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        'now copy data here
        Range("'Transfer'!A" & row + 1 & ":E" & row + 1).Value = Range("'Original'!A2:E2").Value
        Exit Sub 'no sense in running loop more if already found
    End If
row = row + 1
Loop

'If code gets here then the date was never found! so tack to end of list
Dim endrow As Integer
endrow = Range("'Transfer'!A1").End(xlDown).row

Range("'Transfer'!A" & endrow & ":E" & endrow).Value = 
Range("'Original'!A2:E2").Value

End Sub

请注意我如何使用 Range().value 函数一次性复制数据，还请注意我如何指定范围。

运行上面显示的宏后，您应该在“传输”选项卡中看到以下内容：