小花鹿学习VBA记录

小花鹿

Option Explicit

Dim Darging, M As Boolean, Dt As Long, strTmp As String, ar
Private Sub CommandButton1_Click()
    ar = ListBox3.List
    Sheet1.Range("c1:c" & ListBox3.ListCount) = ar
    ListBox3.SetFocus
End Sub
Private Sub ListBox3_AfterUpdate()
    Dt = ListBox3.ListIndex
End Sub
Private Sub ListBox3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    M = False
    Sheet1.Cells(ListBox3.ListIndex + 1, "c").Select
End Sub
Private Sub ListBox3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        M = True
    Else
        M = False
    End If
End Sub
Private Sub ListBox3_Change()
    If Darging And M Then
        Darging = False
        strTmp = ListBox3.List(ListBox3.ListIndex)
        ListBox3.List(ListBox3.ListIndex) = ListBox3.List(Dt)
        ListBox3.List(Dt) = strTmp
        Dt = ListBox3.ListIndex
    End If
    ar = ListBox3.List
    Sheet1.Range("c1:c" & ListBox3.ListCount) = ar
    Sheet1.Cells(Dt + 1, "c").Select
    Darging = True
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
    ListBox3.Height = hi
    Me.Height = hi + 18
    Me.ListBox3.List = ar
    ListBox3.Selected(0) = True
End Sub
窗体调整目标及位置1.rar (22.13 KB, 下载次数: 25)

2017-5-7 14:57 上传

点击文件名下载附件

小花鹿

阿杜分享：
Sub 主程序()
    Dim rg As Range
    Set rg = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Range, Selection.Range)
    Call DP(rg)
End Sub
Function DP(selectRange As Range)
'    1、区域中的软回车替换为硬回车;
'    2、 清除区域中的段前和段尾空白;
'    3 、清除区域中的空段落
    sr$ = Chr$(32) & Chr$(9) & ChrW(12288) & ChrW(160)
    With selectRange
        With .Find
            .Execute "^11", , , 1, , , , 0, , "^p", 2
            .Execute "^p^w", , , 0, , , , 0, , "^p", 2
            .Execute "^w^p", , , 0, , , , 0, , "^p", 2
            .Execute "^13{2,}", , , 1, , , , 0, , "^p", 2
        End With
        With .Paragraphs(1).Range
            n& = Len(.Text) - 1: .SetRange .Start, .Start
            If .MoveEndWhile(sr, n) <> 0 Then: .Text = Empty
        End With
    End With
End Function


Sub deletepage()
    Dim p, doc As Document, s, i&, sp As Shape
    p = ActiveDocument.ActiveWindow.ActivePane.Pages.Count
    For i = p To 1 Step -1
        With ActiveDocument.ActiveWindow.ActivePane.Pages(i).Rectangles(1).Range
            s = .Text: n = 0
            For Each sp In .ShapeRange
                If sp.WrapFormat.Type <> 7 Then
                    n = n + 1
                End If
            Next
            s = .Text
            s = Replace(Replace(s, Chr(13), ""), Chr(12), "")
            If s = "" And n = 0 Then
                .Delete
            End If
        End With
    Next i
End Sub

Sub splitpage()
    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

小花鹿

Sub createchart()
Dim r&, i&, w, h, n, m&, h1&
Range("a1").Activate
r = [a65536].End(3).Row
For i = 2 To r
        ActiveSheet.Shapes.AddChart.Select
    With ActiveChart
        .ChartType = xlLine
        .SetSourceData Source:=Range("A" & i & ":F" & i)
        .SeriesCollection(1).XValues = "=Sheet1!$B$1:$F$1"
        .ChartType = xlLine
        .SetSourceData Source:=Range("A" & i & ":F" & i)
        .SeriesCollection(1).XValues = "=Sheet1!$B$1:$F$1"
        .ChartArea.Width = 300
        .ChartArea.Height = 200
        h = .ChartArea.Height
        w = .ChartArea.Width
        n = (i + 1) Mod 3
        .ChartArea.Top = 15 + 215 * h1
        .ChartArea.Left = 15 + 315 * n
        m = m + 1
        h1 = Int(m / 3)
    End With
Next i
End Sub

小花鹿

Sub test2()
Dim n&, r&, ar(), i&, s
With ThisDocument.Tables(1)
    r = .Rows.Count
    ReDim ar(1 To r, 1 To 2)
    n = .Range.Cells.Count
    For i = 1 To n
        .Range.Cells(i).Select
        r = Selection.Information(13)
        ar(r, 1) = ar(r, 1) & .Range.Cells(i).Range.Text
        ar(r, 2) = i
    Next i
    For i = UBound(ar) To 1 Step -1
        s = Replace(ar(i, 1), Chr(13) & Chr(7), "")
        If s = "" Then
            .Range.Cells(ar(i, 2)).Select
            Selection.Collapse
            Selection.Rows.Delete
        End If
    Next i
End With
End Sub

香川群子

比较2个字符串，按长度倒序返回其中的相同子字串。

例如《abcdefg》 和 《abctde》 中最大相同子字串=abc
设置n2=1时返回全部：abc;ab,bc,de;a,b,c,d,e

1. Function StrLenCmp$(s1$, s2$, Optional n2& = 0) '比较2字符串中的相同子字串
   
2.     If Len(s1) > Len(s2) Then t = s1: s1 = s2: s2 = t
   
3.     n = Len(s1)
   
4.     For j = n To n2 Step -1
   
5.         k = 0: s = ""
   
6.         For i = 1 To n - j + 1
   
7.             t = Mid(s1, i, j)
   
8.             If InStr(s2, t) Then k = 1: If InStr(s, t) = 0 Then s = s & "," & t
   
9.         Next
   
10.         If k Then If n2 Then ss = ss & ";" & Mid(s, 2) Else StrLenCmp = Mid(s, 2): Exit Function
    
11.     Next
    
12.     StrLenCmp = Mid(ss, 2)
    
13. End Function

复制代码

小花鹿 自己写注释吧。

ghoob

是最近才学习的吗？
隔行填充
=MOD(ROW(),2)=1    设置格式

ghoob

ghoob 发表于 2017-5-20 19:29
是最近才学习的吗？
隔行填充
=MOD(ROW(),2)=1    设置格式

学习需诶，我刚开始学习请多多指教

teshia

学习心得好样的

小花鹿

Sub test()
Dim p As Shape
     For Each p In Sheet1.Shapes
        If Not Application.Intersect(p.TopLeftCell, [b2]) Is Nothing Then
        p.Delete
        End If
    Next
End Sub

小花鹿

作者阿杜：
Sub FSO_提取全路径文件()
    Dim f As Object, fd As Object, fso As Object, Stack$(), top&
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then pPath$ = .SelectedItems(1) Else MsgBox "请选目标文件夹": Exit Sub
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    top = 1: ReDim Stack(0 To top)
    Do While top >= 1
        For Each f In fso.GetFolder(pPath).Files
            n = n + 1
            stxt = stxt & f.Path & Chr(13)
        Next
        For Each fd In fso.GetFolder(pPath).SubFolders
            Stack(top) = fd.Path: top = top + 1
            If top > UBound(Stack) Then ReDim Preserve Stack(0 To top)
        Next
        If top > 0 Then pPath = Stack(top - 1): top = top - 1
    Loop
    ActiveDocument.Content.Text = Empty
    ActiveDocument.Content.Text = stxt
    MsgBox "已提取：" & n & "个包含选择路径下的所有文件！"
End Sub