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
浙公网安备 33010602011771号