获取object表的筛选条件

pepsi7777 · 发表于 2023-3-9 15:34

本帖最后由 pepsi7777 于 2023-3-11 11:34 编辑

各位老师好，

sheet1中有个2个object表，名为“表1”和“表2”，如何才能获取“表2”【地区】字段当前的筛选条件？感谢！！！

生成表2【地区】当前的筛选条件（唯一）显示的顺序，无所谓
如果无筛选则显示 “全部”

半百 · 发表于 2023-3-9 16:21

pepsi7777 · 发表于 2023-3-9 17:33

半百发表于 2023-3-9 16:21

感谢半百老师。但是运行是报错

半百 · 发表于 2023-3-9 19:26

pepsi7777 发表于 2023-3-9 17:33
感谢半百老师。但是运行是报错

再检查检查哪里抄错了没

perfect131 · 发表于 2023-3-10 12:37

pepsi7777 发表于 2023-3-9 17:33
感谢半百老师。但是运行是报错

参考

Sub kong()
aa = "表2"
If Objectsexists(ActiveSheet.ListObjects, (aa)) Then
If IsListobjectFiltered(ActiveSheet.ListObjects(aa)) Then
Set bb = ActiveSheet.ListObjects(aa).AutoFilter.Filters
ReDim ar(1 To bb.Count)
cc = 0
For i = 1 To bb.Count
If bb.Item(i).On Then cc = cc + 1: ar(cc) = i
Next
''''' Set kk = ActiveSheet.ListObjects(aa).DataBodyRange.SpecialCells(xlCellTypeVisible)
Set kk = ActiveSheet.ListObjects(aa).Range.SpecialCells(xlCellTypeVisible)
If kk.Areas.Count > 0 Then
ReDim arr(1 To kk.Count \ UBound(ar) + 1, 1 To cc): dd = 0
Set dic = CreateObject("scripting.dictionary")
ReDim br(1 To 1, 1 To cc)
For i = 0 To kk.Areas.Count - 1
brr = kk.Areas.Item(i + 1).Value2
For j = 1 To UBound(brr)
For x = 1 To cc
If Not dic.exists(arr(1, x) & brr(j, ar(x))) Then
br(1, x) = br(1, x) + 1
arr(br(1, x), x) = brr(j, ar(x)): dic(arr(1, x) & brr(j, ar(x))) = ""
End If
Next
Next
Next
Range("a" & ActiveSheet.UsedRange.Rows.Count).Resize(UBound(arr), cc) = arr
End If
Else
MsgBox aa & " ListObjects 没有被筛选"
End If
Else
MsgBox "没有 " & aa & " 这个 ListObjects"
End If
End Sub
Function Objectsexists(bb As Object, aa As String) As Boolean '''ListObjects表判断
On Error GoTo err
If Len(bb(aa)) Then Objectsexists = True
err:
End Function
Function IsListobjectFiltered(ByVal listObj As ListObject) As Boolean '''ListObjects筛选判断
If listObj.ShowAutoFilter Then
If listObj.AutoFilter.FilterMode Then
IsListobjectFiltered = True
Exit Function
End If
End If
IsListobjectFiltered = False
End Function

复制代码

perfect131 · 发表于 2023-3-10 13:14

第二种

Sub kong2()
aa = "表2"
If Objectsexists(ActiveSheet.ListObjects, (aa)) Then
If IsListobjectFiltered(ActiveSheet.ListObjects(aa)) Then
Set bb = ActiveSheet.ListObjects(aa).AutoFilter.Filters
ReDim ar(1 To bb.Count, 1 To 2)
cc = 0
For i = 1 To bb.Count
If bb.Item(i).On Then
cc = cc + 1: ar(cc, 1) = i:
ar(cc, 2) = bb.Item(i).Count
If ans < ar(cc, 2) Then ans = ar(cc, 2)
End If
Next
If cc > 0 Then
ReDim arr(1 To ans + 1, 1 To cc): dd = 0
drr = ActiveSheet.ListObjects(aa).AutoFilter.Range.Value2
For i = 1 To cc
arr(1, i) = drr(1, ar(i, 1))
Next
For i = 1 To cc
If ar(i, 2) > 1 Then
ss = Split(Replace(Join(bb.Item(ar(i, 1)).Criteria1, ","), "=", ""), ",")
For j = 0 To UBound(ss)
arr(j + 2, i) = IIf(IsNumeric(ss(j)), Val(ss(j)), ss(j))
Next
Else
arr(2, i) = Replace(bb.Item(ar(i, 1)).Criteria1, "=", "")
arr(2, i) = IIf(IsNumeric(arr(2, i)), Val(arr(2, i)), arr(2, i))
End If
Next
Range("a" & ActiveSheet.UsedRange.Rows.Count).Resize(UBound(arr), cc) = arr
End If
Else
MsgBox aa & " ListObjects 没有被筛选"
End If
Else
MsgBox "没有 " & aa & " 这个 ListObjects"
End If
End Sub
Function Objectsexists(bb As Object, aa As String) As Boolean '''ListObjects表判断
On Error GoTo err
If Len(bb(aa)) Then Objectsexists = True
err:
End Function
Function IsListobjectFiltered(ByVal listObj As ListObject) As Boolean '''ListObjects筛选判断
If listObj.ShowAutoFilter Then
If listObj.AutoFilter.FilterMode Then
IsListobjectFiltered = True
Exit Function
End If
End If
IsListobjectFiltered = False
End Function

复制代码

pepsi7777 · 发表于 2023-3-11 11:30

perfect131 发表于 2023-3-10 13:14
第二种

感谢 perfect131 老师

		自动登录	找回密码
密码			免费注册

[已解决] 获取object表的筛选条件

评分

评分