Dim xlApp Dim xlApp2 Dim xlBook Dim xlBook2 Dim xlSheet Dim xlSheet2 Dim getPath Dim savePath Dim re As RegExp Dim msg As String Private Sub Command1_Click() CommonDialog1.FileName = "" CommonDialog1.Flags = cdlOFNFileMustExist CommonDialog1.Filter = "All Files|*.*|(*.xls)|*.xls" CommonDialog1.FilterIndex = 2 CommonDialog1.DialogTitle = "打开文件(*.xls)" CommonDialog1.Action = 1 getPath = CommonDialog1.FileName End Sub Private Sub Command2_Click() If getPath <> "" Then CommonDialog2.FileName = "" CommonDialog2.Filter = "All Files|*.*|(*.xls)|*.xls" CommonDialog2.FilterIndex = 2 CommonDialog2.DialogTitle = "另存为(*.xls)" CommonDialog2.Action = 2 savePath = CommonDialog2.FileName If savePath <> "" Then '打开文件 Set xlApp = CreateObject("Excel.Application") Set xlApp2 = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Open(getPath) Set xlSheet = xlBook.Worksheets(1) '新建表格 Set xlBook2 = xlApp2.Workbooks.Open(App.Path & "\" & "模板文件.xls") Set xlSheet2 = xlBook2.Worksheets(1) '读取并修改文件 xlSheet2.Range("a2") = xlSheet.Range("a2") xlSheet2.Range("d2") = xlSheet.Range("e2") xlSheet2.Range("n2") = xlSheet.Range("d2") xlSheet2.Range("o2") = xlSheet.Range("f2") xlSheet2.Range("p2") = xlSheet.Range("g2") xlSheet2.Range("q2") = xlSheet.Range("h2") xlSheet2.Range("s2") = xlSheet.Range("j2") xlSheet2.Range("u2") = xlSheet.Range("i2") xlSheet2.Range("ah2") = "$" & xlSheet.Range("b2") msg = xlSheet.Range("c2") '正则表达式解析msg信息 Set re = New RegExp re.Pattern = "【(\d+)】(.*)\s\(商家编码:(\w+)\)\s\(产品数量:(\d+) piece\)" If (re.Test(msg) = True) Then Set re1 = re.Execute(msg)(0) xlSheet2.Range("ae2") = re1.SubMatches(1) xlSheet2.Range("ag2") = re1.SubMatches(2) xlSheet2.Range("aj2") = re1.SubMatches(3) End If '保存并关闭文件 xlBook2.SaveAs FileName:=savePath xlBook.Close xlApp2.Workbooks(1).Close SaveChanges:=False '不保存关闭模板文件 xlApp.Quit xlApp2.Quit Set xlBook = nothing Set xlBook2 = nothing Set xlApp = nothing Set xlApp2 = nothing MsgBox "文件保存成功" End If End If End Sub