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