VBA代码

excelhome论坛的版主说我大多数分享的都很初级，搞得我很不爽，以后就发这里了

这段代码用来写文件

　　Open strFilePath For Output As #1
    Print #1, ss
    Close #1

　　

这段代码用来读取txt文件，读json也没问题,strLine就是每一行读取的内容

    Dim strFilePath As String
    Dim strLine As String
    strFilePath = ActiveDocument.Path & "/" & "table.txt"
   
    Open strFilePath For Input As #1
    Do While Not EOF(1)
        Line Input #1, strLine
    Loop
    Close #1

　按标题来进行拆分文档

Sub divideByHeading()
    Dim oDoc As Object
    Dim oZd As Object
    Dim oFso As Object
    Dim oFd As Object
    Dim strFolderPath As String
    Dim strFilePath As String
    Dim strFileName As String
    Dim intHeadCount As Integer
    Dim intFileCount As Integer
    Dim i As Integer, j As Integer, k As Integer
    Dim intParaBeg As Long
    Dim intParaEnd As Long
    Dim intHeadingBeg As Long
    Dim intHeadingEnd As Long
    
    On Error Resume Next
    
    Application.ScreenUpdating = False
    
    Set oFso = CreateObject("scripting.filesystemobject")
    Set oFd = Application.FileDialog(msoFileDialogFilePicker)
    
    With oFd
        .AllowMultiSelect = True
        .Filters.Add "Word文档", "*.doc; *.docx; *.docm", 1
        .FilterIndex = 2
        '.InitialFileName = doc.Path
        .InitialView = msoFileDialogViewDetails
        
        If .Show = -1 Then
            intFileCount = .SelectedItems.Count
            For i = 1 To intFileCount
                strFilePath = .SelectedItems(i)
                strFileName = oFso.getbasename(strFilePath)
                
                Set oDoc = Documents.Open(strFilePath, , True)
                strFolderPath = oDoc.Path
                
                Dim arrHeadings As Variant
                
                ReDim arrHeadings(1 To 2, 1 To 1)
                
                '            Set oZd = CreateObject("scripting.dictionary")
                
                '循环段落，判断有标题 2的个数
                k = 1
                For Each para In oDoc.Paragraphs
                    If para.Style = "标题 2" Then
                        If k = 1 Then
                            arrHeadings(1, 1) = para.Range.Start
                            arrHeadings(2, 1) = para.Range.End
                        Else
                            ReDim Preserve arrHeadings(1 To 2, 1 To UBound(arrHeadings, 2) + 1)
                            arrHeadings(1, UBound(arrHeadings, 2)) = para.Range.Start
                            arrHeadings(2, UBound(arrHeadings, 2)) = para.Range.End
                        End If
                        k = k + 1
                    End If
                Next para
                ReDim Preserve arrHeadings(1 To 2, 1 To UBound(arrHeadings, 2) + 1)
                arrHeadings(1, UBound(arrHeadings, 2)) = oDoc.Content.End
                arrHeadings(2, UBound(arrHeadings, 2)) = oDoc.Content.End
                
                For k = 1 To UBound(arrHeadings, 2) - 1
                    intParaBeg = arrHeadings(1, k)
                    intParaEnd = arrHeadings(1, k + 1) - 1
                    intHeadingBeg = arrHeadings(1, k)
                    intHeadingEnd = arrHeadings(2, k) - 1
                    
                    If intHeadingEnd - intHeadingBeg > 1 Then
                        strFileName = oDoc.Range(intHeadingBeg, intHeadingEnd).Text
                        oDoc.Range(intParaBeg, intParaEnd).Select
                        Selection.Copy
                        Set oDocNew = Documents.Add
                        oDocNew.Content.Paste
                        oDocNew.SaveAs strFolderPath & "\" & strFileName & ".docx"
                        oDocNew.Close
                    End If
                Next k
                
                oDoc.Close
                
            Next i
            
        Else
            Exit Sub
        End If
        
    End With
    
    MsgBox "拆分完毕!"
End Sub

使用对话框打开文件或文件夹

Set oFso = CreateObject("scripting.filesystemobject")
    Set oFd = Application.FileDialog(msoFileDialogFilePicker)
    
    With oFd
        .AllowMultiSelect = False
        .Filters.Add "Word文档", "*.doc; *.docx; *.docm", 1
        .FilterIndex = 2
        '    .InitialFileName = doc.Path
        .InitialView = msoFileDialogViewDetails
        
        If .Show = -1 Then
            intFileCount = .SelectedItems.Count         Else
            Exit Sub
        End If
        
    End With

 

 

VBA中的正则表达式

