Question

我有2个文件，一个包含完整数据（input.xlsx），另一个包含（Final Report.xlsm），需要将其复制到其中。在input.xlsx列中，A列具有日期，而Col E具有名称列表。

我要做的是从＆lt; input.xlsx＆＃39;复制单元格（通过宏）。基于两个标准。我的标准是日期（在col A中）和名单（在col E中）。

我已经尝试过以下代码。我从Final Report.xlsm运行此代码并且它工作正常，但我需要的是能够通过消息框输入日期而不是硬编码，类似的名称也将在最终报告中的Sheet3的A列中.XLSM。它需要通过消息框中的日期和名称从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

Answer 1

首先：避免使用Select和Activate方法。请参阅：Excel VBA Performance Coding Best Practices

试试这个：

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

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

注意：未经测试，但也应该有效！

Answer 2

您可以尝试这样的事情......

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

根据输入框复制单元格 - VBA

2 个答案: