小花鹿学习VBA记录

小花鹿

Sub MoveToCurrentLineStart()  ' 移动光标至当前行首  ' Selection.HomeKey wdLine  Selection.HomeKey unit:=wdLineEnd Sub
Sub MoveToCurrentLineEnd()  ' 移动光标至当前行尾  ' Selection.EndKey wdLine  Selection.EndKey unit:=wdLineEnd Sub
Sub SelectToCurrentLineStart()  ' 选择从光标至当前行首的内容  ' Selection.HomeKey wdLine, wdExtend  Selection.HomeKey unit:=wdLine, Extend:=wdExtendEnd Sub
Sub SelectToCurrentLineEnd()  ' 选择从光标至当前行尾的内容  ' Selection.EndKey wdLine, wdExtend  Selection.EndKey unit:=wdLine, Extend:=wdExtendEnd Sub
Sub SelectCurrentLine()  ' 选择当前行  ' Selection.HomeKey wdLine  ' Selection.EndKey wdLine, wdExtend  Selection.HomeKey unit:=wdLine  Selection.EndKey unit:=wdLine, Extend:=wdExtendEnd Sub
Sub MoveToDocStart()  ' 移动光标至文档开始  ' Selection.HomeKey wdStory  Selection.HomeKey unit:=wdStoryEnd Sub
Sub MoveToDocEnd()  ' 移动光标至文档结尾  ' Selection.EndKey wdStory  Selection.EndKey unit:=wdStoryEnd Sub
Sub SelectToDocStart()  ' 选择从光标至文档开始的内容  ' Selection.HomeKey wdStory, wdExtend  Selection.HomeKey unit:=wdStory, Extend:=wdExtendEnd Sub
Sub SelectToDocEnd()  ' 选择从光标至文档结尾的内容  ' Selection.EndKey wdStory, wdExtend  Selection.EndKey unit:=wdStory, Extend:=wdExtendEnd Sub
Sub SelectDocAll()  ' 选择文档全部内容（从WholeStory可猜出Story应是当前文档的意思）  Selection.WholeStoryEnd Sub
Sub MoveToCurrentParagraphStart()  ' 移动光标至当前段落的开始  ' Selection.MoveUp wdParagraph  Selection.MoveUp unit:=wdParagraphEnd Sub
Sub MoveToCurrentParagraphEnd()  ' 移动光标至当前段落的结尾  ' Selection.MoveDown wdParagraph  Selection.MoveDown unit:=wdParagraphEnd Sub
Sub SelectToCurrentParagraphStart()  ' 选择从光标至当前段落开始的内容  ' Selection.MoveUp wdParagraph, wdExtend  Selection.MoveUp unit:=wdParagraph, Extend:=wdExtendEnd Sub
Sub SelectToCurrentParagraphEnd()  ' 选择从光标至当前段落结尾的内容  ' Selection.MoveDown wdParagraph, wdExtend  Selection.MoveDown unit:=wdParagraph, Extend:=wdExtendEnd Sub
Sub SelectCurrentParagraph()  ' 选择光标所在段落的内容  ' Selection.MoveUp wdParagraph  ' Selection.MoveDown wdParagraph, wdExtend  Selection.MoveUp unit:=wdParagraph  Selection.MoveDown unit:=wdParagraph, Extend:=wdExtendEnd Sub
Sub DisplaySelectionStartAndEnd()  '显示选择区的开始与结束的位置，注意：文档第1个字符的位置是0  MsgBox ("第" & Selection.Start & "个字符至第" & Selection.End & "个字符")End Sub
Sub DeleteCurrentLine()  ' 删除当前行  ' Selection.HomeKey wdLine  ' Selection.EndKey wdLine, wdExtend  Selection.HomeKey unit:=wdLine  Selection.EndKey unit:=wdLine, Extend:=wdExtend  Selection.DeleteEnd Sub
Sub DeleteCurrentParagraph()  ' 删除当前段落  ' Selection.MoveUp wdParagraph  ' Selection.MoveDown wdParagraph, wdExtend  Selection.MoveUp unit:=wdParagraph  Selection.MoveDown unit:=wdParagraph, Extend:=wdExtend  Selection.DeleteEnd Sub


补充内容 (2016-11-24 10:36):
Sub shishi()
    With ActiveDocument.Content.Find
        .Text = "大家"
        Do While .Execute
            .Parent = "我们"
            .Parent.Font.Size = 14
            .Parent.Collapse wdCollapseEnd
        Loop
    End With
End Sub

补充内容 (2016-11-24 10:38):
ActiveDocument.Content.Find.Execute 代表什么？
   ActiveDocument.Content.Find.Parent 代表什么？ActiveDocument.Content代表当前活动文档的range对象（全文档区域）
ActiveDocument.Content.Find代表返回一个 Find 对象
ActiveDocument.Content.Find.Execute 运行指定的查找操作。如果查找成功，则返回 True。Boolean 类型。
ActiveDocument.Content.Find.Parent返回Find对象的父对象。注释：说白了就是返回“查找到的”的range对象（就是查找到的区域）

补充内容 (2016-11-25 08:38):
返回一个 Find 对象，该对象包含了查找操作所需的条件。只读。

注释  将本属性用于 Selection 对象时，如果查找到了所需内容，则所选内容就会改变。如将本属性用于 Range 对象，则除非用 Select 方法，否则所选内容不改变。


补充内容 (2016-11-25 08:44):
Sub shishi()
    With ActiveDocument.Content.Find
        .ClearFormatting
        .Text = "公司"
        Do While .Execute
            .Parent = "我们"
            .Parent.Font.Size = 14
            .Parent.Collapse wdCollapseEnd
        Loop
    End With
End Sub

补充内容 (2017-1-19 10:16):
Sub test123()
Dim d, reg, docs, mys, n, n1, mdoc, myrange, thisdoc
Set d = CreateObject("scripting.dictionary")
Set reg = CreateObject("vbscript.regexp")
Set thisdoc = ActiveDocument
reg.Global = True
reg.IgnoreCase = False
reg.MultiLine = True
reg.Pattern = "^([\(（]\d[\)）])((?![\(（]\d[\)）]).)+"
docs = ActiveDocument.Range
For Each mys In reg.Execute(docs)
    n = mys.FirstIndex
    n1 = mys.Length
    Set myrange = thisdoc.Range(n, n1 + n)
    Set mdoc = Documents.Add
    mdoc.Range.FormattedText = myrange.FormattedText
Next mys
End Sub


补充内容 (2017-1-19 10:17):
Sub abcd()
    Dim mt, oRng As Range, n&, m&, str$, Unm, k()
    Dim d, Ydoc As Document, Mdoc As Document
    Set Ydoc = ThisDocument
    Set d = CreateObject("Scripting.Dictionary")
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True: reg.IgnoreCase = False: reg.MultiLine = True
    reg.Pattern = "^[(（]\s*(\d+)\s*[)）](?:(?!^[(（]\s*\d+\s*[)）]).)+"
    str = Replace(Ydoc.Content, Chr(7), "")
    For Each mt In reg.Execute(str)
        Unm = mt.submatches(0)
        m = mt.FirstIndex: n = mt.Length
        Set oRng = Ydoc.Range(m, m + n)
        Set d(Unm) = oRng
    Next
    k = d.keys: WordBasic.SortArray k()
    Set Mdoc = Documents.Add
    For i = 0 To d.Count - 1
        With Mdoc.Content
            .Collapse 0
            .FormattedText = d(CStr(k(i))).FormattedText
        End With
    Next
End Sub

小花鹿

下列代码来自本站，有所修改，谢谢原作者：

