常用代码归集

jsgj2023

Sub 新建文件夹_fso()
Dim fso As New Scripting.FileSystemObject
Dim sfolder As String
sfolder = Application.InputBox(prompt:="请输入新建文件夹的名称:", _
Title:="输入文件夹名称", Type:=2)
If sfolder = "False" Or sfolder = "" Then Exit Sub
sfolder = ThisWorkbook.Path & "\" & sfolder
If fso.FolderExists(sfolder) Then
    MsgBox "文件夹" & sfolder & "已经存在!"
Else
    fso.CreateFolder (sfolder)
    MsgBox "文件夹" & sfolder & "创建完成!"
End If
Set fso = Nothing
End Sub

jsgj2023

Sub 删除文件夹_fso()
Dim fso As New FileSystemObject
Dim sfolder As String
sfolder = Application.InputBox(prompt:="请输入需要删除的文件夹名称", _
Title:="输入文件夹名称", Type:=2)
If sfolder = "False" Or sfolder = "" Then Exit Sub
sfolder = ThisWorkbook.Path & "\" & sfolder
If fso.FolderExists(sfolder) Then
    fso.DeleteFolder (sfolder)
    MsgBox "文件夹""  &  sfolder &  ""已经删除!"
Else
    MsgBox "文件夹" & sfolder & "不存在!"
End If
Set fso = Nothing
End Sub

jsgj2023

Sub 复制文件_fso()
Dim fso As New Scripting.FileSystemObject
Dim sourcefile As String
Dim destinationfile As String
sourcefile = Application.InputBox(prompt:="请输入当前文件夹中需要复制文件的名称:" & _
vbCrLf & "(可使用通配符):", Title:="输入文件名", Type:=2)
destinationfile = Application.InputBox(prompt:="请输入目标文件或文件夹(以" \ "结尾)的名称:", _
Title:="目标文件", Type:=2)
If sourcefile = "False" Or sourcefile = "" Then Exit Sub
If Destination = "False" Or destinationfile = "" Then Exit Sub
sourcefile = ThisWorkbook.Path & "\" & sourcefile
destinationfile = ThisWorkbook.Path & "\" & destinationfile
If fso.FileExists(sourcefile) Then
    fso.CopyFile sourcefile, destinationfile, True
    MsgBox "复制成功!"
Else
    MsgBox "文件" & sourcefile & "不存在!"
End If
Set fso = Nothing
End Sub

jsgj2023

Sub 复制文件夹_Fso()
Dim fso As New Scripting.FileSystemObject
Dim sourcefile As String
Dim destinationfile As String
sourcefile = Application.InputBox(prompt:="请输入需要复制的文件夹名称:" & _
vbCrLf & "(可使用通配符):", Title:="输入文件夹", Type:=2)
destinationfile = Application.InputBox(prompt:="请输入目标文件夹名称:", _
Title:="目标文件夹", Type:=2)
If sourcefile = "False" Or sourcefile = "" Then Exit Sub
If destinationfile = "False" Or destinationfile = "" Then Exit Sub
sourcefile = ThisWorkbook.Path & "\" & sourcefile
destinationfile = ThisWorkbook.Path & "\" & destinationfile
If fso.FolderExists(sourcefile) Then
    fso.CopyFolder sourcefile, Destination, True
    MsgBox "文件夹复制成功!"
Else
    MsgBox "文件夹" & sourcefile & "不存在!"
End If
Set fso = Nothing
End Sub

jsgj2023

