Makro zum Erstellen eines neuen Arbeitsfortsatzes anstelle eines Arbeitsblatts

Question

Das folgende Makro sollte bestimmte Daten für einen Datumsbereich abrufen. Währenddessen wollte ich, dass es in derselben Arbeitsmappe auf einem anderen Blatt angezeigt wird, stattdessen wird eine neue Arbeitsmappe erstellt. Irgendeine Idee, wie ich das beheben kann?

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

Sie definieren Set wbkOutput = Workbooks.Add, die wird immer eine neue Arbeitsmappe erstellen. Stattdessen Set wbkOutput = die Arbeitsmappe, in der die Ausgabe erfolgen soll.

Beachten Sie, dass Ihre Zuweisung von wksOutput.Name = wks.Name fehlschlägt (zwei Arbeitsblätter können nicht den gleichen Namen haben), also habe ich es für jetzt auskommentiert und Sie können diese Anweisung nach Bedarf überarbeiten.

Ersetzen Sie alle Verweise auf wbkOutput mit 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