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