Function idtest(theid)
    Dim arr As Variant, brr() As Variant, a As Variant, b As Variant, theFinalRow&, id
    Dim i&, j&, theSum&, theNum&, theStr$, theDate As Date, theYear&, theMonth&, theDay&, theAge&
    idtest = "身份证校验通过"
        theDate = Date
        a = VBA.Array(7, 9, 10, 5, 8, 4, 2, 1, 6, 3, 7, 9, 10, 5, 8, 4, 2)
        b = VBA.Array("1", "0", "X", "9", "8", "7", "6", "5", "4", "3", "2")
        theSum = 0
        If theid <> "" Then
            If Len(theid) = 18 Then
                For j = 1 To 17
                    theSum = theSum + CLng(Mid(theid, j, 1)) * a(j - 1)
                Next j
                theNum = theSum Mod 11
                If UCase(Right(theid, 1)) <> b(theNum) Then
                    idtest = "身份证校验码不正确"
                Else
                    theYear = Mid(theid, 7, 4)
                    theMonth = Mid(theid, 11, 2)
                    theDay = Mid(theid, 13, 2)
                    theStr = theYear & "-" & theMonth & "-" & theDay
                    If Not IsDate(theStr) Then
                        idtest = "身份证日期有误"
                    Else
                        theAge = DateDiff("yyyy", CDate(theStr), theDate)
                        If theAge < 0 Or theAge > 130 Then '小于0岁或大于130岁判为不正常
                            idtest = "身份证日期不正常"
                        End If
                    End If
                End If
            Else
                idtest = "身份证长度不正确"
            End If
        End If
        If idtest = "身份证校验通过" Then
            theYear = Mid(theid, 7, 4)
            theMonth = Mid(theid, 11, 2)
            theDay = Mid(theid, 13, 2)
            theStr = theYear & "-" & theMonth & "-" & theDay
            theAge = DateDiff("yyyy", CDate(theStr), theDate)
            idtest = theAge & "|" & idtest
        End If
End Function





补充内容 (2017-4-13 11:02):
Function IDcheck(ID)  '身份证号码校验函数
Dim s, i As Integer
Dim e, z As String
Part1: '----------------------------身份证号码合法性检查---------------------------------------
If Not (Len(ID) = 18 Or Len(ID) = 15) Then                   '位数检验
   IDcheck = "位数错误"
   Exit Function
   Else
   If Len(ID) = 15 Then ID = Left(ID, 6) & "19" & Right(ID, 9)
   If IsNumeric(Left(ID, 17)) = False Or InStr(ID, ".") > 0 Then                      '字符检验
      IDcheck = "字符错误"
      Exit Function
   End If
   On Error Resume Next                                                               '日期检验
   If DateValue(Mid(ID, 7, 4) & "-" & Mid(ID, 11, 2) & "-" & Mid(ID, 13, 2)) < 1 Or _
      DateValue(Mid(ID, 7, 4) & "-" & Mid(ID, 11, 2) & "-" & Mid(ID, 13, 2)) > Date Then
      IDcheck = "日期错误"
      Exit Function
   End If
End If
Part2: '-----------------------------校验码的生成及检查----------------------------------------
s = 0
For i = 1 To 17
   s = s + Val(Mid(ID, 18 - i, 1)) * (2 ^ i Mod 11)
Next
e = Mid("10X98765432", (s Mod 11) + 1, 1)                                           '生成校验码
If Len(ID) = 18 Then
   z = UCase(Right(ID, 1))
   If z = e Then                                                                    '校验码对比
      IDcheck = "通过"
      Else
      IDcheck = "校验未通过"                   '如果要返回校验码，请把本行语句改为：IDcheck = e
   End If
   Else
   IDcheck = "通过"   'ID & e   '15位身份证号码升位
End If
End Function

小花鹿

