VBA使用今天的日期并粘贴数据，在“月”列中选择最后一个空单元格

Question

I'm trying to use VBA script to trigger when checkbox is checked that copies data from one particular cell and pastes in the last empty cell of Month column using Today's date. Here is my code thus far, and I've tested the check box triggering the copy and paste function. What I can't figure out is finding the correct column using today's date and selecting the next empty cell in that column. My columns are labeled on a second sheet using long month names (text data).

Sub CheckBoxUpdated()
Dim Mnth As String
Dim fndrng
Dim cb As CheckBox


Mnth = MonthName(Month(Date))
With Sheet2 'has to be 'with' something to work correctly
    Set fndrng = Cells.Find(What:=Mnth, After:=A1, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=True)
End With

    On Error Resume Next
    Set cb = ActiveSheet.DrawingObjects(Application.Caller)
    On Error GoTo 0

    If Not cb Is Nothing Then
        If cb.Value = 1 Then
            Sheets("Sheet1").Range(cb.LinkedCell).Offset(0, -4).Copy
            Sheets("Sheet2").Activate
            fndrng.Offset(4, 0).Select
            ActiveSheet.Paste
        End If
    End If

End Sub

Any help is much appreciated, thanks!!!!

Answer 1

Two things I noticed immediately.

1. Within your first With...End With statement , the Set fndrng = Cells.Find ... is missing the prefix period that assigns the worksheet parent from the With statement. Should be Set fndrng = .Cells.Find...

2. The close of the With Sheet2 could be extended down to encompass much more of the code, releasing you from dependence on things like ActiveSheet and Select .

Consider this rewrite.

Sub CheckBoxUpdated()
    Dim Mnth As String, fndrng as range, cb As CheckBox

    On Error Resume Next

    Mnth = MonthName(Month(Date))

    With Sheet2 'has to be 'with' something to work correctly
        Set fndrng = Cells.Find(What:=Mnth, After:=A1, LookAt:=xlPart, _
                                SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                MatchCase:=True)

        Set cb = .DrawingObjects(Application.Caller)
        On Error GoTo 0

        If Not cb Is Nothing Then
            If cb.Value = 1 Then
                Sheets("Sheet1").Range(cb.LinkedCell).Offset(0, -4).Copy _
                    Destination:=fndrng.Offset(4, 0)
            End If
        End If

    End With

End Sub

I changed your method of Copy & Paste to a more direct method in keeping with the expansion of the With/End With statement.

See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.