宏创建一个新的工作台，而不是添加工作表

Question

The following Macro was intended to get specific data for a date range. While it does this, I wanted it displayed within the same workbook on another sheet, instead a new workbook is created. Any idea on how I can fix this?

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

You're defining Set wbkOutput = Workbooks.Add which will always create a new workbook. Instead, Set wbkOutput = the workbook where you want the output to be.

Note that your assignment of wksOutput.Name = wks.Name will fail (two worksheets cannot have same name), so I've commented it out for now and you can revise that statement as needed.

Replace all references to wbkOutput with 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