基于输入框的单元格复制-VBA

我有两个文件，一个是完整的数据（input.xlsx），另一个是需要复制到其中的最终报告（Final Report.xlsm）。在input.xlsx中，A列有日期，E列有名称列表

我试图做的是根据两个标准从“input.xlsx”复制单元格（通过宏）。我的标准是日期（a栏）和姓名列表（E栏）

我已经尝试了下面的代码。我从Final Report.xlsm运行这段代码，它工作正常，但我需要的是能够通过消息框输入日期，而不是硬编码，类似地，名称也将出现在Final Report.xlsm中sheet3的a列中。它需要通过sheet3的A列中的日期和名称的消息框选择标准，因为名称不断变化，并且有100多个名称

请让我知道如何修改此代码

我的代码：

Sub Generate()
  Workbooks.Open Filename:= _
   "E:\Resource\Input.xlsx"

  Sheets("NewInput").Select

  Range("A1").Select

  Selection.AutoFilter
  ActiveSheet.Range("$A$1:$M$49000").AutoFilter Field:=1, Criteria1:="3/1/2017"
  ActiveSheet.Range("$A$1:$M$49000").AutoFilter Field:=5, Criteria1:="John, Henry, Jacob"
  Cells.Select
  Selection.Copy
  Windows("Final Report.xlsm").Activate
  Sheets("Sheet1").Select
  Range("A1").Select
  ActiveSheet.Paste
  Application.CutCopyMode = False
End Sub

---

首先：避免使用

Select

和

Activate

方法。见：

试试这个：

Option Explicit

Sub Generate()
'declare variables
Dim srcWbk As Workbook, dstWbk As Workbook
Dim srcWsh As Worksheet, dstWsh As Worksheet
Dim sDate As String, dDate As Date
Dim i As Integer

'on error go to error handler
On Error GoTo Err_Generate

    'initiate variables
    'source workbook and worksheet
    Set srcWbk = Workbooks.Open(Filename:="E:\Resource\Input.xlsx")
    Set srcWsh = srcWbk.Worksheets("NewInput")
    'destination workbook and worksheet
    Set dstWbk = ThisWorkbook '=> "Final Report.xlsm
    Set dstWsh = dstWbk.Worksheets("Sheet1")

    'prompt a user for date, max. 3 times
    While sDate = ""
        sDate = InputBox("Enter a date. Use 'mm/dd/yyyy' format!", "Enter date...", Date)
        If sDate <> "" Then dDate = CDate(sDate) 'this part you may want to improve. Using Regex will be very good solution!
        i = i + 1
        If i = 3 Then
            MsgBox "You canceled entering date 3. times!", vbInformation, "Info..."
            GoTo Exit_Generate
        End If
    Loop

    'filter and copy data
    srcWsh.Range("$A$1:$M$49000").AutoFilter Field:=1, Criteria1:=dDate
    srcWsh.Range("$A$1:$M$49000").AutoFilter Field:=5, Criteria1:="John, Henry, Jacob"
    srcWsh.Cells.Copy
    dstWsh.Range("A1").Paste
    Application.CutCopyMode = False


Exit_Generate:
    On Error Resume Next
    'clean up
    Set srcWsh = Nothing
    If srcWbk Is Not Nothing Then srcWbk.Close SaveChanges:=False
    Set srcWbk = Nothing
    Set dstWhs = Nothing
    Set dstWbk = Nothing
    Exit Sub

Err_Generate:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_Generate
End Sub

选项显式
子生成（）
'声明变量
将srcWbk作为工作簿，将dstWbk作为工作簿
Dim srcWsh作为工作表，dstWsh作为工作表
Dim sDate作为字符串，dDate作为日期
作为整数的Dim i
'出错时转到错误处理程序
发生错误时转到Err_生成
'启动变量
'源工作簿和工作表
设置srcWbk=Workbooks.Open（文件名：=“E:\Resource\Input.xlsx”）
设置srcWsh=srcWbk.Worksheets（“NewInput”）
'目标工作簿和工作表
设置dstWbk=thiswoolk'=>“Final Report.xlsm
设置dstWsh=dstWbk.工作表（“表1”）
'提示用户输入日期，最多3次
而sDate=“”
sDate=InputBox（“输入日期。使用'mm/dd/yyyy'格式！”，“输入日期…”，日期）
如果sDate“”那么dDate=CDate（sDate）“”这部分您可能需要改进。使用正则表达式将是非常好的解决方案！
i=i+1
如果i=3，那么
MsgBox“您已取消输入日期3。时代！，vbInformation，“信息…”
转到出口_生成
如果结束
环
'筛选并复制数据
srcWsh.Range（“$A$1:$M$49000”）。自动筛选字段：=1，标准1:=dDate
srcWsh.Range（$A$1:$M$49000”）。自动筛选字段：=5，标准1:=“John，Henry，Jacob”
srcWsh.Cells.Copy
dstWsh.范围（“A1”）.粘贴
Application.CutCopyMode=False
退出并生成：
出错时继续下一步
“清理
设置srcWsh=Nothing
如果srcWbk不是空，则srcWbk.Close SaveChanges:=False
设置srcWbk=Nothing
设置dstWhs=Nothing
设置dstWbk=Nothing
出口接头
错误生成：
MsgBox错误描述、VBEQUOTION、错误编号
恢复退出生成
端接头

在上下文中使用代码并提供错误处理非常重要

---

注意：未经测试，但它也应该可以工作！

您可以尝试类似的方法

Sub Generate()
Dim wbSource As Workbook, wbDest As Workbook
Dim wsSource As Worksheet, wsDest As Worksheet, wsCrit As Worksheet
Dim CritDate As String
Dim critName

Application.ScreenUpdating = False

Set wbDest = ThisWorkbook
Set wsDest = wbDest.Sheets("Sheet1")
Set wsCrit = wbDest.Sheets("Sheet3")

'Clearing existing data on destination sheet before copying the new data from Input.xlsx
wsDest.Cells.Clear

'Assuming the Names criteria are in column A starting from Row2 on Sheet3
critName = Application.Transpose(wsCrit.Range("A2", wsCrit.Range("A1").End(xlDown)))

CritDate = InputBox("Enter a date...", "Date:", "mm/dd/yyyy")
CritDate = Format(CritDate, "mm/dd/yyyy")

If CritDate = "" Then
    MsgBox "You didn't enter a date.", vbExclamation, "Action Cancelled!"
    Exit Sub
End If

Set wbSource = Workbooks.Open(Filename:="E:\Resource\Input.xlsx")
Set wsSource = wbSource.Sheets("NewInput")

With wsSource.Rows(1)
    .AutoFilter field:=1, Criteria1:="=" & CritDate, Operator:=xlAnd
    .AutoFilter field:=5, Criteria1:=critName, Operator:=xlFilterValues
    wsSource.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A1")
End With
wbSource.Close False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub