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的分配将失败（两个工作表不能同名），所以我暂时对其进行了评论，您可以根据需要修改该语句。

将所有对wbkOutput的引用替换为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

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

1 个答案: