05_筛选标记5.0版最终版 多选项文件夹批量操作

项目知识点总结

1.Public 可以声明公共变量

2.Inputbox 对话输入框(默认返回值为文本格式)

3.label1: 标签操作 常配合GoTo标签作跳转使用

4.vbCrLf和 chr(13) & chr(10)回车换行操作

5. Select Case xxx
	case 1
	case 2
	...
	case Else
   End Select 

6.Floder 文件夹操作

7.set 变量 = nothing  释放内存变量

8.VBProject.VBComponents 工程窗体组件

9.VBA.Split(Town, ",") '---拆分数组

10.Find 查找 定位/取列和行

11.AutoFilter自动筛选

12.表格格式取消筛选标记

13. Workbooks.Add '新建一个Excel工作簿

代码如下

Public Town As String
Public TArr() As String
Public TownSheet, firstAddress, ACN
Public wsh As Worksheet
Public num

Sub 选项确认()
       
label1:

    num = InputBox("请根据数字选择对应操作功能!" & vbCrLf & _
      "                                 " & vbCrLf & _
     "  1.表格筛选     1.普通  (11.田组 12.刘组) " & vbCrLf & _
    "                                 " & vbCrLf & _
     "  2.文件夹筛选   2.普通  (21.田组 22.刘组) " & vbCrLf & _
      "                                 " & vbCrLf & _
    "   3.表格取消筛选" & vbCrLf & _
    "                                 " & vbCrLf & _
    "   4.文件夹取消筛选" & vbCrLf & _
    "                                 " & vbCrLf & _
     "   0.取消 ")
     
    Select Case num
     Case 0
     Case 1, 11, 12
            Call xlApp '表筛选
     Case 2, 21, 22, 4
            If ThisWorkbook.FullName <> "D:\NewFile.xlsx" Then Call 文件夹提示
            Call Folder '文件夹
     Case 3
            Call Cancel '表取消
     Case Else
          MsgBox ("你输入的数字有误请重新输入!")
          GoTo label1:
      End Select

