将3个工作表复制到新工作簿-1个仅具有可见单元格-其他2个仅具有值

Question

I'm new here and to vba in general. I basically just read myself into the matter for my new job. So please bear with me. I'm looking for a solution to my issue and found seperate solutions for parts but I'm not able to piece them together.

My goal is the following: Copy 3 Worksheets of a workbook to a new one (not existing yet) and save it under the current date with a specific name. Here's the code that I put together so far for that which works fine.

Sub export()

Dim path As String
Dim file As String
Dim ws As Worksheet
Dim rng As Range

path = "D:\@Inbox\"
file = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " &     "accr " & Format(DateSerial(Year(Date), Month(Date), 1), "YYYY_MM") & " city" & ".xlsx"

Application.ScreenUpdating = False

Sheets(Array("Accr", "Pivot", "Segments")).Select
Sheets(Array("Accr", "Pivot", "Segments")).Copy
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value

For Each ws In Worksheets
ws.Rectangles.Delete
Next
Sheets(Array("Pivot", "Segments")).Visible = False

ActiveWorkbook.SaveAs Filename:=path & file, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close

Sheets("Menu =>").Select
Range("C1").Select

End Sub

1st condition: the new workbook should not be created manually and opened first, but the macro should do that.

2nd condition: the 1st workbook should have autofilters selected and then only visible cells copied. Is that possible as a whole worksheet, or do I have to copy the cells and create a worksheet in the new workbook? Here's the code for the filter

Sheets("Accr").Select
Reset_Filter
Selection.AutoFilter Field:=1, Criteria1:="12"
Selection.AutoFilter Field:=2, Criteria1:="booked"
Selection.AutoFilter Field:=35, Criteria1:="Frankfurt"
Set rng = Application.Intersect(ActiveSheet.UsedRange)
rng.SpecialCells(xlCellTypeVisible).Copy

3rd condition: the other two worksheets should be copied without formulas but with format. (That is included in the first code sample)

My problem is now, to piece everything together so that there are 3 worksheets in the new workbook containing in the first ws the visible cells of the source ws with the autofilter and the other two worksheets containing only the data and the format and being hidden. Info to my reasoning: the first worksheet refers with the formulas to the other two worksheets so that the recipients of the file have preselected fields and lists to fill out the cells.

Thank you very much in advance.

EDIT: Background Info: The Accr sheet contains accrual informattion and has the Month information in column A. Since several years should be also able to be compared in one Pivot Table later on, the format was changed from a mere number to a date (format: MM.YYYY ).

Answer 1

Edit

Alright, here is a different code, this copies the worksheets then removes the rows in Accr which do not meet the criteria. Be sure to make ranges absolute, put $ in front of the column and row in a formula, the vlookup you mentioned should become =VLOOKUP(R2097;Segments!$G:$Q;11;0) and this goes for any formula on the Accr sheet that references a fixed range anywhere.

 Sub Export() Dim NewWorkbook As Workbook Dim Ws As Worksheet Dim fPath As String, fName As String Dim i As Long Dim RowsToDelete As Range Application.ScreenUpdating = False Application.DisplayAlerts = False Set NewWorkbook = Workbooks.Add fPath = "D:\\@Inbox\\" fName = VBA.Format(VBA.Date, "YYYY-MM-DD") & " " & VBA.Format(VBA.Time, "hhmm") & " " & "accr " & VBA.Format(VBA.DateSerial(VBA.Year(VBA.Date), VBA.Month(VBA.Date), 1), "YYYY_MM") & " city" NewWorkbook.SaveAs fPath & fName, xlOpenXMLWorkbook ThisWorkbook.Worksheets(Array("Accr", "Pivot", "Segments")).Copy NewWorkbook.Worksheets(1) For Each Ws In NewWorkbook.Worksheets With Ws If Not .Name = "Accr" And Not .Name = "Pivot" And Not .Name = "Segments" Then .Delete ElseIf Ws.Name = "Accr" Then For i = 4 To .Cells(.Rows.Count, 1).End(xlUp).Row If Not .Cells(i, 1) = .Cells(i, 1) = Month(ThisWorkbook.Worksheets("Mon").Cells(19, 2)) And Not .Cells(i, 2) = "booked" And Not .Cells(i, 35) = "Frankfurt" Then If RowsToDelete Is Nothing Then Set RowsToDelete = .Rows(i).EntireRow Else Set RowsToDelete = Union(RowsToDelete, .Rows(i).EntireRow) End If End If Next i If Not RowsToDelete Is Nothing Then RowsToDelete.Delete xlUp End If ElseIf .Name = "Pivot" Or .Name = "Segments" Then .Visible = xlSheetHidden .UsedRange = Ws.UsedRange.Value End If End With Next Ws NewWorkbook.Save NewWorkbook.Close Application.Goto ThisWorkbook.Worksheets("Menu =>").Cells(1, 3) Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub 

