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