End Sub
Sub Folder()
    Dim myPath$, myFile$, myPath1$, myPath2$, WB As Workbook, new_book As Workbook, yes_no '这个$ 是相当于定义字符串
      
    '调用函数，获取用户选择的文件夹，并且在最后加上一个反斜杠，用于下面的文件列表获取
    myPath2 = ChooseFolder  '这里的路径是没有加入最后的"\"的
    myPath = myPath2 & "\"
    
    myPath1 = InStrRev(myPath2, "\") '从右向左查找"\"，返回其所在的位置，返回值是一个数字，但是最后会变成一个字符串，所以定义的时候也定义了一个字符串
    If myPath1 = 0 Then
        myPath1 = ""    '如果找不到"\"，那么就说明用户选择是主硬盘，如：C:\\等，这样就 返回空值
    Else
        myPath1 = Right(myPath2, Len(myPath2) - myPath1) & "_" '如果不是空值，那么就直接可以使用Right提取，使用最开始没有"\"的myPath2这个变量，
    End If
    
    myFile = Dir(myPath & "*.xls*") '依次找寻指定路径中的*.xls，或者xlsx文件
    
    Do While myFile <> "" '当指定路径中有文件时进行循环
           
        If myFile <> ThisWorkbook.Name Then   '如果我们这个宏文件在需要处理的文件夹之中，这个判断就会跳过下面的操作
            
            Set WB = Workbooks.Open(Filename:=myPath & myFile, UpdateLinks:=0) '打开符合要求的文件，并且如果遇到需要更新链接的时候，默认不更新
            
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            
            Select Case num

            Case 2, 21, 22
                Call xlApp
            Case 4
                Call Cancel
            End Select
            
            On Error Resume Next
            WB.Close 0  '保存关闭文件 0代表FALSE,-1代表TRUE
            
        End If
        myFile = Dir '找寻下一个*.xls，或者xlsx文件
    Loop
    Set WB = Nothing    '释放变量内存
    MsgBox ("兄台，已完成")
    
   ' Application.VBE.ActiveVBProject.VBComponents.Remove VBComponent:=sht.Item
    
    'Application.EnableEvents = True
    'Application.VBE.MainWindow.Visible = False
    'Excel.Application.Quit
    End
    Exit Sub
End Sub

Sub xlApp()

    Call Cancel  ' 初始化表格状态
    
    Select Case num
     Case 1, 2
          Town = InputBox("请输入街道名称!")  '街道输入
     Case 11, 21
         Town = ("xxx,xxx,xxx,xxx") '田组
     Case 12, 22
         Town = ("xxx,xxx,xxx,xxx") '刘组
    End Select
       
    ' Town = InputBox("请输入街道名称!")  '街道输入
    'Town = Text1.Text
     
    
    TArr() = VBA.Split(Town, ",") '-----数组
    
    For Each wsh In Sheets     '表格循环
        wsh.Select
        
        With wsh.UsedRange
             Call 标记
             Call 筛选
        End With
        
    Next wsh
    Excel.Worksheets(1).Select
    
    If num = "2" Or num = "21" Or num = "22" Then
        ActiveWorkbook.Close -1
    Else:
        del
        MsgBox ("兄台，已完成!")
    End If
    
    
End Sub
Sub 标记()
        ' wsh.Activate
        Dim a
        
        For Each TownSheet In TArr()
        
            Set a = wsh.UsedRange.Find(What:=TownSheet)

            If Not a Is Nothing Then
            
                firstAddress = a.Address
                
                ACN = Range(firstAddress).Column
                
                wsh.Tab.ColorIndex = 6
                
            Else
                Debug.Print (ActiveWorkbook.Name & ";" & wsh.Name & ";找不到")
            End If
        Next
End Sub

Sub 筛选()
   ' MsgBox (Range(firstAddress).Column)
   If firstAddress <> "" Then
        'Selection.AutoFilter
        wsh.Range(firstAddress).AutoFilter Field:=ACN, Criteria1:=TArr(), Operator:=xlFilterValues '条件数组
        firstAddress = ""
    End If
    'Worksheets(1).Range("$F$2").AutoFilter Field:=6, Criteria1:="学院路街道", Operator:=xlFilterValues '条件数组'
    
End Sub
Sub Cancel() '取消筛选标记
    Dim wsh As Object
    
    For Each wsh In Sheets
        wsh.Tab.ColorIndex = -4142 '取消颜色标记,取消筛选，取消隐藏
        wsh.AutoFilterMode = False
        Cells.EntireRow.Hidden = False
        Cells.EntireColumn.Hidden = False
    Next wsh

End Sub
Public Function ChooseFolder() As String    '定义函数，用于下面的调用
    '定义并新建一个对话框对象
    Dim dlgOpen As FileDialog
    Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
    
    '如果当前没有对话框显示，就让他弹出对话框
    If dlgOpen.Show = -1 Then ChooseFolder = dlgOpen.SelectedItems(1)
    Set dlgOpen = Nothing
End Function

Sub del() '删除模块
    Dim sht As Object
    Set sht = Application.VBE.ActiveVBProject.VBComponents
    sht.Remove VBComponent:=sht.Item("D最新筛选多选项230131v")
End Sub

Sub 文件夹提示()
    Dim n
         
  n = InputBox("是否创建新工作簿以解除占用(输入对应数字)" & vbCrLf & "1.是 " & vbCrLf & "2.否")

    If n = 1 Then
        MsgBox ("正在创建新工作簿D:\NewFile.xlsx!.....")
        
        Workbooks.Add '新建一个Excel工作簿
        
        
        ActiveWorkbook.SaveAs Filename:="D:\NewFile.xlsx" ',Password:=123将工作簿保存，路径为F:\MyVBA，命名为new，打开工作簿密码为123
        
        Call CopyCode
        
        ThisWorkbook.Close -1
    End If
    
    
End Sub

Sub CopyCode() ' 添加复制代码----
  Dim s$
  s = ThisWorkbook.VBProject.VBComponents("D最新筛选多选项230131v").CodeModule.Lines(1, 300)
 ' Debug.Print s
 
 vbext_ct_StdModule = 1
 
 With ActiveWorkbook.VBProject
 
    .VBComponents.Add(vbext_ct_StdModule).Name = "模块1"
 
    .VBComponents("模块1").CodeModule.AddFromString s
 End With
 
End Sub