Sub 遍历子文件夹()
Dim d, thispath, thisname, n&, m&, x&, mydir, dk
Set d = CreateObject("scripting.dictionary")
thispath = ThisWorkbook.Path & "\"
thisname = ThisWorkbook.Name
d(thispath) = ""
Do While n < d.Count
    dk = d.keys
    mydir = Dir(dk(n), vbDirectory)
    Do While mydir <> ""
        If mydir <> "." And mydir <> ".." Then
            If GetAttr(dk(n) & mydir) And vbDirectory Then
                d(dk(n) & mydir & "\") = ""
                m = m + 1
                Cells(m, 1) = dk(n) & mydir & "\"
            Else
                x = x + 1
                Cells(x, 7) = dk(n) & mydir
            End If
        End If
        mydir = Dir
    Loop
    n = n + 1
Loop
End Sub


If GetAttr(dk(n) & mydir) = 8208 Then

Private Sub Test()
    Dim Smail, Pword, Tmail, zhuti, zhengwen, fujian
    Shell "regsvr32 /s " & ThisWorkbook.Path & "\Jmail.dll"
    SendMail Smail, Pword, Tmail, zhuti, zhengwen, fujian
End Sub
Sub SendMail(username, password, SendTo, ByVal sSubject As String, ByVal sBody As String, ByVal sFileName As String)
    Dim email
    Set email = CreateObject("jmail.Message")
    email.Charset = "gb2312"
    email.Silent = False
    email.Priority = 1
    email.MailServerUserName = username
    email.MailServerPassWord = password
    email.FromName = username
    email.From = username
    email.Subject = sSubject
    email.AddRecipient SendTo
    email.body = sBody
    If sFileName <> "" Then email.AddAttachment sFileName
    email.send ("smtp.163.com")
    email.Close
    Set email = Nothing
End Sub
ToEmail.rar (205.72 KB, 下载次数: 19)

2016-12-21 12:23 上传

点击文件名下载附件

microyip

牛啊，还能整出这么一出出来

小花鹿

VBA工程加锁解锁器更新版（支持07版格式）
http://club.excelhome.net/thread-1315235-1-1.html
2007-201x.rar (1011 Bytes, 下载次数: 30)

2016-12-1 20:32 上传

点击文件名下载附件

Sub test(control As IRibbonControl)


Sub setpicsize()
Dim n
On Error Resume Next
For n = 1 To ActiveDocument.InlineShapes.Count
MsgBox ActiveDocument.InlineShapes(n).Height
ActiveDocument.InlineShapes(n).Height = 400
ActiveDocument.InlineShapes(n).Width = 300
Next n
For n = 1 To ActiveDocument.Shapes.Count
ActiveDocument.Shapes(n).Height = 400
ActiveDocument.Shapes(n).Width = 300
Next n
End Sub

ActiveDocument.InlineShapes(n).LockAspectRatio = msoFalse

Shape 对象代表文档中的图形对象，InlineShape 代表文档中的嵌入式图形对象。

所谓嵌入式图形对象，是指将图像作为文字处理，在排版上以文字的方式进行排版。

Shape 与 InlineShape 对象在文档中分别属于 Shapes 集合与 InlineShapes 集合。

通过 Shape 对象的 ConvertToInlineShape 方法可以将 Shape 对象转换为 InlineShape 对象。

通过 InlineShape 对象的 ConvertToShape 方法可将 InlineShape 对象转换为 Shape 对象。

Shapes 集合与 InlineShapes 集合都有 AddPicture 方法，用于在文档中插入图片。两方法的定义如下：

Shapes：

Function AddPicture(FileName As String, [LinkToFile], [SaveWithDocument], [Left], [Top], [Width], [Height], [Anchor]) As Shape

InlineShapes：

Function AddPicture(FileName As String, [LinkToFile], [SaveWithDocument], [Range]) As InlineShape

两个方法的不同在于插入的位置的不同：

InlineShapes 只能指定 Range 进行插入。这与文档中的文字插入是相同的。

Shapes 插入的图片可以任意定位。

雷达图表：

Sub 宏2()

Dim r&, i&, w, h, n, m&, h0

Range("a1").Activate

r = [a65536].End(3).Row

h0 = Range("a1:a" & r).Height + 20

For i = 3 To r

    ActiveSheet.Shapes.AddChart.Select

    With ActiveChart

        .ChartType = xlRadar

        .SetSourceData Source:=Range("E" & i & ":I" & i)

        .SeriesCollection(1).XValues = "=Sheet1!$E$1:$I$1"

        .SeriesCollection(1).Name = "=Sheet1!$A$" & i

        .Legend.Delete

        .ChartArea.Width = 300

        h = .ChartArea.Height

        w = .ChartArea.Width

        n = i Mod 2

        If n Then

            .ChartArea.Top = h0 + (h + 20) * m

            .ChartArea.Left = 30

        Else

            .ChartArea.Top = h0 + (h + 20) * m

            .ChartArea.Left = 30 + w + 20

            m = m + 1

        End If

    End With

Next i

End Sub

工作簿1.rar (27.28 KB, 下载次数: 15)

2017-1-13 10:55 上传

点击文件名下载附件

小花鹿

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships"><Relationship Id="rId3" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties" Target="docProps/app.xml"/><Relationship Id="customUIRelID" Type="http://schemas.microsoft.com/office/2006/relationships/ui/extensibility" Target="customUI/customUI.xml"/><Relationship Id="rId2" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" Target="docProps/core.xml"/><Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" Target="xl/workbook.xml"/></Relationships>


<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
  <ribbon startFromScratch="false">
   <tabs>
     <tab id="rxTabCustom1"
        label="我的功能"
        insertBeforeMso="TabEnd">
         <group id="myGroup1" label="我的命令">
             <button id="c1"
                 imageMso="SmartArtChangeColorsGallery"
                 size="normal"
                 label="汇总数据1"
                 onAction="test"/>
             <button id="c2"
                 imageMso="SmartArtChangeColorsGallery"
                 size="normal"
                 label="汇总数据2"
                 onAction="test"/>
             <button id="c3"
                 imageMso="SmartArtChangeColorsGallery"
                 size="normal"
                 label="汇总数据3"
                 onAction="test"/>            
          </group>     
          <group id="myGroup2" label="我的命令1">
             <button id="c11"
                 imageMso="SmartArtChangeColorsGallery"
                 size="normal"
                 label="汇总数据11"
                 onAction="test"/>
             <button id="c21"
                 imageMso="SmartArtChangeColorsGallery"
                 size="normal"
                 label="汇总数据21"
                 onAction="test"/>
             <button id="c31"
                 imageMso="SmartArtChangeColorsGallery"
                 size="normal"
                 label="汇总数据31"
                 onAction="test"/>            
          </group>
     </tab>     
   </tabs>   
  </ribbon>
</customUI>

小花鹿

Sub test()
Dim ar, d, i&, j&, tm, tm1, n&, s
Set d = CreateObject("scripting.dictionary")
ar = Sheet1.[a2].CurrentRegion
For i = 3 To UBound(ar)
    If Val(ar(i, 7)) > 0 Then
        d(ar(i, 2)) = Trim(d(ar(i, 2)) & " " & ar(i, 7) & " " & ar(i, 4))
    End If
    If Val(ar(i, 12)) > 0 Then
        tm1 = ar(i, 12): n = 0: s = 0
        tm = Split(d(ar(i, 2)), " ")
        Do While tm1 > 0
            If Val(tm(n)) >= tm1 Then
                s = s + tm(n + 1) * tm1
                tm(n) = tm(n) - tm1
                tm1 = 0
                Exit Do
            Else
                s = s + tm(n) * tm(n + 1)
                tm1 = tm1 - tm(n)
                tm(n) = 0
                n = n + 2
            End If
        Loop
        Cells(i, 14) = s
        tm = Join(tm, " ")
        d(ar(i, 2)) = tm
    End If
Next i
'one in one out
End Sub


补充内容 (2017-5-2 01:41):
Sub W()
    Dim p As Page, doc As Document
    For Each p In ActiveDocument.ActiveWindow.ActivePane.Pages
        With p.Rectangles(1).Range
            n = n + 1
            If Right(.Text, 1) = Chr(13) Then .End = .End - 1
            Set doc = Documents.Add(, , , 0)
            doc.Bookmarks("\endofdoc").Range.FormattedText = .FormattedText
            doc.ActiveWindow.View.Type = 4
            doc.SaveAs ThisDocument.Path & "\" & n & ".docx"
            doc.Close 0
        End With
    Next
End Sub

小花鹿

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Cancel = True
If TextBox1.Value = "" Then Exit Sub
Dim s, s1, s2, i&
s = TextBox1.Value
s1 = Split(s, ".")
'-----------------------------------------
If Val(s1(0)) > Val(s1(1)) Then  '6.2
    s = ListBox1.List(s1(0) - 1)
    For i = s1(0) - 2 To s1(1) - 1 Step -1
        ListBox1.List(i + 1) = ListBox1.List(i)
    Next i
    ListBox1.List(s1(1) - 1) = s
    ListBox1.Selected(s1(1) - 1) = True
Else                                          '2.6
    s = ListBox1.List(s1(0) - 1)
    For i = Val(s1(0)) To s1(1) - 1
        ListBox1.List(i - 1) = ListBox1.List(i)
    Next i
    ListBox1.List(s1(1) - 1) = s
    ListBox1.Selected(s1(1) - 1) = True
End If
'----------------------------------------
For s = 0 To ListBox1.ListCount - 1
    s2 = Split(ListBox1.List(s), "--")
    ListBox1.List(s) = (s + 1) & "--" & s2(1)
Next s
TextBox1.Value = ""
End Sub

Private Sub UserForm_Initialize()
Dim ar, i&
ar = Sheet1.[a1].CurrentRegion
For i = 1 To UBound(ar)
    ar(i, 1) = i & "--" & ar(i, 1)
Next i
Me.ListBox1.List = ar
TextBox1.SetFocus
End Sub
===================================================
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Cancel = True
If TextBox1.Value = "" Then Exit Sub
Dim s, s1, s2, i&
s = TextBox1.Value
s1 = Split(s, ".")
'-----------------------------------------
If Val(s1(0)) > Val(s1(1)) Then
    s = ListBox1.List(s1(0) - 1)
    For i = s1(0) - 2 To s1(1) - 1 Step -1
        ListBox1.List(i + 1) = ListBox1.List(i)
    Next i
    ListBox1.List(s1(1) - 1) = s
    ListBox1.Selected(s1(1) - 1) = True
Else
    s = ListBox1.List(s1(0) - 1)
    For i = Val(s1(0)) To s1(1) - 1
        ListBox1.List(i - 1) = ListBox1.List(i)
    Next i
    ListBox1.List(s1(1) - 1) = s
    ListBox1.Selected(s1(1) - 1) = True
End If
'----------------------------------------
For s = 0 To ListBox1.ListCount - 1
    s2 = Split(ListBox1.List(s), "--")
    ListBox1.List(s) = (s + 1) & "--" & s2(1)
Next s
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Text)
End Sub