Function regTest(ByVal strRegText As String, ByVal strPattern As String, ByVal oReg As Object) As Boolean
    Dim strMatch As String
    
    With oReg
        '设置是否匹配所有的符合项，True表示匹配所有, False表示仅匹配第一个符合项
        .Global = True
        '设置是否区分大小写，True表示不区分大小写, False表示区分大小写
        .IgnoreCase = True
        
        .Pattern = strPattern
        
        If .test(strRegText) Then
            regTest = True
        Else
            regTest = False
        End If
        
    End With
    
End Function

Function regMatch(ByVal strRegText As String, ByVal strPattern As String, ByVal oReg As Object)
    '''属性 pattern global ignorecase multiline
    '''方法 test replace execute
    Dim strMatch As String
    
    With oReg
        '设置是否匹配所有的符合项，True表示匹配所有, False表示仅匹配第一个符合项
        .Global = True
        '设置是否区分大小写，True表示不区分大小写, False表示区分大小写
        .IgnoreCase = True
        '设置要查找的字符模式
        .Pattern = strPattern
        
        '        '判断是否可以找到匹配的字符，若可以则返回True
        'MsgBox .test(sText)
        
        '对字符串执行正则查找，返回所有的查找值的集合，若未找到，则为空
        Set objmatches = .Execute(strRegText)
        
        If objmatches.Count = 1 Then
            strMatch = objmatches(0)
        Else
            MsgBox "error"
        End If
        
        '把字符串中用正则找到的所有匹配字符替换为其它字符
        'MsgBox .Replace(sText, "")
    End With
    
    regMatch = strMatch
    
End Function

利用正则表达式删除字符串中的所以空格

Public Function removeWhiteSpace(target As String) As String
    Dim oReg As Object
    Set oReg = CreateObject("vbscript.regexp")
    With oReg
        .Pattern = "\s"
        .MultiLine = True
        .Global = True
        removeWhiteSpace = .Replace(target, vbNullString)
    End With
    Set oReg = Nothing
    
End Function

 

三次样条插值

Sub interp1Main()
    Dim oWb As Object: Set oWb = ThisWorkbook
    Dim arrX0 As Variant
    Dim arrY0 As Variant
    Dim arrX As Variant
    Dim arrY As Variant
    
    Dim intX0RowsCount As Integer
    Dim intY0RowsCount As Integer
    Dim intXRowsCount As Integer
    Dim intYRowsCount As Integer
    
    With oWb.Worksheets("interp1")
        intX0RowsCount = .Cells(2, 2)
        intY0RowsCount = .Cells(2, 3)
        intXRowsCount = .Cells(2, 4)
        intYRowsCount = .Cells(2, 5)
        
        arrX0 = .Cells(3, 2).Resize(intX0RowsCount, 1)
        arrY0 = .Cells(3, 3).Resize(intY0RowsCount, 1)
        arrX = .Cells(3, 4).Resize(intXRowsCount, 1)
        arrY = interp1ByArray(arrX, arrX0, arrY0)
        .Cells(3, 5).Resize(UBound(arrY, 1), 1) = arrY
    End With
    
End Sub

Function interp1ByArray(arrX, arrX0, arrY0)
    '''arrX0:原始x坐标
    '''arrY0:原始y坐标
    '''arrX:处理后x坐标
    '''arrY:处理后y坐标
    Dim arrY As Variant
    ReDim arrY(1 To UBound(arrX, 1), 1 To 1)
    
    If UBound(arrX0, 1) <> UBound(arrY0, 1) Then
        MsgBox "两列源数据不一致"
    Else
        For i = LBound(arrX, 1) To UBound(arrX, 1)
            x = arrX(i, 1)
            arrY(i, 1) = 1 * interp1(x, arrX0, arrY0)
        Next i
    End If
    
    interp1ByArray = arrY
    
End Function

Function interp1(ByVal x As Single, ByVal arrX As Variant, ByVal arrY As Variant)
    Dim dblProduct As Double
    Dim dblsum As Double
    
    If x < arrX(1, 1) Then
        intIndex = 2
    ElseIf x <= arrX(UBound(arrX, 1), 1) Then
        '''找出x值在arrX中对应的序号intIndex
        For i = LBound(arrX, 1) + 1 To UBound(arrX, 1)
            xi = arrX(i, 1)
            xi_1 = arrX(i - 1, 1)
            If (x - xi_1) >= 0 And (x - xi) <= 0 Then
                If (i = UBound(arrX, 1)) Then
                    intIndex = i - 1
                    Exit For
                Else
                    intIndex = i
                    Exit For
                End If
            End If
        Next i
    Else
        intIndex = UBound(arrX, 1) - 1
    End If
    
    '''进行三点插值(抛物线插值)运算
    dblsum = 0
    For k = intIndex - 1 To intIndex + 1
        dblProduct = 1
        For j = intIndex - 1 To intIndex + 1
            If j <> k Then
                xj = arrX(j, 1)
                xk = arrX(k, 1)
                dblProduct = dblProduct * (x - xj) / (xk - xj)
            End If
        Next j
        yk = arrY(k, 1)
        dblsum = dblsum + dblProduct * yk
    Next k
    interp1 = dblsum
