VBA-在活动用户桌面上过滤并另存为唯一的工作表名称

编程问答 2022-06-05

问题描述

好-我将此代码发布在另一篇文章中，我的问题得到了回答。这样可以解决最初的问题，但是现在我遇到了一个新错误。我还不断遇到不同的帖子，这使我认为有办法做到这一点。我的代码在这一行上出错了：

'Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws2.Name & ".xlsx"'

长话短说，我收到一个过时的输出文件，需要根据C列中的过滤后的值进行过滤，复制，粘贴和另存为新工作簿。该宏应该遍历每个过滤器并保存，但这总是失败。对于提供的所有帮助，我将不胜感激，并深表感谢。

最后一个重要说明-由于收到的带有日期的文件经常具有新的工作簿名称，因此该代码已保存到我的个人宏簿中。关键是代码需要从用户的个人宏书中运行，并将所有文件保存到用户的桌面上以进行分发。

Option Explicit

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim ws As Range
Dim ws2 As Worksheet
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook

'Specify sheet name in which the data is stored
ActiveSheet.Name = "Data"
sht = "Data"

'Workbook where VBA code resides
Set Workbk = ActiveWorkbook

'New Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Workbk.Activate

'change filter column in the following code
last = Workbk.Sheets(sht).Cells(Rows.Count,"C").End(xlUp).Row

With Workbk.Sheets(sht)
Set rng = .Range("A1:S" & last)
End With

Workbk.Sheets(sht).Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy,CopyToRange:=Range("AA1"),Unique:=True
For Each x In Workbk.Sheets(sht).Range([AA2],Cells(Rows.Count,"AA").End(xlUp))

With rng
.AutoFilter
.AutoFilter Field:=3,Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy

newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
Next x

Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws2 In ActiveWorkbook.Sheets
    ws2.Copy
    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws2.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True

' Turn off filter
Workbk.Sheets(sht).AutoFilterMode = False

With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

End Sub

非常感谢您提供的所有帮助！

谢谢， 轻弹

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）

desktopfilenamessavesave-as