宏创建新工作区而不是添加工作表

Question

以下宏旨在获取日期范围的特定数据。虽然这样做，我希望它显示在另一张工作表上的同一工作簿中，而不是创建一个新的工作簿。任何想法如何我可以解决这个问题？

Public Sub PromptUserForInputDates() 

    Dim strStart As String, strEnd As String, strPromptMessage As String 

    strStart = InputBox("Please enter the start date") 

    If Not IsDate(strStart) Then 
     strPromptMessage = "Not Valid Date" 

     MsgBox strPromptMessage 

     Exit Sub 
    End If 

    strEnd = InputBox("Please enter the end date") 

    If Not IsDate(strStart) Then 
     strPromptMessage = "Not Valid Date" 

     MsgBox strPromptMessage 
     Exit Sub 

    End If 

    Call CreateSubsetWorkbook(strStart, strEnd) 

    End Sub 

Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String) 

    Dim wbkOutput As Workbook 
    Dim wksOutput As Worksheet, wks As Worksheet 
    Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long 
    Dim rngFull As Range, rngResult As Range, rngTarget As Range 

    lngDateCol = 4 
    Set wbkOutput = Workbooks.Add 

    For Each wks In ThisWorkbook.Worksheets 
     With wks 

      Set wksOutput = wbkOutput.Sheets.Add 
      wksOutput.Name = wks.Name 

      Set rngTarget = wksOutput.Cells(1, 1) 

      lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _ 
            SearchOrder:=xlByRows, _ 
            SearchDirection:=xlPrevious).Row 
      lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _ 
            SearchOrder:=xlByColumns, _ 
            SearchDirection:=xlPrevious).Column 
      Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol)) 

      With rngFull 
       .AutoFilter Field:=lngDateCol, _ 
          Criteria1:=">=" & StartDate, _ 
          Criteria2:="<=" & EndDate 


       Set rngResult = rngFull.SpecialCells(xlCellTypeVisible) 
       rngResult.Copy Destination:=rngTarget 
      End With 

      .AutoFilterMode = False 
      If .FilterMode = True Then 
       .ShowAllData 

      End If 
     End With 
    Next wks 


    MsgBox "Data Transferred!" 

    End Sub 

Answer 1

你定义Set wbkOutput = Workbooks.Add这将总是创建一个新的工作簿。相反，Set wbkOutput =您希望输出的工作簿。

请注意，您的任务wksOutput.Name = wks.Name将失败（两个工作表不能同名），所以我现在已经发表了意见，您可以根据需要修改该语句。

与ThisWorkbook

Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String) 

    Dim wksOutput As Worksheet, wks As Worksheet 
    Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long 
    Dim rngFull As Range, rngResult As Range, rngTarget As Range 

    lngDateCol = 4 
    For Each wks In ThisWorkbook.Worksheets 
     With wks 
      Set wksOutput = ThisWorkbook.Sheets.Add 
      ' This is not allowed, you can make some change to the name but it cannot be the same name worksheet 
      ' >>> wksOutput.Name = wks.Name 

      Set rngTarget = wksOutput.Cells(1, 1) 

      lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _ 
            SearchOrder:=xlByRows, _ 
            SearchDirection:=xlPrevious).Row 
      lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _ 
            SearchOrder:=xlByColumns, _ 
            SearchDirection:=xlPrevious).Column 
      Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol)) 

      With rngFull 
       .AutoFilter Field:=lngDateCol, _ 
          Criteria1:=">=" & StartDate, _ 
          Criteria2:="<=" & EndDate 


       Set rngResult = rngFull.SpecialCells(xlCellTypeVisible) 
       rngResult.Copy Destination:=rngTarget 
      End With 

      .AutoFilterMode = False 
      If .FilterMode = True Then 
       .ShowAllData 

      End If 
     End With 
    Next wks 
End Sub