|
|
Sub 一键清除数据库()
On Error Resume Next
a = InputBox("将要清除全部数据!" & vbNewLine & "请输入密码", "密码输入")
If Format(a, "#") <> Format("14358899") Then
MsgBox " 您输入的密码不正确!"
Exit Sub
End If
X = MsgBox("确认清除！执行清除后，数据库所有数据将清除且不能恢复，点“是”继续，“否”取消操作！", vbYesNo)
If X = vbYes Then
Close
Else
Exit Sub
End If
Dim j
With Sheet4
.Range("A2:U65536") = ""
MsgBox "已清除所有数据!"
End With
End Sub
Sub 一键清除预算单数据()
On Error Resume Next
a = InputBox("将要清除全部数据!" & vbNewLine & "请输入密码", "密码输入")
If Format(a, "#") <> Format("14358899") Then
MsgBox " 您输入的密码不正确!"
Exit Sub
End If
X = MsgBox("确认清除！执行清除后，数据库所有数据将清除且不能恢复，点“是”继续，“否”取消操作！", vbYesNo)
If X = vbYes Then
Close
Else
Exit Sub
End If
Dim j
With Sheet23
.Range("A2:U65536") = ""
MsgBox "已完成!"
End With
End Sub
Sub 导入ACCESS数据库()
'引用Microsoft ActiveX Data Objects 2.x Library
Dim cnn As New ADODB.Connection, rs As New ADODB.Recordset, SQL As String, strMsg As String
' cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\数据库.accdb"
Dim DatabaseFuPass As String: DatabaseFuPass = ThisWorkbook.Path & "\数据库1.accdb"
Const myPass As String = "14358899"
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password=" & myPass & ";Data Source=" & DatabaseFuPass
SQL = "SELECT A.* FROM [Excel 12.0;Database=" & ThisWorkbook.FullName & ";].[数据库$A1:U" & Sheets("数据库").Range("b" & Sheets("数据库").Rows.Count).End(xlUp).Row _
& "] A LEFT JOIN (Select * From 数据库) D ON A.单号=D.单号 WHERE D.单号 IS NULL"
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
SQL = "INSERT INTO 数据库 " & SQL
cnn.Execute SQL
strMsg = rs.RecordCount & "条记录已添加到数据库！"
Else
strMsg = "没有发现可以插入的记录！"
End If
MsgBox strMsg, vbInformation, "提示"
rs.Close: cnn.Close
Set rs = Nothing: Set cnn = Nothing
End Sub
Sub 删除再导入ACCESS数据库()
On Error Resume Next
a = InputBox("您将要清除所有数据重新导入新数据!" & vbNewLine & "请输入密码", "密码输入")
If Format(a, "#") <> Format("14358899") Then
MsgBox " 您输入的密码不正确!"
Exit Sub
End If
X = MsgBox("确认要进行数据删除？执行删除后，所有数据将清零，并导入新的全部数据到ACCESS数据库，点“是”继续，“否”取消操作！", vbYesNo)
If X = vbYes Then
Close
Else
Exit Sub
End If
' 引用Microsoft ActiveX Data Objects 2.x Library
Dim cnn As New ADODB.Connection, rs As New ADODB.Recordset, SQL As String, strMsg As String
Dim DatabaseFuPass As String: DatabaseFuPass = ThisWorkbook.Path & "\数据库1.accdb"
Const myPass As String = "14358899"
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password=" & myPass & ";Data Source=" & DatabaseFuPass
' 清除旧数据
SQL = "delete * from 数据库"
cnn.Execute SQL
' -----------
SQL = "SELECT A.* FROM [Excel 12.0;Database=" & ThisWorkbook.FullName & ";].[数据库$A1:U" & Sheets("数据库").Range("b" & Sheets("数据库").Rows.Count).End(xlUp).Row _
& "] A LEFT JOIN (Select * From 数据库) D ON A.单号=D.单号 WHERE D.单号 IS NULL"
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
' 导入数据
SQL = "INSERT INTO 数据库 " & SQL
cnn.Execute SQL
strMsg = rs.RecordCount & "条记录已添加到数据库！"
MsgBox strMsg, vbInformation, "提示"
rs.Close: cnn.Close
Set rs = Nothing: Set cnn = Nothing
End Sub
Sub 二维码()
Call UserForm9.Show
End Sub
Sub 进存销宏菜单()
Dim mCaidan As Menu
MenuBars(xlWorksheet).Reset
Set mCaidan = MenuBars(xlWorksheet).Menus.Add("【进存销功能菜单】")
With mCaidan.MenuItems
.Add "二维码", "二维码"
.Add "系统初始化", "X_初始化"
.Add "导入ACCESS数据库", "导入ACCESS数据库"
.Add "删除再导入ACCESS数据库", "删除再导入ACCESS数据库"
.Add "插入批注", "插入批注"
.Add "系统备份", "X_文件备份"
.Add "日历", "日历"
.Add "更新库存", "B_一键更新库存"
.Add "显示隐藏工作表", "显示隐藏工作表"
.Add "清除数据库", "一键清除数据库"
.Add "清除预算单数据", "一键清除预算单数据"
End With
End Sub
Sub 隐藏工作表()
On Error Resume Next
a = InputBox("将要将要隐藏部份工作表!" & vbNewLine & "请输入密码", "密码输入")
If Format(a, "#") <> Format("14358899") Then
MsgBox " 您输入的密码不正确!"
Exit Sub
End If
X = MsgBox("确认隐藏！执行隐藏，你自定的部份工作表将隐藏不可见，点“是”继续，“否”取消操作！", vbYesNo)
If X = vbYes Then
Close
Else
Exit Sub
End If
Sheet1.Visible = 2
'Sheet2.Visible = 2
'Sheet3.Visible = 2
Sheet4.Visible = 2
Sheet5.Visible = 2
'Sheet6.Visible = 2
Sheet7.Visible = 2
Sheet8.Visible = 2
Sheet9.Visible = 2
Sheet10.Visible = 2
Sheet11.Visible = 2
Sheet12.Visible = 2
Sheet13.Visible = 2
Sheet14.Visible = 2
Sheet15.Visible = 2
'Sheet16.Visible = 2
Sheet17.Visible = 2
Sheet18.Visible = 2
Sheet19.Visible = 2
Sheet20.Visible = 2
Sheet21.Visible = 2
'Sheet22.Visible = 2
Sheet23.Visible = 2
Sheet24.Visible = 2
'Sheet25.Visible = 2
Sheet26.Visible = 2
'Sheet27.Visible = 2
MsgBox "已按你的要求隐藏了部份工作表"
End Sub
Sub 显示工作表()
On Error Resume Next
a = InputBox("将要显示全部工作表!" & vbNewLine & "请输入密码", "密码输入")
If Format(a, "#") <> Format("14358899") Then
MsgBox " 您输入的密码不正确!"
Exit Sub
End If
X = MsgBox("确认要显示？执行显示后，所有工作表将显示，点“是”继续，“否”取消操作！", vbYesNo)
If X = vbYes Then
Close
Else
Exit Sub
End If
Sheet1.Visible = -1
Sheet2.Visible = -1
'Sheet3.Visible = -1
Sheet4.Visible = -1
Sheet5.Visible = -1
'Sheet6.Visible = -1
Sheet7.Visible = -1
Sheet8.Visible = -1
Sheet9.Visible = -1
Sheet10.Visible = -1
Sheet11.Visible = -1
Sheet12.Visible = -1
Sheet13.Visible = -1
Sheet14.Visible = -1
Sheet15.Visible = -1
'Sheet16.Visible = -1
Sheet17.Visible = -1
Sheet18.Visible = -1
Sheet19.Visible = -1
Sheet20.Visible = -1
Sheet21.Visible = -1
'Sheet22.Visible = -1
Sheet23.Visible = -1
Sheet24.Visible = -1
'Sheet25.Visible = -1
Sheet26.Visible = -1
'Sheet27.Visible = -1
MsgBox "已显示全部工作表"
End Sub
Sub 显示隐藏工作表()
Static i& '声明为静态变量
i = i + 1
Select Case i
Case 1: 显示工作表
Case 2: 隐藏工作表
Case Else: 显示工作表: i = 1
End Select
End Sub
Sub 插入批注()
Dim Rng As Range
For Each Rng In Intersect(Sheet1.UsedRange, Sheet1.Range("a:a"))
Rng.ClearComments
If Dir(ThisWorkbook.Path & "\图片\" & Rng.Value & ".jpg") <> "" Then
Rng.AddComment
With Rng.Comment
.Visible = False
.Shape.Fill.UserPicture ThisWorkbook.Path & "\图片\" & Rng.Value & ".jpg"
.Shape.Height = 193
.Shape.Width = 300
End With
End If
Next
MsgBox "图片插入已完成！"
End Sub
能否将以上代码封装一下？
|
|
楼主: HHAAMM
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-9-5 09:26