End Function

　　

 窗体最小化和最大化功能实现代码

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const GWL_STYLE = (-16)


Private Sub UserForm_Initialize()
    Dim lngWndForm As Long
    Dim lngStyle As Long
    lngWndForm = FindWindow(vbNullString, Me.Caption)
    lngStyle = GetWindowLong(lngWndForm, GWL_STYLE)
    lngStyle = lngStyle Or WS_MINIMIZEBOX
    lngStyle = lngStyle Or WS_MAXIMIZEBOX
    SetWindowLong lngWndForm, GWL_STYLE, lngStyle
    
End Sub

 

 

Sub Test2()
    Open "D:\a.txt" For Output As #1 '如改为For Append，则为追加文件。
        Print #1, "新内容"
    Close #1
End Sub



Sub Test4()
    Dim FSO As New FileSystemObject
    Dim txt As TextStream
    Set txt = FSO.OpenTextFile("D:\a.txt", ForAppending, True)
    txt.WriteLine "新行"
    txt.Close
    Set txt = Nothing
End Sub

Sub 新建文本文件并写入值()
  Dim objFile As Object, FileObj '声明变量
  With CreateObject("Scripting.FileSystemObject") '引用FSO对象
    If .FileExists("C:\时间记录.txt") Then '判断有没有此文本文件，文件名“时间记录.txt”和路径可以随意改。如果有...
      Set FileObj = .GetFile("C:\时间记录.txt")  '那么提取该文件对象
      Set objFile = FileObj.OpenAsTextStream(8, -2) '打开文件(此打开方式会使新写入的数据总是保存在原数据之后，如果将8改为2则会覆盖原来的数据)
    Else '否则
      Set objFile = .CreateTextFile("C:\时间记录.txt") '新建一个文本文本
    End If
    objFile.WriteLine '向文件中写入一个换行符
    objFile.WriteLine "ABC" '向文件中写入ABC
    objFile.WriteLine Date '向文件中写入当前日期
    objFile.Close
  End With


Sub Test6()
    Dim st As ADODB.Stream
    Set st = New ADODB.Stream
    With st
        .Type = adTypeText
        .Mode = adModeReadWrite
        .Charset = "UTF-8"
        .Open
        .WriteText "新内容"
        .SaveToFile "C:\a.txt", adSaveCreateOverWrite
        .Flush
        .Close
    End With
End Sub

　　

一、目录批量生成

Sub 照片目录自动生成()
Dim sht
Dim rng
Dim newrng
Dim data
Dim mainFolderPath, subFolderPath

Set fso = CreateObject("scripting.filesystemobject")

Set sht = Worksheets("目录批处理")

Set rng = sht.Range("a1").CurrentRegion

Set newrng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1, rng.Columns.Count)

data = newrng.Value

For i = 1 To UBound(data, 1)

    mainFolderPath = fso.buildpath(ThisWorkbook.Path, data(i, 1))
    If Not fso.folderexists(mainFolderPath) Then
        fso.createfolder (mainFolderPath)
    End If

    subFolderPath = mainFolderPath
    For j = 2 To UBound(data, 2)
    
        subFolderPath = fso.buildpath(subFolderPath, data(i, j))
        If Not fso.folderexists(subFolderPath) Then
            fso.createfolder (subFolderPath)
        End If
    Next j
    
Next i

MsgBox "目录生成完成!"
End Sub

　　文件批量复制

Sub copyFiles()
Dim strFullFileName As String
Dim strNewFullFileName As String
Dim oRng As Object
Set oRng = Worksheets("文件批处理").Range("a1").CurrentRegion
arrData = oRng.Value
Dim oFile As Object
Dim oFolder As Object
Dim oNewFolder As Object
Dim strNewFolderPath As String

Set fso = CreateObject("scripting.filesystemobject")
With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "请选择文件"
    .AllowMultiSelect = False
    If .Show = -1 Then
        strFullFileName = .SelectedItems(1)
        Set oFile = fso.getfile(strFullFileName)
        
        Set oFolder = oFile.parentfolder
        
        strNewFolderPath = oFolder.Path & "\文件复制"
        If Not fso.folderexists(strNewFolderPath) Then
             Set oNewFolder = fso.createfolder(strNewFolderPath)
        Else
            Set oNewFolder = fso.getfolder(strNewFolderPath)
        End If
        
        For i = 1 To UBound(arrData, 1)
            strNewFullFileName = oNewFolder.Path & "\" & arrData(i, 1) & oFile.Name
            fso.copyfile strFullFileName, strNewFullFileName
        Next i
    Else
        Exit Sub
    End If
