常用代码归集

jsgj2023

Sub 添加数据到access()
Dim cnn As ADODB.Connection
cnn1 As ADODB.Connection
rs As ADODB.Recordset
rs1 As ADODB.Recordset
Dim strsql As String
Dim strsql1 As String
Dim strsql2 As String
On Error Resume Next
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
cnn.Open "provider=microsoft.jet.oledb.4.0;" & "data source=" & ThisWorkbook.Path & "\xxx.mdb"
rs.Open "select * from", cnn
strsql = "insert  into 供应商("
For i = 1 To rs.Fields.Count - 1
    strsql = strsql & rs.Fields(i).Name & ","
Next
strsql = Left(strsql, Len(strsql) - 1) & ") values("
Set cnn1 = CreateObject("adodb.connection")
Set rs1 = CreateObject("adodb.recordset")
cnn1.Open "provider=microsoft.jet.olecb.4.0;" & "extended properties=excle 8.0;" & "data source=" & ThisWorkbook.FullName
strsql1 = "select 8 from [Sheet1$]"
rs1.Open strsql1, cnn1, adOpenStatic
Do While Not rs1.EOF
    strsql2 = strsql
    If rs1.Fields(0).Value <> "" Then
        For i = 0 To rs1.Fields.Count - 1
            strsql2 = strsql2 & "'" & rs1.Fields(i).Value & "',"
        Next
        strsql2 = Left(strsql2, Len(strsql2) - 1) & ")"
        MsgBox strsql2
        cnn.Execute strsql2
    End If
    rs1.MoveNext
Loop
MsgBox "当前工作表中的数据已添加到数据库中!"
rs.Close
rs1.Close
cnn.Close
cnn1.Close
End Sub

jsgj2023

Sub 创建access数据库()
Dim cat  As New ADOX.Catalog
Dim rs1 As New ADODB.Recordset
Dim conn As New ADODB.Connection
Dim str1 As String
strsql As String
Dim sdbname As String
sdbname = Application.InputBox(prompt:="请输入数据的名称:", _
Title:="创建数据库", Default:="test", Type:=2)
If sdbname = "False" Then Exit Sub
str1 = "provider=microsoft.jet.oledb.4.0;data source="
str1 = str1 & ThisWorkbook.Path & "\" & sdbname & ".mdb"
strsql = "create table test(学号 char(10),姓名 char(10), 性别 char(2),"
strsql = strsql & "出生日期 date,联系电话 char(20),地址 char(40))"
cat.Create str1
conn.Open str1
conn.Execute strsql
With rs1
    .Open "test", conn, adOpenKeyset, adLockPessimistic
    .AddNew
    .Fields("学号") = "w0008"
    .Fields("姓名") = "王五"
    .Fields("性别") = "女"
    .Fields("出生日期") = #10/11/1983#
    .Fields("联系电话") = "88888888"
    .Fields("地址") = "深南中路8888号"
End With
MsgBox "数据库"" & sdbname & ""创建完成!"
rs1.Close
conn.Close
End Sub

jsgj2023

Sub 判断单元格是否包含公式()
Dim rng As Range
Set rng = ActiveSheet.Range("a1").CurrentRegion
For Each c In rng.Cells
    If c.HasFormula Then
        MsgBox "单元格" & c.Address & "定义了公式!"
    End If
Next c
End Sub

jsgj2023

Sub 自动填充公式()
Dim i As Long
Dim j As Long
With Range("a1").CurrentRegion
    i = .Rows.Count - 1
    j = .Columns.Count - 1
End With
Range("j3").AutoFill Destination:=Range(Cells(3, 10), Cells(i, 10))
Range("d16").AutoFill Destination:=Range(Cells(16, 4), Cells(16, j))
End Sub

jsgj2023

Sub 锁定及隐藏公式()
If ActiveSheet.ProtectContents = True Then
    MsgBox "工作表已保护!"
End If
Worksheets("Sheet1").Range("a1").CurrentRegion.Select
Selection.Locked = False
Selection.FormulaHidden = False
Selection.SpecialCells(xlCellTypeFormulas).Select
Selection.Locked = True
Selection.FormulaHidden = True
Worksheets("Sheet1").Protect DrawingObjects:=True, contents:=True, scenaruos:=True
Worksheets("Sheet1").EnableSelection = xlNoRestrictions
End Sub

jsgj2023

Sub 将单元格公式转换为数值()
Dim rng As Range
Dim c As Range
Set rng = ActiveSheet.Range("a1").CurrentRegion
For Each c In rng.Cells
    If c.HasFormula Then
        c.Value = c.Value
    End If
Next
End Sub

jsgj2023

Sub 查找指定的值()
Dim result As String
Dim str1 As String
Dim str2 As String
Dim c As Range
result = Application.InputBox(prompt:="请输入要查找的值:", Title:="查找", Type:=2)
If result = "False" Or result = "" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet.Cells
    Set c = .Find(result, , , xlWhole, xlByColumns, xlNext, False)
    If Not c Is Nothing Then
        str1 = c.Address
        Do
            c.Interior.ColorIndex = 4
            str2 = str2 & c.Address & vbCrLf
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> str1
    End If
End With
MsgBox "查找到指定数据在以下单元格中:" & vbCrLf & vbCrLf & str2, vbInformation + vbOKOnly, "查找结果"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

vanuse

好东西，留个脚印

jsgj2023

Sub 打开记事本()
    Shell "Notepad.exe", vbNormalFocus
End Sub

jsgj2023

Sub 打开计算器()
    Shell "calc.exe", vbNormalFocus
End Sub