End of edit

Answer 2

Ok... so after fiddling around with it a while and collecting several pieces of information around this website, I finally have a solution.

The main problem, was the first criteria, which is a date field. I found out that vba has its problems when the date is not in US-Format. So I made a workaround and made a textformat date in my parameter worksheet, so that I always have the export of the sheets for the current month set in the workbook. In my accruals-data I just had to change the format in column A to have text (eg '01.2016). Plus I optimized my rawdata a little bit, so that I only have to export one additional worksheet, which will be hidden and contains only hardcopy values, so that there is no external link to my original file anymore.

Sub ACTION_Export_AbgrBerlin()
Dim Pfad As String
Dim Dateiname As String
Dim ws As Worksheet
Dim oRow As Range, rng As Range
Dim myrows As Range

' define filepath and filename
Pfad = "D:\@Inbox\"
Dateiname = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " & "Abr " _
& Format(DateSerial(Year(Date), Month(Date), 1), "yyyy-mm") & " Berlin" & ".xlsx"


Application.ScreenUpdating = False

Sheets(Array("Abgr", "Masterdata MP")).Copy

' hardcopy of values
Sheets("Masterdata MP").UsedRange = Sheets("Masterdata MP").UsedRange.Value
' delete Macrobuttons and Hyperlinks
    For Each ws In Worksheets
    ws.Rectangles.Delete
    ws.Hyperlinks.Delete
    Next
' delete first 3 rows (that are placeholders for the macrobuttons in the original file)
    With Sheets("Abgr")
    .AutoFilterMode = False
    .Rows("1:3").EntireRow.Delete

' set Autofilter matching the following criteria
    .Range("A1:AO1048576").AutoFilter
'refer to parameter worksheet which contains the current date as textformat
    .Range("A1:AO1048576").AutoFilter Field:=1, Criteria1:=ThisWorkbook.Worksheets("Mon").Range("E21")
    .Range("A1:AO1048576").AutoFilter Field:=2, Criteria1:=Array(1, "gebucht")
    .Range("A1:AO1048576").AutoFilter Field:=36, Criteria1:=Array(1, "Abgr Berlin")
    End With
'delete hidden rows i.e. delete anything but the selection
    With Sheets("Abgr")
    Set myrows = Intersect(.Range("A:A").EntireRow, .UsedRange)
    End With

    For Each oRow In myrows.Columns(1).Cells
        If oRow.EntireRow.Hidden Then
            If rng Is Nothing Then
                Set rng = oRow
            Else
                Set rng = Union(rng, oRow)
            End If
        End If
    Next

    If Not rng Is Nothing Then rng.EntireRow.Delete

    Sheets("Masterdata MP").Visible = xlSheetHidden
    Sheets("Masterdata MP").UsedRange = Sheets("Masterdata MP").UsedRange.Value


    ActiveWorkbook.SaveAs Filename:=Pfad & Dateiname, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close
  'go back to main menu in original workbook  
    Sheets("Menu").Select
End Sub

Now I can create one sub for each file I have to create and then run all the subs after each other. That saves me a bunch of time. The part with the hidden rows, I found here Delete Hidden/Invisible Rows after Autofilter Excel VBA

Thanks again @silentrevolution for your help, it gave me the pointers to get the needed result.

It's not the cleanest code and I'm sure that it can be made a bit leaner, so I would appreciate any recommendations. But for now it serves my needs.