【VB界面化选择代码】分享，个人觉得这个比较精华

个人觉得这个比较精华



Public Sub Workbook_Open()

    '打开文件时运行

    Call Recount_Open

End Sub



'main

Public Sub CreateSheets(sheetName As String)

    '#############################################################

    '筛选出第11列值为Y和B的行

    'Sheets("需求表").Select

    'Rows(1).Select

    'Selection.AutoFilter Field:=11, Criteria1:=Array(sheetName), Operator:=xlFilterValues

    '选择复制粘贴

    'Cells.Select

    'Selection.Copy



    '选择复制[与以上注释的作用一样，此语句速度快些]

    With Sheets("需求表")

        .Rows(1).AutoFilter Field:=11, Criteria1:=Array(sheetName), Operator:=xlFilterValues

        .Cells.Copy

    End With

    '粘贴

    'Sheets(sheetName).Select

    'Range("A1").Select

    'ActiveSheet.Paste



    '粘贴[与以上注释的作用一样，此语句速度快些]

    With Sheets(sheetName)

        .Range("A1").Select

        ActiveSheet.Paste

    End With



    '取消筛选

    'Sheets("需求表").Select

    'Rows(1).Select

    'Selection.AutoFilter

    With Sheets("需求表")

        .Rows(1).AutoFilter

    End With

End Sub

--------------------编程问答--------------------



Sub Recount()

    '运行重新统计

    RecountForm.Show

End Sub



Public Sub Recount_Open()

    'Sheets(1).Select

    Dim allrows, tempallrows, tempsheetsMun As Integer

    'Sheets("需求表").Select

    '计算需求表的总行数

    For allrows = 1 To 32325

        If Sheets("需求表").Cells(allrows, 2).Value = "" Then

            allrows = allrows - 1

            Exit For

        End If

    Next

    '新建一个temp的Sheet

    For tempsheetsMun = 1 To 256

        If Sheets(tempsheetsMun).Name = "temp" Then

            Exit For

        ElseIf Sheets(tempsheetsMun).Name <> "temp" And tempsheetsMun = Sheets.Count Then

            Sheets.Add After:=Sheets(Sheets.Count)

            ActiveSheet.Name = "temp"

        End If

    Next

    With Sheets("需求表")

        '.Select

        .Range("$K$2" & ":" & "$K$" & allrows).Copy

    End With



    'Sheets("需求表").Select

    '选中要进行分类的列，从这列中查找出相关的值

   ' ActiveSheet.Range("$K$2" & ":" & "$K$" & allrows).Select

    'Selection.Copy

    With Sheets("temp")

        .Select

        .Range("A1").Select

        ActiveSheet.Paste

        '取消边框和取消颜色

        Call 取消边框

        Call 取消颜色

        '去除重复值，留下唯一值

        ActiveSheet.Range("$A$1" & ":" & "$A$" & allrows - 1).RemoveDuplicates Columns:=1, Header:=xlNo

        '去除重复值后的行数

        For tempallrows = 1 To 32325

            If .Cells(tempallrows, 1).Value = "" Then

                tempallrows = tempallrows - 1

                Exit For

            End If

        Next tempallrows

        Dim listbox_Mum As Integer

        For listbox_Mum = 1 To tempallrows

            StartForm.ListBox.AddItem .Cells(listbox_Mum, 1).Value

        Next listbox_Mum

    End With



    '使多选框可以选择多个值

    StartForm.ListBox.MultiSelect = fmMultiSelectMulti

    Load StartForm

    StartForm.Show

    Sheets("需求表").Select

    'ActiveWorkbook.Save

End Sub

--------------------编程问答--------------------



'sub funcation



Sub 设置边框(rowT As String, columnT As String)

'

'设置边框

'注意一定要先选中要取消的单元格

    Range(rowT, columnT).Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

    With Selection.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlInsideVertical)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlInsideHorizontal)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    rowT = ""

    columnT = ""

End Sub



Sub 取消边框()

'取消边框

'注意一定要先选中要取消的单元格

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

    Selection.Borders(xlEdgeLeft).LineStyle = xlNone

    Selection.Borders(xlEdgeTop).LineStyle = xlNone

    Selection.Borders(xlEdgeBottom).LineStyle = xlNone

    Selection.Borders(xlEdgeRight).LineStyle = xlNone

    Selection.Borders(xlInsideVertical).LineStyle = xlNone

    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub



Sub 取消颜色()

'取消选中的单元格颜色

'取消边框

'注意一定要先选中要取消的单元格

    With Selection.Interior

    .Pattern = xlNone

    .TintAndShade = 0

    .PatternTintAndShade = 0

    End With

End Sub

'界面代码 确定窗口

