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

Question

我是新来的，一般来说是 vba。我基本上只是为我的新工作读懂了这件事。所以请多多包涵。 我正在寻找解决我的问题的方法，并找到了单独的零件解决方案，但我无法将它们拼凑在一起。

我的目标如下： 将工作簿的 3 个工作表复制到一个新工作表（尚不存在），并以特定名称将其保存在当前日期下。 这是我到目前为止为运行良好而整理的代码。

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

第一个条件：不应该手动创建新工作簿并首先打开，但宏应该这样做。

第二个条件：第一个工作簿应该选择自动过滤器，然后只复制可见的单元格。 这可以作为一个完整的工作表，还是我必须复制单元格并在新工作簿中创建一个工作表？ 这是过滤器的代码

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

第 3 个条件：其他两个工作表应在没有公式但有格式的情况下复制。 （包含在第一个代码示例中）

我现在的问题是，将所有内容拼凑在一起，以便新工作簿中有 3 个工作表，其中第一个 ws 包含源 ws 的可见单元格和自动过滤器，另外两个工作表仅包含数据和格式和被隐藏。 我的推理信息：第一个工作表将公式引用到其他两个工作表，以便文件的收件人预先选择字段和列表来填写单元格。

非常感谢您。

编辑：背景信息： Accr 表包含应计信息，并在 A 列中包含月份信息。由于以后也应该能够在一个数据透视表中比较几年，因此格式从单纯的数字更改为日期（格式：MM.YYYY） .

Answer 1

编辑

好的，这是一个不同的代码，它复制工作表，然后删除 Accr 中不符合条件的行。确保范围绝对，将$ 放在公式中列和行的前面，您提到的vlookup 应该变为=VLOOKUP(R2097;Segments!$G:$Q;11;0)，这适用于Accr 表上引用固定范围的任何公式任何地方。

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

编辑结束

Answer 2

好的...所以在摆弄了一段时间并收集了有关该网站的几条信息之后，我终于有了一个解决方案。

主要问题是第一个条件，即日期字段。我发现当日期不是美国格式时，vba 会出现问题。所以我做了一个解决方法，并在我的参数工作表中创建了一个文本格式日期，这样我总是可以在工作簿中设置当前月份的工作表导出。 在我的应计数据中，我只需将 A 列中的格式更改为包含文本（例如 '01.2016）。 另外，我稍微优化了原始数据，因此我只需导出一个额外的工作表，该工作表将被隐藏并且仅包含硬拷贝值，因此不再有指向我的原始文件的外部链接。

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

现在我可以为必须创建的每个文件创建一个子文件，然后依次运行所有子文件。这为我节省了很多时间。 隐藏行的部分，我在这里找到Delete Hidden/Invisible Rows after Autofilter Excel VBA

再次感谢@silentrevolution 的帮助，它为我提供了获得所需结果的指示。

这不是最干净的代码，我相信它可以变得更精简，所以我会很感激任何建议。但现在它可以满足我的需求。