修改

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个工作表，其中包含源ws的可见单元格和自动过滤器以及另外两个仅包含数据和格式的工作表被隐藏根据我的推理信息：第一个工作表将公式引用到另外两个工作表，以便文件的收件人具有预先选择的字段和列表来填充单元格。

非常感谢你。

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

Answer 1

修改

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

Accr

编辑结束

Answer 2

好的......所以经过一段时间摆弄它并收集本网站的几条信息之后，我终于找到了解决方案。

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

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

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

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

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

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

2 个答案:

修改

编辑结束