Private Sub CommandButtonNO_Click()

    Unload RecountForm

End Sub



Private Sub CommandButtonYES_Click()

    Unload RecountForm

    '调用与workbook_open()一样的宏

    Call Recount_Open

End Sub

--------------------编程问答--------------------



'选择窗口

Private Sub ButtonCancel_Click()

    Unload StartForm

    '不提示警告信息

    Application.DisplayAlerts = False

        On Error Resume Next

            Sheets("temp").Delete

        On Error GoTo 0

    Application.DisplayAlerts = True

End Sub



Private Sub ButtonYES_Click()

    Dim select_Mum, sheets_Mun, NowsheetNum As Integer

    Dim SFLB As Object

    Dim Flag As Boolean

    Set SFLB = StartForm.ListBox

         '不提示警告信息

    Application.DisplayAlerts = False

    '删除名字不是"需求表"或"temp"的sheet

    

    For sheets_Mun = 5 To 256

        On Error Resume Next

        If Sheets(5).Name <> "temp" Or Sheets(5).Name <> "需求表" Or Sheets(5).Name <> "迭代表" Or Sheets(5).Name <> "人员表" Then

            Sheets(5).Delete

        ElseIf sheets_Mun = Sheets.Count Or Sheets(5).Name = "temp" Then

            Exit For

        Else

            Sheets(5).Delete

        End If

        On Error GoTo 0

    Next sheets_Mun

    '设置为删除可提示

    Application.DisplayAlerts = True



    For select_Mum = 0 To SFLB.ListCount - 1

        If SFLB.Selected(select_Mum) = True Then

            Sheets.Add After:=Sheets(Sheets.Count)

            ActiveSheet.Name = SFLB.List(select_Mum)

            Call CreateSheets(SFLB.List(select_Mum))

            Flag = True

        ElseIf SFLB.Selected(select_Mum) = False Then

            Flag = Flag Or False

        End If

        

        

    Next select_Mum



    '不提示警告信息

    Application.DisplayAlerts = False

        On Error Resume Next

            Sheets("temp").Delete

        On Error GoTo 0

    Application.DisplayAlerts = True

    

    If Flag = True Then

        Unload StartForm

        'ActiveWorkbook.Save

        'MsgBox Prompt:="运行结束！", Title:="警告！"

    ElseIf Flag = False Then

        MsgBox Prompt:="您没有选择参数！", Title:="警告"

    End If

    

End Sub



Private Sub CheckBoxAll_Click()

    Dim M As Integer

    Dim SFLB As Object

    Set SFLB = StartForm.ListBox

    '全选状态

    If CheckBoxAll.Value = True Then

        For M = 0 To SFLB.ListCount - 1

            SFLB.Selected(M) = True

            If M = SFLB.ListCount - 1 Then

                Exit For

            End If

        Next M

        '设置确定按钮可用

        'ButtonYES.Enabled = True

    End If

    '全否状态

    If CheckBoxAll.Value = False Then

        For M = 0 To SFLB.ListCount - 1

            SFLB.Selected(M) = False

            If M = SFLB.ListCount - 1 Then

                Exit For

            End If

        Next M

        '设置确定按钮不可用

        'ButtonYES.Enabled = False

    End If

End Sub

'###################

'Private Sub ListBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

 '   Dim M As Integer

 '   Dim Flag As Boolean

 '   Dim SFLB As Object

    

 '   Set SFLB = StartForm.ListBox

  

  '  Flag = False

  '  For M = 0 To SFLB.ListCount - 1

  '      If SFLB.Selected(M) = True Then

  '          Flag = True

  '      ElseIf SFLB.Selected(M) = False And Flag > 0 Then

  '          Flag = Flag ^ False

  '      End If

  '  Next M

'End Sub

--------------------编程问答-------------------- 没法再连击了吧？ --------------------编程问答--------------------

--------------------编程问答-------------------- 感谢lz的分享

--------------------编程问答-------------------- 多谢分享…………………… --------------------编程问答--------------------

引用 4 楼 sysdzw 的回复:

没法再连击了吧？

可以多选的
关键语句：
'使多选框可以选择多个值
StartForm.ListBox.MultiSelect = fmMultiSelectMulti
--------------------编程问答-------------------- 经典中的精品呀。 --------------------编程问答-------------------- 先写个整体功能的简单说明呗。 --------------------编程问答-------------------- 刚刚才看看粘少了一点代码，这几个全局变量没定义到，现补上。



'定义全局变量

Option Explicit

Public tempStart, tempEnd, allrows As Integer

--------------------编程问答--------------------

看不懂做什么的

For allrows = 1 To 32325
=> For allrows = 1 To XLsApp.ActiveCell.row

补充：VB ,  VBA