入力ボックスに基づいてセルをコピーする - VBA

Question

私は完全なデータ（input.xlsx）ともう1つ（Final Report.xlsm）の2つのファイルをコピーする必要があります。 input.xlsxの列Aには日付があり、Col Eには名前のリストがあります。

私がしようとしているのは、2つの基準に基づいて 'input.xlsx'から（マクロを介して）セルをコピーすることです。私の基準は日付（col A）と名前のリスト（col E）です。

私は以下のコードを試しました。私はこのコードをFinal Report.xlsmから実行していますが、うまくいきますが、必要なのは、メッセージボックスで日付を入力するのではなく、最終的なレポートのsheet3の列Aにも同様に名前を入れることです.xlsm。名前を変更し続けると100個以上の名前があるので、sheet3の列Aから日付と名前のメッセージボックスを介して条件を選択する必要があります。

このコードを変更する方法を教えてください。

マイコード：すべての

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