Sub 列出文件夹名称()
Dim fso As New Scripting.FileSystemObject
Dim sfolder As Folder
Dim i As Integer
On Error Resume Next
i = 2
With Sheet1
    For Each sfolder In fso.GetFolder("C:\").SubFolders
        .Cells(i, 1) = sfolder.Name
        .Cells(i, 2) = Round(sfolder.Size / 1024, 2) & "KB"
        .Cells(i, 3) = sfolder.ShortName
        i = i + 1
    Next
End With
Set fso = Nothing
End Sub

jsgj2023

Sub 删除所有空文件夹()
Dim strpath As String
strpath = Application.InputBox(prompt:="请输入文件夹,名称:", _
Title:="输入文件夹名称", Default:=thisworbook.Path, Type:=2)
If strpath = "False" Or strpath = "" Then Exit Sub
Call delemtydir(strpath)
End Sub
Sub delemtydir(strpath)
Dim fso As New Scripting.FileSystemObject
Dim strdirname As String
Dim lastdir As String
Dim strfld As String
Dim fld As Folder
If strpath = "False" Or strpath = "" Then Exit Sub
If Right(strpath, 1) <> "\" Then strpath = strpath & "\"
strdirname = Dir(strpath, vbDirectory)
Do While strdirname <> ""
    If strdirname <> "." And strdirname <> ".." Then
        If (GetAttr(strpath & strdirname) And vbDirectory) = vbDirectory Then
            lastdir = strdirname
            Set fld = fso.GetFolder(strpath & strdirname)
            If fld.Size = 0 Then
                fld.Delete
                strfld = Left(strpath & strdirname, InStrRev(strpath$ & strdirname, "\") - 1)
                Call delemtydir(strfld)
            Else
                Call delemtydir(strpath & strdirname)
            End If
            strdirname = Dir(strpath, vbDirectory)
            Do Until strdirname = lastdir Or strdirname = ""
                strdirname = Dir
            Loop
            If strdirname = "" Then Exit Sub
        End If
    End If
    strdirname = Dir
Loop
Set fso = Nothing
End Sub

jsgj2023

Sub 使用ADO链接数据库()
Dim cnn As ADODB.Connection
On Error Resume Next
Set cnn = CreateObject("ADODB.connection")
cnn.Open "provider=microsoft.jet.oledb.4.0;" & "extended  properties=excel 8.0;" & "data soucrce=" & ThisWorkbook.FullName
MsgBox "链接数据库成功!", vbInformation + vbOKOnly, "提示"
cnn.Close
Set cnn = Nothing
End Sub

jsgj2023

Sub 从工作表中查询数据()
Dim cnn As ADODb.Connection
Dim rs  As ADODb.Recordset
Dim strsql As Stream
Dim str1  As Stream
On Error Resume Next
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
cnn.Open "provider=microsoft.jet.oledb.4.0;" _
& "extended properties=excel 8.0;" _
& "data source=" & ThisWorkbook.FullName
str1 = ActiveSheet.Range("a2")
strsql = "select * from [数据库$] where  商品名称 like '% " & str1 & " %'"
rs.Open strsql, cnn, adOpenStatic
With ActiveSheet
    .Range("a5:g1000").ClearContents
    .Range("a5").CopyFromRecordset rs
End With
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub

jsgj2023

Sub 汇总数据_()
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strsql As String
Dim str1 As String
On Error Resume Next
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
cnn.Open "provider=microsoft.jet.oledb.4.0;" _
& "extended properties=excle 8.0;" _
& "data source=" & ThisWorkbook.FullName
strsql = "select  商品名称,sum(期初库存) from [数据库$] group  by  商品名称"
rs.Open strsql, cnn, adOpenStatic
With Sheet1
    .Range("a2:g1000").ClearContents
    .Range("a2").CopyFromRecordset
End With
rs.colse
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub

jsgj2023

Sub 从access中获取数据()
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strsql As String
Dim str1 As String
On Error Resume Next
Set cnn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
cnn.Open "provider=miscosoft.jet.olebd.4.0;" _
& "data source=" & ThisWorkbook.Path & "\xxx.mdb"
str1 = ActiveSheet.Range("b2")
strsql = "select * from [供应商] where 公司名称 like  '%" & str1 & "%'"
rs.Open strsql, cnn, adOpenStatic
With ActiveSheet
    For i = 0 To rs.Fields.Count - 1
        .Cells(4, i + 1) = rs.Fields(i).Name
    Next
    .Range("a5:g1000").ClearContents
    .Range("a5").CopyFromRecordset
    .Columns.AutoFit
End With
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub