将3个工作表复制到新的工作簿 – 1只有可见的单元格 – 另外两个只有值
我是新来的，一般来说vba。 我基本上只是把自己的事情看成是为了我的新工作。 所以请忍受我。 我正在寻找解决scheme来解决我的问题，并发现部分解决scheme，但我无法将它们拼凑在一起。
我的目标如下：将工作簿的3个工作表复制到一个新的工作表（不存在），并将其保存在具有特定名称的当前date之下。 下面是我为了工作正常而编写的代码。
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 第一个条件：不应该手动创build新的工作簿并且先打开，但macros应该这样做。
第二个条件：第一个工作簿应该select自动筛选器，然后只复制可见的单元格。 这是可能的整个工作表，还是我必须复制单元格，并在新的工作簿中创build一个工作表？ 这是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
第三个条件：另外两个工作表应该被复制，而没有公式，但格式。 （包含在第一个代码示例中）
我现在的问题是将所有东西拼成一个整体，这样在新的工作簿中就有三张工作表，在第一个工作表中包含源ws的可见单元格和自动filter，另外两个工作表仅包含数据和格式并被隐藏。 信息给我的推理：第一个工作表引用与另外两个工作表的公式，以便该文件的收件人有预先选定的字段和列表来填写单元格。
非常感谢你提前。
编辑：背景信息： Accr工作表包含权责发生制信息，并在A列中包含月份信息。由于几年之后也应该能够在一个数据透视表中进行比较，因此格式从单纯的数字更改为date（格式： MM.YYYY ）。
编辑
好吧，这是一个不同的代码，这复制工作表，然后删除Accr中不符合条件的行。 一定要将范围绝对化，把$放在公式前面的行和列中，你提到的=VLOOKUP(R2097;Segments!$G:$Q;11;0)应该变成=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
编辑结束
好的…所以经过一段时间的摆弄和收集这个网站上的几条信息后，我终于有了一个解决scheme。
主要的问题，是第一个标准，这是一个date字段。 当date不是US格式时，我发现vba有问题。 所以我做了一个解决方法，并在参数工作表中创build了一个文本格式的date，以便我始终导出工作簿中设置的当前月份的工作表。 在我的权责发生制数据中，我不得不改变A列中的格式以获得文本（例如'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 ie 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
现在我可以为每个文件创build一个子文件，然后运行所有的子文件。 这节省了我一堆时间。 具有隐藏行的部分，我在这里find删除自动筛选Excel VBA后隐藏/不可见行
再次感谢@silentrevolution的帮助，它给了我指针来获得所需的结果。
这不是最干净的代码，我相信它可以变得更加精简，所以我希望有任何build议。 但现在它符合我的需求。