代码之家 › 专栏 › 技术社区 › Ramadan Moussa

向VBA添加规则以删除筛选器

vba excel

1

Ramadan Moussa · 技术社区 · 1 年前

我有一个代码,可以在源文件关闭时在两个不同的工作簿之间复制数据,它工作得很好,但有一个问题,那就是当源文件在表中使用活动过滤器关闭时,我在复制到目标文件的数据中遇到了问题

因此,我需要在代码中添加一条规则,在复制数据之前清除源文件中的所有过滤器“停止工作”,以便将所有数据传输到目标文件

这是我的代码

Sub Update()

  ' Open the source workbook
Set sourceWorkbook = Workbooks.Open(Filename:="D:\Desktop\Stop Work.xlsm")

sourceWorkbook.Worksheets("Sheet1").Cells.Copy

' Open the destination workbook
Set destinationWorkbook = Workbooks.Open(Filename:="D:\Desktop\AUTHs.xlsm")
 
destinationWorkbook.Worksheets("Stop Work").Cells.PasteSpecial xlPasteAll

destinationWorkbook.Save

' Close the source workbook after saving changes
sourceWorkbook.Close SaveChanges:=False

 ActiveSheet.ListObjects(1).ListColumns(1).Range.End(xlDown).Select
    
     
End Sub

3 回复 | 直到 1 年前

1

0

Michal 1 年前

您需要在代码的开头检查是否存在任何过滤器,如果存在,请将其删除:

Dim tbl As ListObject

' Open the source workbook
Set sourceWorkbook = Workbooks.Open(Filename:="D:\Desktop\Stop Work.xlsm")

' Check if there are tables in the worksheet and clear filters if present
Set ws = sourceWorkbook.Worksheets("Sheet1")
On Error Resume Next
For Each tbl In ws.ListObjects
    If tbl.AutoFilter Is Nothing = False Then
        tbl.AutoFilter.ShowAllData
    End If
Next tbl
On Error GoTo 0

2

0

Kaper 1 年前

您尚未指定是否只筛选自动筛选或excel表。所以,让我们试着涵盖这两种情况

Sub Update()

  ' Open the source workbook
Set sourceWorkbook = Workbooks.Open(Filename:="D:\Desktop\Stop Work.xlsm")

with sourceWorkbook.Worksheets("Sheet1")

  .AutoFilterMode = False
  Dim lo As Long
  For lo = 1 To .ListObjects.Count
    .ListObjects(lo).ShowAutoFilter = False
  Next lo

  .Cells.Copy

end with

' Open the destination workbook
'....

顺便说一句,同样的问题在 https://www.mrexcel.com/board/threads/add-a-rule-to-the-vba-to-remove-filters.1268355/

3

0

VBasic2008 1 年前

从已关闭的工作簿中复制带有Excel表的工作表

Sub UpdateAuth()

    ' Open and reference the source workbook.
    Dim swb As Workbook:
    Set swb = Workbooks.Open(Filename:="D:\Desktop\Stop Work.xlsm")

    ' Reference the source worksheet.
    Dim sws As Worksheet: Set sws = swb.Sheets("Sheet1")

    ' Reference the only table in the source worksheet.
    Dim slo As ListObject: Set slo = sws.ListObjects(1)

    ' Clear filters in the table.
    With slo
        If .ShowAutoFilter Then ' is auto filter turned on?
            If .AutoFilter.FilterMode Then ' is filtered?
                .AutoFilter.ShowAllData ' clear filter
            End If
        End If
    End With
    
    ' Open and reference the destination workbook.
    Dim dwb As Workbook:
    Set dwb = Workbooks.Open(Filename:="D:\Desktop\AUTHs.xlsm")
    ' If this is the (open) workbook containing this code,
    ' use 'Set dwb = ThisWorkbook' instead.

    ' Reference the destination worksheet.
    Dim dws As Worksheet: Set dws = dwb.Sheets("Stop Work")
    
    ' Clear and copy.
    dws.Cells.Clear ' clear existing data
    sws.Cells.Copy Destination:=dws.Cells ' copy
    
    ' Close the source workbook after saving changes (due to clearing filters).
    swb.Close SaveChanges:=True
    
    ' Save the destination workbook.
    dwb.Save
    
End Sub