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$, 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
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
conn.ConnectionString = "Driver={MySQL ODBC 5.3 Unicode Driver};Server=localhost;DB=test;UID=root;PWD=Changeme_123;OPTION=3;"
conn.Open
rs.Open "select 廠家部件號,廠家部件描述,箱號,數量 from 900m where 發射點名稱='" & myFile & "'", conn
Sheets("主設備").Range("I3").CopyFromRecordset rs
Dim x As Integer
Sheets("主設備").Select
x = Range("I65536").End(xlUp).Row
Application.DisplayAlerts = False
Range("K3:L" & x).Select
Selection.Cut
Range("M3").Select
ActiveSheet.Paste
Application.DisplayAlerts = True
rs.Close: Set rs = Nothing
conn.Close: Set conn = Nothing
ChDir "D:\test"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=AK.Name, _
??? FileFormat:= _
??? xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Application.DisplayAlerts = True
myFile = Dir
Loop
Application.ScreenUpdating = True
End Sub

轉載于:https://www.cnblogs.com/Vidar854/p/10545006.html

總結

以上是生活随笔為你收集整理的VB 宏+mysql解决EXCEL表格实现自动化处理的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。