Private Sub UserForm_Initialize()
Dim ar, i&, hi, hi1
ar = Sheet1.[a1].CurrentRegion
For i = 1 To UBound(ar)
    ar(i, 1) = i & "--" & ar(i, 1)
Next i
hi = 100
hi1 = UBound(ar) * 9.3
If hi1 > 50 * 9.3 Then hi1 = 50 * 9.3
If hi1 > hi Then hi = hi1
ListBox1.Height = hi
Me.Height = hi + 18
Me.ListBox1.List = ar
TextBox1.SetFocus
End Sub===================================================================

Option Explicit

Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode <> 38 And KeyCode <> 40 Then Exit Sub
Dim r&, s, s2
r = ListBox1.ListIndex
If r = -1 Then Exit Sub
If KeyCode = 40 Then
    If r = ListBox1.ListCount - 1 Then Exit Sub
    s = ListBox1.List(r)
    ListBox1.List(r) = ListBox1.List(r + 1)
    ListBox1.List(r + 1) = s
End If
If KeyCode = 38 Then
    If r = 0 Then Exit Sub
    s = ListBox1.List(r)
    ListBox1.List(r) = ListBox1.List(r - 1)
    ListBox1.List(r - 1) = s
End If
For s = 0 To ListBox1.ListCount - 1
    s2 = Split(ListBox1.List(s), "--")
    ListBox1.List(s) = (s + 1) & "--" & s2(1)