End With
End Sub

　　

 

二、写csv文件

Sub writeToCsv()
    Dim Fs, myFile As Object
    Dim myfileline As String 'txtfile的行数据
    Dim sht As Worksheet
    Dim csvFileName As String 'csv文件名
    Dim totalRows As Integer ' 总的行数
    Dim totalColumns As Integer '总的列数
    Dim sheetNumber As Integer '工作表号
    Dim strAll As String '整个工作表的文本
    Dim owb As Object: Set owb = ThisWorkbook
    Dim osht As Object: Set osht = owb.Worksheets("电位")
    
    csvFileName = ""
    
    Set Fs = CreateObject("Scripting.FileSystemObject")   '建立filesytemobject
    Set myFile = Fs.createtextfile(owb.Path + "\" + csvFileName + ".csv") '通过filesystemobject新建一个csv文件
    
    
    With osht
        
        totalRows = .Range("a" & .Rows.Count).End(xlUp).Row
        For i = 1 To totalRows  '从第1行开始
            ra = CStr(.Cells(i, 1).Value)    '从第一列开始
            If ra = "" Then Exit For
            rb = ""
            For j = 1 To 6
                ca = CStr(.Cells(1, j).Value)
                If ca = "" Then Exit For
                If rb = "" Then
                    rb = CStr(.Cells(i, j).Value)
                Else
                    rb = rb & "," & CStr(.Cells(i, j).Value)
                End If
            Next j
            myFile.writeline (rb)
            strAll = strAll + rb + vbCrLf
            
        Next i
    End With
    
    
    Set myFile = Nothing
    Set Fs = Nothing                   '关闭文件和filesystemobject对象
    '
    '    SaveSetting AppName:="MyApp201912", Section:="MySection", Key:="Sheet" & CStr(sheetNumber), Setting:=strAll '保存所有文本到注册表
    '
    '    sheetNumber = sheetNumber + 1 '下一个工作表
    
    MsgBox ("已保存")
    
    '    MsgBox "已保存工作表内容到注册表：HKEY_CURRENT_USER\Software\VB and VBA Program Settings\MyApp201912\MySection"
End Sub

　　批量将doc与docx文件互相转换

Sub doc2docx()    'doc文件转docx文件
    
    Dim myDialog As FileDialog
    Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
    Dim oFile As Object
    Dim oFilePath As Variant
    
    With myDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD2007 文件", "*.doc", 1    '增加筛选器的项目为所有doc文件
        .AllowMultiSelect = True    '允许多项选择
        If .Show = -1 Then    '确定
            For Each oFilePath In .SelectedItems    '在所有选取项目中循环
                Set oFile = Documents.Open(oFilePath)
                oFile.SaveAs FileName:=Replace(oFilePath, "doc", "docx"), FileFormat:=16
                oFile.Close
            Next
    End If
    
End With

End Sub

　　

Sub docx2doc()    'docx文件转doc文件
    
    Dim myDialog As FileDialog
    Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
    Dim oFile As Object
    Dim oFilePath As Variant
    
    With myDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD2007 文件", "*.docx", 1    '增加筛选器的项目为所有doc文件
        .AllowMultiSelect = True    '允许多项选择
        If .Show = -1 Then    '确定
            For Each oFilePath In .SelectedItems    '在所有选取项目中循环
                Set oFile = Documents.Open(oFilePath)
                oFile.SaveAs FileName:=Replace(oFilePath, "docx", "doc"), FileFormat:=0
                oFile.Close
            Next
    End If
    
End With

End Sub

　　

Function GetRandNumber(ByVal lMin As Long, ByVal lMax As Long)
    '生成一个随机数seed
    Randomize
    Dim arr()
    Dim arrResult()
    ReDim arr(lMin To lMax)
    '先生成准备要取随机数的数组序列
    For i = lMin To lMax
        arr(i) = i
    Next i
    ReDim arrResult(lMin To lMax)
    lEnd = lMax
    For i = lMin To lMax
        '每次生成lMin到lEnd之间的随机整数
        j = Int(VBA.Rnd() * (lEnd - lMin + 1) + lMin)
        '把j位置的值取出放到随机数结果数组中
        arrResult(i) = arr(j)
        '将j位置的值与lEnd位置的值交换，保证下次不会再取到这个值
        arr(j) = arr(lEnd)
        '每次交换结束后，将lEnd减去1，保证不会再取到刚才取到的值。
        lEnd = lEnd - 1
    Next i
    GetRandNumber = arrResult
End Function