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

细说自动筛选和高级筛选通过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
    
Next


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
        
    Next
    
Next
If exists_f = True Then
 Debug.Print "sheet exists"
Else
 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"
    Else
    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
    
    
    
    
    Selection.copy
    On Error Resume Next
        Sheets("new").Select
    If Err Then Sheets.Add().Name = "new"
    Sheets("new").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 & ","

Next

ads = Left(ad, Len(ad) - 1)
Debug.Print ads
Debug.Print Range(ads).Address




'Range(ads).EntireRow.Delete

End Sub
Sub xx()
    Range("A1:L6").Columns.AutoFit
End Sub
Sub arr()
Dim MyArr(), MyRng As Range, NewRng As Range, a
Debug.Print ActiveSheet.Name


'''初始化
Set MyRng = Range("A1:B3")
MyArr = MyRng
'''处理
'''在
'区域输出
Debug.Print MyRng.Address
Debug.Print MyRng.value
For Each a In MyArr
Debug.Print a
Next



End Sub

Attribute VB_Name = "图表"
Option Explicit

Sub 宏1()
Attribute 宏1.VB_ProcData.VB_Invoke_Func = " \n14"
'
' 宏1 宏
'

'
    Columns("E:F").Select
End Sub
Sub 宏2()
Attribute 宏2.VB_ProcData.VB_Invoke_Func = " \n14"
'
' 宏2 宏
'

'
    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