Next s
End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'Cancel = True
If TextBox1.Value = "" Then Exit Sub
Dim s, s1, s2, i&
s = TextBox1.Value
s1 = Split(s, ".")
'-----------------------------------------
If Val(s1(0)) > Val(s1(1)) Then
    s = ListBox1.List(s1(0) - 1)
    For i = s1(0) - 2 To s1(1) - 1 Step -1
        ListBox1.List(i + 1) = ListBox1.List(i)
    Next i
    ListBox1.List(s1(1) - 1) = s
    ListBox1.Selected(s1(1) - 1) = True
Else
    s = ListBox1.List(s1(0) - 1)
    For i = Val(s1(0)) To s1(1) - 1
        ListBox1.List(i - 1) = ListBox1.List(i)
    Next i
    ListBox1.List(s1(1) - 1) = s
    ListBox1.Selected(s1(1) - 1) = True
End If
'----------------------------------------
For s = 0 To ListBox1.ListCount - 1
    s2 = Split(ListBox1.List(s), "--")
    ListBox1.List(s) = (s + 1) & "--" & s2(1)
Next s
TextBox1.Value = ""
End Sub

Private Sub UserForm_Initialize()
Dim ar, i&, hi, hi1
ar = Sheet1.[a1].CurrentRegion
For i = 1 To UBound(ar)
    ar(i, 1) = i & "--" & ar(i, 1)
Next i
hi = 120
hi1 = UBound(ar) * 9.3
If hi1 > 50 * 9.3 Then hi1 = 50 * 9.3
If hi1 > hi Then hi = hi1
ListBox1.Height = hi
Me.Height = hi + 18
Me.ListBox1.List = ar
ListBox1.Selected(0) = True
End Sub

thzss

跟着小花鹿学习，受益不浅

moxi96

谢谢分享~~