VB 宏+mysql解决EXCEL表格实现自动化处理

1、表格模板自动建立源码

Sub opp()
Dim myPath$,myFile$,AK As Workbook
Application.ScreenUpdating = False
myPath = "d:test"
myFile = Dir(myPath & "*.xls")
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then
Set AK = Workbooks.Open(myPath & myFile)
End If
Call F
??? ChDir "D:test"
??? ActiveWorkbook.SaveAs Filename:=AK.Name,_
???????? FileFormat:= _
??????? xlOpenXMLWorkbook,CreateBackup:=False
??? ActiveWindow.Close
myFile = Dir
Loop
Application.ScreenUpdating = True
End Sub

Sub F()

??
??? Sheets.Add after:=Sheets(Sheets.Count)
??? Sheets("Sheet1").Select
??? Sheets("Sheet1").Name = "主设备"
??? Range("b1:h1").Merge
??? Range("i1:n1").Merge
??? Range("a2") = "设计物资标识（系统唯一）"
??? Range("b2") = "物料大类*"
??? Range("c2") = "物料中类*"
??? Range("d2") = "物料小类*"
??? Range("e2") = "物料说明"
??? Range("f2") = "单位*"
??? Range("g2") = "数量*"
??? Range("h2") = "厂家"
??? Range("I2") = "物料编码*"
??? Range("j2") = "物料名称*"
??? Range("k2") = "型号"
??? Range("l2") = "物料价值（元）"
??? Range("m2") = "箱号*"
??? Range("n2") = "领取数量*"
??? Range("b1:h1") = "设计单位"
??? Range("i1:n1") = "场家"
??? Range("B1:H1").Select
??? With Selection.Font
??????? .Name = "宋体"
??????? .Size = 12
??????? .Strikethrough = False
??????? .Superscript = False
??????? .Subscript = False
??????? .OutlineFont = False
??????? .Bold = True
??????? .Shadow = False
??????? .Underline = xlUnderlineStyleNone
??????? .ColorIndex = xlAutomatic
??????? .TintAndShade = 0
??????? .ThemeFont = xlThemeFontNone
??? End With
??????? Range("I1:N1").Select
??? With Selection.Font
??????? .Name = "宋体"
??????? .Size = 12
??????? .Strikethrough = False
??????? .Superscript = False
??????? .Subscript = False
??????? .OutlineFont = False
??????? .Bold = True
??????? .Shadow = False
??????? .Underline = xlUnderlineStyleNone
??????? .ColorIndex = xlAutomatic
??????? .TintAndShade = 0
??????? .ThemeFont = xlThemeFontNone
??? End With
??????? Range("A2:N2").Select
??? With Selection.Font
??????? .Name = "宋体"
??????? .Size = 10
??????? .Strikethrough = False
??????? .Superscript = False
??????? .Subscript = False
??????? .OutlineFont = False
??????? .Bold = False
??????? .Shadow = False
??????? .Underline = xlUnderlineStyleNone
??????? .ColorIndex = xlAutomatic
??????? .TintAndShade = 0
??????? .ThemeFont = xlThemeFontNone
??? End With
??? Selection.Font.Bold = True
??? Selection.Font.Bold = False
‘
??? Range("A1:N200").Select
??? With Selection
??????? .HorizontalAlignment = xlCenter
??????? .VerticalAlignment = xlCenter
??????? .WrapText = False
??????? .Orientation = 0
??????? .ColumnWidth = 17.29
??????? .AddIndent = False
??????? .IndentLevel = 0
??????? .ShrinkToFit = False
??????? .ReadingOrder = xlContext
??? End With
??? Range("G4").Select
??? ActiveSheet.Copy after:=Sheets(Sheets.Count)
??? ActiveSheet.Name = "主材"
??? ActiveSheet.Copy after:=Sheets(Sheets.Count)
??? ActiveSheet.Name = "配套"
??? ActiveSheet.Copy after:=Sheets(Sheets.Count)
??? ActiveSheet.Name = "不安装设备"
??? Application.DisplayAlerts = False
??? Sheets(1).Delete

End Sub

?

2、数据库调试及表格检测插入

Sub opp()Dim myPath$,AK As WorkbookApplication.ScreenUpdating = FalsemyPath = "d:test"myFile = Dir(myPath & "*.xls")Do While myFile <> ""If myFile <> ThisWorkbook.Name ThenSet AK = Workbooks.Open(myPath & myFile)End IfDim conn As ADODB.ConnectionDim rs As ADODB.RecordsetSet conn = New ADODB.ConnectionSet rs = New ADODB.Recordsetconn.ConnectionString = "Driver={MySQL ODBC 5.3 Unicode Driver};Server=localhost;DB=test;UID=root;PWD=Changeme_123;OPTION=3;"conn.Openrs.Open "select 厂家部件号,厂家部件描述,箱号,数量 from 900m where 发射点名称=‘" & myFile & "‘",connSheets("主设备").Range("I3").CopyFromRecordset rsDim x As IntegerSheets("主设备").Selectx = Range("I65536").End(xlUp).RowApplication.DisplayAlerts = FalseRange("K3:L" & x).SelectSelection.CutRange("M3").SelectActiveSheet.PasteApplication.DisplayAlerts = Truers.Close: Set rs = Nothingconn.Close: Set conn = NothingChDir "D:test"Application.DisplayAlerts = FalseActiveWorkbook.SaveAs Filename:=AK.Name,_??? FileFormat:= _??? xlOpenXMLWorkbook,CreateBackup:=FalseActiveWindow.CloseApplication.DisplayAlerts = TruemyFile = DirLoopApplication.ScreenUpdating = TrueEnd Sub