Question

我正在尝试使用VBA要求用户输入日期。在该日期，复制所有约会并将其逐一粘贴到“ Daily Appts”表中。我的参考表包含了与给定日期相对应的所有数据，被称为“ Appts”。我附上一张图片供参考。为此，我创建了工作表“ Daily Sheet”，并将标题从“ Appts”复制并粘贴到其上。我试图获取输入的日期的每个值，以将其复制并粘贴到新工作表上，但我遇到了麻烦。例如，如果用户输入10/01/2018，它将有多组数据需要复制。这是我到目前为止所拥有的。第6步是我需要帮助才能完成任务的地方。 1：https://i.stack.imgur.com/vEtUd.png

'Step 1:
Sub Part2()
Dim sheet As Variant
'Step 2: Add code to delete sheet "Daily Appts", if exist.
    For Each sheet In ActiveWorkbook.Worksheets
        If sheet.Name = "Daily Appts" Then
            Application.DisplayAlerts = False
            Worksheets("Daily Appts").Delete
            Application.DisplayAlerts = True
        End If
    Next sheet 
'Step 3: Add code to add a new sheet, name it "Daily Appts"
    Sheets("Main").Select
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Select
    ActiveSheet.Name = "Daily Appts"
    Sheets("main").Select
'Step 4: Add code to select the worksheet "Appts". Name the range that holds             
'the title (first row), the range that contains the data, and the range 
'contains the schedule.
Sheets("Appts").Select
Dim Title As Range, Data As Range, Schedule As Range
    Set Title = Range("A1", Range("A1").End(xlToRight))
    Title.Name = "Title"

    Set Data = Range("A2", Range("A2").End(xlDown).End(xlToRight))
    Data.Name = "Data"

    Set Schedule = Range("J2", Range("J2").End(xlDown))
    Schedule.Name = "Schedule"


'Step 5: Add code to copy and paste the title into the new sheet, "Daily         
'Appts".
    Sheets("Appts").Range("Title").Copy 'Copy the data
    Sheets("Daily Appts").Activate 'Activate the destination worksheet
    Range("A1").Select 'Select the target range
    ActiveSheet.Paste 'Paste in the target destination

    Application.CutCopyMode = False
'Step 6: Ask the user to enter a date.  For that date, copy all appointments     
'and paste them on sheet "Daily Appts", one-by-one.
Dim result As String, i As Long, mydate As Date
Sheets("Appts").Select
    result = InputBox("Enter a date")

    For i = 2 To 360
        mydate = Cells(i, 10)
        If mydate = result Then
        Sheets("Appts").Range("J2").End(xlToLeft).Copy
        Sheets("Daily Appts").Activate
        Range("A2").End(xlDown).Select
        ActiveSheet.Paste
        End If
    Next
End Sub

Answer 1

没有理由循环测试单个表是否存在，如果单元格引用有效，则进行简单测试即可：

If Not IsError(Application.Evaluate("'Daily Appts'!A1")) Then Worksheets("Daily Appts").Delete

还通过在添加项上声明一个工作表变量，使以后使用该表更容易：

Dim ws As Worksheet
Set ws = Worksheets.Add(After:=Worksheets("Main"))
ws.Name = "Daily Appts"

然后，当您创建范围时就不需要range.name，因为变量只是引用它们。

然后在循环中需要迭代复制范围。

我还清理了.Activate和.Select，应该避免。

Sub Part2()

'Step 2: Add code to delete sheet "Daily Appts", if exist.
    If Not IsError(Application.Evaluate("'Daily Appts'!A1")) Then Worksheets("Daily Appts").Delete
'Step 3: Add code to add a new sheet, name it "Daily Appts"
    Dim ws As Worksheet
    Set ws = Worksheets.Add(After:=Worksheets("Main"))
    ws.Name = "Daily Appts"
'Step 4: Add code to select the worksheet "Appts". Name the range that holds
'the title (first row), the range that contains the data, and the range
'contains the schedule.

    With Worksheets("Appt")
        Dim lCol As Long
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

        Dim lRow As Long
        lRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        Dim Title As Range
        Set Title = .Range(.Cells(1, 1), .Cells(1, lCol))

'Step 5: Add code to copy and paste the title into the new sheet, "Daily
'Appts".
        Title.Copy ws.Range("A1") 'Paste in the target destination

'Step 6: Ask the user to enter a date.  For that date, copy all appointments
'and paste them on sheet "Daily Appts", one-by-one.
        Do
            Dim result As String
            result = InputBox("Enter a date")
            If Not IsDate(result) Then MsgBox ("must be date")
        Loop Until IsDate(result)

        For i = 2 To lRow
            If .Cells(i, 10).Value2 = CDate(result) Then
                .Range(.Cells(i, 1), .Cells(i, lCol)).Copy ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1)
            End If
        Next
    End With
End Sub

VBA将相应的数据复制并粘贴到新工作表上

1 个答案: