细说自动筛选和高级筛选通过VBA快速文本筛选_wang880117的博客

相关文章推荐
眼睛小的肉夹馍 · winfrom listBox ...· 2 周前 ·
爱运动的打火机 · 使用 VBA ...· 2 周前 ·
性感的凉面 · VBA | ...· 2 周前 ·
考研的松树 · 用VBA写将查找值所在的列赋值给数组 - ...· 2 周前 ·
帅呆的金鱼 · 用VBA数组字典实现多条件查找 - ...· 2 周前 ·
重感情的水煮肉 · Android Kotlin 實作 Day ...· 1 月前 ·
魁梧的小蝌蚪 · prevented an empty ...· 1 年前 ·
乐观的火锅 · NIELSEN价格报价行情 - 京东· 1 年前 ·
高大的蟠桃 · video.js实现鼠标移入播放鼠标移出暂停 ...· 1 年前 ·
完美的皮带 · Github+Hexo博客搭建小白教程（一） ...· 1 年前 ·
细说自动筛选和高级筛选通过VBA快速文本筛选
 排序中的自定义排序的引用序列如何能够用VBA来写活，指定按某列顺序来排序来
Attribute VB_Name = "find_cell"
Option Explicit
Sub select1()
Attribute select1.VB_ProcData.VB_Invoke_Func = " \n14"
' select1 宏
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
End Sub
Sub filldown()
Attribute filldown.VB_ProcData.VB_Invoke_Func = " \n14"
' filldown 宏
    Range("A1:A8").Select
    Selection.filldown
    Selection.copy
    Range("D11").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub
Sub copy()
Attribute copy.VB_ProcData.VB_Invoke_Func = " \n14"
' copy 宏
    Range("E2").Select
    Selection.copy
    Range("E13").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("F13").Select
    ActiveSheet.Paste
    Range("G13").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("H13").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("I13").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("J13").Select
    ActiveSheet.Paste Link:=True
    Range("K13").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Range("L13").Select
    Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("M13").Select
    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("N13").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("O13").Select
    ActiveSheet.Pictures.Paste.Select
    ActiveSheet.Shapes.Range(Array("Picture 1")).Select
    Range("P13").Select
    ActiveSheet.Pictures.Paste(Link:=True).Select
    ActiveSheet.Shapes.Range(Array("Picture 2")).Select
End Sub
Sub delwq()
Attribute delwq.VB_ProcData.VB_Invoke_Func = " \n14"
' delwq 宏
    ActiveSheet.Shapes.Range(Array("Picture 1")).Select
    Selection.Delete
    ActiveSheet.Shapes.Range(Array("Picture 2")).Select
    Selection.Cut
    Range("K13").Select
    Selection.Delete Shift:=xlToLeft
    Range("L13").Select
    Selection.Delete Shift:=xlUp
    Range("M13").Select
    Selection.EntireRow.Delete
    Selection.EntireColumn.Delete
    Selection.ClearContents
    Range("M13").AddComment
    Range("M13").Comment.Visible = False
    Range("M13").Comment.text text:="123"
    Range("M13").Select
    Selection.NumberFormatLocal = "0_ "
    Selection.NumberFormatLocal = "yyyy/m/d h:mm;@"
    Selection.NumberFormatLocal = "@"
    Range("N13").Select
    ActiveCell.FormulaR1C1 = "3/24/2019 12:45"
    Range("N14").Select
    Columns("N:N").ColumnWidth = 15.33
    Range("N14").Select
    ActiveCell.FormulaR1C1 = "123456"
    Range("N14").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("N13").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Range("N14").Select
End Sub
Sub usedrow()
Dim re
On Error Resume Next
Range("B3", Cells(ActiveSheet.UsedRange.Rows.Count, 2)).SpecialCells (xlCellTypeBlanks)
'不用管，对齐问题，要想接收对象，必须用set ,如果函数的返回是对象可以直接写对象的操作,也可以保存对象的引用，再使用对象方法
'MSCell("工号").Select
'要想变量接收对象要写成下面的形式
Set re = MSCell("工号")
re.Select
End Sub
Sub get_area()
Dim re, findc, i, row_, col_
For Each i In Worksheets
    Debug.Print i.Name
    i.Select
    row_ = ActiveSheet.UsedRange.Rows.Count
    col_ = ActiveSheet.UsedRange.Columns.Count
    Set re = MSCell("工号", i.Name)
    re.Select
    findc = Empty
    On Error Resume Next
    Debug.Print ActiveSheet.UsedRange.Rows.Count: Set findc = Range(re, Cells(ActiveSheet.UsedRange.Rows.Count, re.Column)): Debug.Print findc.Address: findc.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Function MSCell(value As String, shname As String)
    Dim result
    Sheets(shname).Select
    Set result = Cells.Find(What:=value, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False, SearchFormat:=False)
    If result.Count = 1 Then
        Set MSCell = result
        result.Select
    Else:
        Debug.Print result.Count
    End If
End Function
Attribute VB_Name = "copyfilterfiled1"
Option Explicit
Dim exists_f, wk, sh
Sub sheet_s(sheet)
exists_f = False
For Each wk In Workbooks
    For Each sh In wk.Worksheets
        If sh.Name = sheet Then
            exists_f = True
            wk.Activate
            sh.Select
        End If
If exists_f = True Then
 Debug.Print "sheet exists"
 Debug.Print "Error not exists"
End If
End Sub
Sub 宏1()
Attribute 宏1.VB_ProcData.VB_Invoke_Func = " \n14"
' 宏1 宏
    sheet_s ("new")
    On Error Resume Next
        Sheets("new").Select
    If Err Then
    Debug.Print "sheet no exists"
    Sheets("new").UsedRange.Select: Debug.Print Selection.Name: Selection.AutoFilter: Selection.Delete
    End If
    'Sheets("new").Select
    Dim result, re, myrange
    Sheets("sheet3").Select
    Set result = Cells.Find(What:="一级渠道名称", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False, SearchFormat:=False)
    If result.Count = 1 Then
        result.Select
    Else:
        Debug.Print result.Count
    End If
    Range(result, result.End(xlToRight)).Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$R$78").AutoFilter Field:=8, Criteria1:=Array( _
        "福安小区", "古南小区", "剑河家苑"), Operator:=xlFilterValues
    ActiveSheet.UsedRange.Select
    'result.UsedRange.Select
    Range("c3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.UsedRange.Select
    Debug.Print ActiveSheet.UsedRange.Address
    Set re = ActiveSheet.UsedRange.Find(What:="用户手机", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False, SearchFormat:=False)
    re.EntireRow.Select
    Selection.EntireRow.NumberFormatLocal = "0_ "
    Set myrange = Application.InputBox(prompt:="select a cells,is date time", Type:=8)
    myrange.Select
    Selection.EntireRow.NumberFormatLocal = "yyyy/m/d h:mm;@"
    With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    myrange.Rows.Item("2:3").Select
    Selection.EntireRow.NumberFormatLocal = "yyyy/m/d h:mm;@"
    'ActiveSheet.Paste
    Range("O3").Select
    Sheets("sheet3").Select
    Selection.AutoFilter
End Sub
Sub filter1()
Attribute filter1.VB_ProcData.VB_Invoke_Func = " \n14"
' filter1 宏
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$R$78").AutoFilter Field:=8, Criteria1:=Array( _
        "福安小区", "古南小区", "剑河家苑"), Operator:=xlFilterValues
End Sub
Attribute VB_Name = "删除空行"
Option Explicit
Sub text()
    'Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete '找A列所有空单元格，然后删除空单元格所在行
    'Range("A1:D12").SpecialCells(xlCellTypeBlanks).Activate
    Range("A1:D12").SpecialCells(xlCellTypeLastCell).Activate
    Debug.Print Range("A1:D12").SpecialCells(xlCellTypeBlanks).Count
    Debug.Print Range("A1:A13").SpecialCells(xlCellTypeBlanks).Count
End Sub
Sub 删除空行()
Dim rng As Range, ads As String, ad As String
For Each rng In [a1:a14]
  If rng = "" Then ad = ad & rng.Address & ","
ads = Left(ad, Len(ad) - 1)
Debug.Print ads
Debug.Print Range(ads).Address
    Range("B2:C8").Select
    ActiveSheet.Shapes.AddChart2(227, xlLine).Select
    ActiveChart.SetSourceData Source:=Range("工作簿1!$B$2:$C$8")
    ActiveSheet.Shapes("图表 1").IncrementLeft -115.8
    ActiveSheet.Shapes("图表 1").IncrementTop 48
    ActiveChart.PlotArea.Select
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    ActiveChart.FullSeriesCollection(1).Delete
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.FullSeriesCollection(1).Name = "=工作簿1!$B$4:$C$4"
    ActiveChart.FullSeriesCollection(1).Values = "=工作簿1!$H$4:$K$4"
    ActiveChart.FullSeriesCollection(1).XValues = "=工作簿1!$H$1:$K$1"
    ActiveChart.ChartArea.Select
    ActiveSheet.Shapes("图表 1").ScaleWidth 1.0741666667, msoFalse, _
        msoScaleFromTopLeft
    ActiveSheet.Shapes("图表 1").ScaleHeight 1.0583333333, msoFalse, _
        msoScaleFromBottomRight
    ActiveSheet.Shapes("图表 1").IncrementLeft 15.6
    ActiveSheet.Shapes("图表 1").IncrementTop 49.8
End Sub
Sub 宏3()
Attribute 宏3.VB_ProcData.VB_Invoke_Func = " \n14"
' 宏3 宏
    Range("G2").Select
    Selection.copy
    Range("H6:K6").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("K8").Select
End Sub
Function sxid(valueid As String, valuename As String)
db_rowmax = Worksheets("detail").UsedRange.Rows.Count
tmpval = ""
For i = 7 To db_rowmax + 1
  If UCase(Sheets("detail").Cells(i, 2)) Like "*" & UCase(valueid) &a
rg.AutoFilter Field:=1, Criteria1:="内容"
rg 为筛选区域， Criteria1为筛选的值，比如在A1列内筛选内容为北京区的 ，则 Criteria1="北京区"
2、高级筛选
 Rg.AdvancedFilter Action:=xlFilte
Attribute VB_Name = "NewMacros" 
Sub PPT最优打印自动排版() 
Attribute PPT最优打印自动排版.VB_Description = "宏在 2008-6-16 由 欣宇 录制" 
Attribute PPT最优打印自动排版.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.Macro1" 
'【调整页边距及页眉页脚距，适用于A4纸】 
    With ActiveDocument.Styles(wdStyleNormal).Font 
        If .NameFarEast = .NameAscii Then 
            .NameAscii = "" 
        End If 
        .NameFarEast = "" 
    End With 
    With ActiveDocument.PageSetup 
        .LineNumbering.Active = False 
        .Orientation = wdOrientPortrait 
        .TopMargin = CentimetersToPoints(1.6) 
        .BottomMargin = CentimetersToPoints(0.9) 
        .LeftMargin = CentimetersToPoints(1.4) 
        .RightMargin = CentimetersToPoints(1) 
        .Gutter = CentimetersToPoints(0) 
        .HeaderDistance = CentimetersToPoints(0.5) 
        .FooterDistance = CentimetersToPoints(0.9) 
        .PageWidth = CentimetersToPoints(21) 
        .PageHeight = CentimetersToPoints(29.7) 
        .FirstPageTray = wdPrinterDefaultBin 
        .OtherPagesTray = wdPrinterDefaultBin 
        .SectionStart = wdSectionNewPage 
        .OddAndEvenPagesHeaderFooter = False 
        .DifferentFirstPageHeaderFooter = False 
        .VerticalAlignment = wdAlignVerticalTop 
        .SuppressEndnotes = False 
        .MirrorMargins = False 
        .TwoPagesOnOne = False 
        .BookFoldPrinting = False 
        .BookFoldRevPrinting = False 
        .BookFoldPrintingSheets = 1 
        .GutterPos = wdGutterPosLeft 
        .LayoutMode = wdLayoutModeLineGrid 
    End With 
'【加页码，页脚居中处】 
    Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:= _ 
        wdAlignPageNumberCenter, FirstPage:=True 
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then 
        ActiveWindow.Panes(2).Close 
    End If 
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _ 
        ActivePane.View.Type = wdOutlineView Then 
        ActiveWindow.ActivePane.View.Type = wdPrintView 
    End If 
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader 
    If Selection.HeaderFooter.IsHeader = True Then 
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter 
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader 
    End If 
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _ 
        ActivePane.View.Type = wdOutlineView Then 
        If ActiveWindow.Panes.Count = 2 Then 
            ActiveWindow.Panes(2).Close 
        End If 
        ActiveWindow.View.SplitSpecial = wdPaneCurrentPageHeader 
        ActiveWindow.View.SeekView = wdSeekCurrentPageHeader 
    End If 
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument 
    ActiveWindow.ActivePane.VerticalPercentScrolled = 0 
'【调整每张幻灯片的大小为高184宽262，也许还有更佳的值，可自己尝试】 
    Dim i As Integer 
    For i = 1 To ActiveDocument.InlineShapes.Count 
        ActiveDocument.InlineShapes(i).Height = 184 
        ActiveDocument.InlineShapes(i).Width = 262 
    Next i 
'【给每张幻灯片加边框，感觉没有边框很难看】 
    Selection.HomeKey Unit:=wdStory 
    Dim j As Integer 
    For j = 1 To ActiveDocument.InlineShapes.Count 
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend 
    With Selection.InlineShapes(1) 
        With .Borders(wdBorderLeft) 
            .LineStyle = wdLineStyleSingle 
            .LineWidth = wdLineWidth050pt 
            .Color = wdColorAutomatic 
        End With 
        With .Borders(wdBorderRight) 
            .LineStyle = wdLineStyleSingle 
            .LineWidth = wdLineWidth050pt 
            .Color = wdColorAutomatic 
        End With 
        With .Borders(wdBorderTop) 
            .LineStyle = wdLineStyleSingle 
            .LineWidth = wdLineWidth050pt 
            .Color = wdColorAutomatic 
        End With 
        With .Borders(wdBorderBottom) 
            .LineStyle = wdLineStyleSingle 
            .LineWidth = wdLineWidth050pt 
            .Color = wdColorAutomatic 
        End With 
        .Borders.Shadow = False 
    End With 
    With Options 
        .DefaultBorderLineStyle = wdLineStyleSingle 
        .DefaultBorderLineWidth = wdLineWidth050pt 
        .DefaultBorderColor = wdColorAutomatic 
    End With 
        Selection.MoveRight Unit:=wdCharacter, Count:=1 
    Next j 
End Sub
众所周知，invoke函数有两个重载方式
1 Invoke（methodName, time）经过多长时间后，调用该方法一次
在实际中，切换到游戏开始场景后，一般要等待几秒给玩家缓冲，然后再开始运行角色，可以使用这个方法
2 InvokeRepeating(methodName, time, repeatTime), 经过time时间后调用该方法，并且每过repeatTime再重新调用一次
第二...
				早些时候发在个人博客的，看到网友留言询问控件未注册的问题，自己转到此处。
 之前写了篇“对于指定的操作，该主题不受信任”的问题，后来又遇到过——“无法创建控件，因为它未经正确授权”，见下图。
 当时的解决过程大体如下，仅供大家参考。 1.依旧拿出法宝——Google，不想这次却彻底没戏，有同样问题的人不少，唯独...
				Windows和MacOS各有其优劣。Windows的优点在于它比较普及，大部分软件都是为Windows系统编写的。 Windows还支持很多硬件设备，更适合专业游戏玩家。另外，Windows的价格相对较低，因为它在大部分计算机上都预安装。 
MacOS的优点在于它更加直观，易于上手，因为它很注重用户体验。MacOS的图形用户界面更加美观，好看。其次，MacOS系统非常稳定，很少出现崩溃的情况。它专为Apple硬件设备定制，所以很好的兼容Apple的硬件，算是相关性比较强的一种操作系统。而且,MacOS是为开发人员打造的，它自带了一些强大的开发工具，更适合程序员。当然，要享受MacOS系统，你需要花比Windows更高的价格。