VBA创建ACCESS

Sub NsCreate()
Dim D As New ADOX.Catalog, i, j, s, e As Integer, Name, Engine As String
Dim isRec(), NsStart(), NsEnd(), NsType()

Name = "DbNS"
NsType = Array("CECS", "CECS-CBIMU", "CIAS", "CJ", "CJJ", "DL", "GA", "GB", "GBJ", "GBZ", "GY", "HG", "HJ", "JC", "JG", "JGJ", "JTG", "MH", "SL", "TB", "TBJ", "????")
NsEnd = Array(22, 23, 24, 27, 283, 317, 0, 378, 1641, 1642, 1643, 0, 1646, 1647, 0, 2067, 0, 2068, 0, 0, 2076, 2077)

Name = ThisWorkbook.Path & "\" & Name & ".accdb"
Engine = "provider=microsoft.ace.oledb.12.0;data source=" & Name
D.Create Engine
Set D = Nothing
Set A = ThisWorkbook.ActiveSheet
Set C = CreateObject("ADODB.Connection")
C.Open Engine
i = 0
s = 1

For Each Item In NsType
C.Execute "create table [" & Item & "] ([id] counter primary key, [S/N] real not null, [Year] int not null, [isRec] bit, [Name] Text not null)"
e = NsEnd(i)
If e = 0 Then
Else
For j = s To e
If A.Cells(j, 3) = "" Then
isRec = Array(",[isRec]", ",True")
Else
isRec = Array("", "")
End If
C.Execute "insert into [" & Item & "] ([S/N],[Year]" & isRec(0) & ",[Name]) values (" & A.Cells(j, 1) & "," & A.Cells(j, 2) & isRec(1) & ",'" & A.Cells(j, 4) & "')"
Next
s = e + 1
End If
i = i + 1
Next

C.Execute "create table [#EXPIRE] ([id] counter primary key, [Type] Text not null, [S/N] real not null, [Year] int not null, [isRec] bit, [Name] Text not null)"
C.Execute "create table [#USER] ([id] counter primary key, [Type] Text not null, [idv] int not null, [Batch] int not null, [Parked] bit)"
C.Close
Set C = Nothing
End Sub

Sub FileCreate()
Dim i, j, s, e As Integer, Dir, SType, SDir, SName, Spath As String
Dim SNumber, NsStart(), NsEnd(), NsType()

Dir = "H:\????\??\????????\??????\??????\"
NsType = Array("CECS", "CECS-CBIMU", "CIAS", "CJ", "CJJ", "DL", "GA", "GB", "GBJ", "GBZ", "GY", "HG", "HJ", "JC", "JG", "JGJ", "JTG", "MH", "SL", "TB", "TBJ", "????")
NsEnd = Array(22, 23, 24, 27, 283, 317, 0, 378, 1641, 1642, 1643, 0, 1646, 1647, 0, 2067, 0, 2068, 0, 0, 2076, 2077)

Set A = ThisWorkbook.ActiveSheet
Set F = CreateObject("Scripting.FileSystemObject")
i = 0
s = 1

For Each Item In NsType
e = NsEnd(i)
SType = Item
SDir = Dir & SType & "\"

If e = 0 Then
Else
For j = s To e
SNumber = A.Cells(j, 1)

Select Case Item
Case "CECS"
If SNumber < 10 Then
SName = "0" & SNumber
End If
Case "GBJ"
SName = 50000 + SNumber
SType = "GB"
Case "TBJ"
SName = 10000 + SNumber
SType = "TB"
End Select
    
SName = SType & SName & "-" & A.Cells(j, 2)
If A.Cells(j, 3) = 1 Then
SName = SName & "T"
End If

Spath = SDir & SName & " " & A.Cells(j, 4)
If F.FileExists(Spath & ".pdf") Then
Else
F.CreateTextFile(Spath, True).Close
End If

Next
s = e + 1
End If
i = i + 1
Next

Set F = Nothing
End Sub

Function SName(SType, SNumber, Year, isRec, Name)
Select Case SType
Case "CECS"
If SNumber < 10 Then
SNumber = "0" & SNumber
End If
Case "GBJ"
SNumber = 50000 + SNumber
SType = "GB"
Case "TBJ"
SNumber = 10000 + SNumber
SType = "TB"
End Select
If isRec = 0 Then
isRec = ""
Else
isRec = "/T"
End If

SName = SType & isRec & " " & SNumber & "-" & Year & " " & Name
End Function