[已解决]解释下代码？

sdfsdfs

Dim WithEvents app As Application
Dim MyPath$
Dim arrf(), mf&

Private Sub Workbook_Open()
    Dim Fso As Object
    Set app = Excel.Application
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Call GetFiles(ThisWorkbook.Path, "*.xls", Fso)
End Sub

Private Sub app_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Address <> "$A$1" Then Exit Sub
    Dim cnn As Object, SQL$, t, i&
    On Error Resume Next
    For i = 1 To mf
        If arrf(i) <> Sh.Parent.FullName Then
            Set cnn = CreateObject("ADODB.Connection")
            cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0;hdr=no';Data Source =" & arrf(i)
            Select Case True
                Case Target.Value = ""
                    t = "null"
                Case IsNumeric(Target.Value)
                    t = Target.Value
                Case Else
                    t = "'" & Target.Value & "'"
            End Select
            SQL = "update [" & Sh.Name & "$a1:a1] set f1 =" & t
            cnn.Execute SQL
        End If
    Next
    cnn.Close
    Set cnn = Nothing
End Sub

Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, Fso As Object)
    Dim Folder As Object
    Dim SubFolder As Object
    Dim File As Object
    Set Folder = Fso.GetFolder(sPath)
   
    For Each File In Folder.Files
        If File.Name Like sFileType Then
            mf = mf + 1
            ReDim Preserve arrf(1 To mf)
            arrf(mf) = sPath & "\" & File.Name
        End If
    Next
    If Folder.SubFolders.Count > 0 Then
        For Each SubFolder In Folder.SubFolders
            Call GetFiles(SubFolder.Path, sFileType, Fso)
        Next
    End If
    Set Folder = Nothing
    Set File = Nothing
    Set SubFolder = Nothing
End Sub

最佳答案

月排行榜 / 总排行榜

zjdh

2014-10-26 18:02

Dim WithEvents app As Application    '定义变量 app 为 应用程序
Dim MyPath$
Dim arrf(), mf&
Private Sub Workbook_Open()
    Dim Fso As Object    '定义变量 Fso 为 对象
    Set app = Excel.Application    '设定 app= Excel的应用程序
    Set Fso = CreateObject("Scripting.FileSystemObject")    '创建文件系统
    Call GetFiles(ThisWorkbook.Path, "*.xls", Fso)    '调用 GetFiles
End Sub

Private Sub app_SheetChange(ByVal Sh As Object, ByVal Target As Range)    '修改数组记录的所有文件中相同工作表A1内容
    If Target.Address <> "$A$1" Then Exit Sub    '如果修改的单元不不为 "$A$1" 则退出
    Dim cnn As Object, SQL$, t, i&
    On Error Resume Next    '当错误执行下一个
    For i = 1 To mf         '数组循环
        If arrf(i) <> Sh.Parent.FullName Then    '如果 arrf(i)不等于Sh的父项的完整名称则
            Set cnn = CreateObject("ADODB.Connection")     '创建ADODB
            cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0;hdr=no';Data Source =" & arrf(i) '建立数据连接arrf(i)的文件
            Select Case True          '选定条件情况
            Case Target.Value = ""    '若为空
                t = "null"            't="null"
            Case IsNumeric(Target.Value)    '若为数字
                t = Target.Value            't= 修改的值
            Case Else                 '其他情况
                t = "'" & Target.Value & "'"
            End Select
            SQL = "update [" & Sh.Name & "$a1:a1] set f1 =" & t  'SQL语句:修改与当前工作表同名的工作表的A1单元为变量t的值
            cnn.Execute SQL          '执行SQL
        End If
    Next
    cnn.Close            ' 关闭
    Set cnn = Nothing    ' 释放空间
End Sub

Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, Fso As Object) '作用为搜索当前目录下所有（含子目录）的文件
    Dim Folder As Object                '定义变量为 对象
    Dim SubFolder As Object
    Dim File As Object
    Set Folder = Fso.GetFolder(sPath)      '设定为当前文件夹
    For Each File In Folder.Files          '搜索文件夹内所有文件
        If File.Name Like sFileType Then   '如果文件类似指定类型则
            mf = mf + 1
            ReDim Preserve arrf(1 To mf)   '重定义变量
            arrf(mf) = sPath & "\" & File.Name     '记录文件的名称
        End If
    Next
    If Folder.SubFolders.Count > 0 Then            '如果有子文件夹
        For Each SubFolder In Folder.SubFolders    '搜索每个子文件夹
            Call GetFiles(SubFolder.Path, sFileType, Fso)    '给出参数回调本程序
        Next
    End If
    Set Folder = Nothing    ' 释放空间
    Set File = Nothing
    Set SubFolder = Nothing
End Sub

跳转到最佳答案楼层

zjdh

下载解释器
http://www.excelpx.com/thread-186721-1-1.html

su45

一是用解释器，二是按 F1键找帮助

zjdh

Dim WithEvents app As Application    '定义变量 app 为 应用程序
Dim MyPath$
Dim arrf(), mf&
Private Sub Workbook_Open()
    Dim Fso As Object    '定义变量 Fso 为 对象
    Set app = Excel.Application    '设定 app= Excel的应用程序
    Set Fso = CreateObject("Scripting.FileSystemObject")    '创建文件系统
    Call GetFiles(ThisWorkbook.Path, "*.xls", Fso)    '调用 GetFiles
End Sub

Private Sub app_SheetChange(ByVal Sh As Object, ByVal Target As Range)    '修改数组记录的所有文件中相同工作表A1内容
    If Target.Address <> "$A$1" Then Exit Sub    '如果修改的单元不不为 "$A$1" 则退出
    Dim cnn As Object, SQL$, t, i&
    On Error Resume Next    '当错误执行下一个
    For i = 1 To mf         '数组循环
        If arrf(i) <> Sh.Parent.FullName Then    '如果 arrf(i)不等于Sh的父项的完整名称则
            Set cnn = CreateObject("ADODB.Connection")     '创建ADODB
            cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0;hdr=no';Data Source =" & arrf(i) '建立数据连接arrf(i)的文件
            Select Case True          '选定条件情况
            Case Target.Value = ""    '若为空
                t = "null"            't="null"
            Case IsNumeric(Target.Value)    '若为数字
                t = Target.Value            't= 修改的值
            Case Else                 '其他情况
                t = "'" & Target.Value & "'"
            End Select
            SQL = "update [" & Sh.Name & "$a1:a1] set f1 =" & t  'SQL语句:修改与当前工作表同名的工作表的A1单元为变量t的值
            cnn.Execute SQL          '执行SQL
        End If
    Next
    cnn.Close            ' 关闭
    Set cnn = Nothing    ' 释放空间
End Sub

Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, Fso As Object) '作用为搜索当前目录下所有（含子目录）的文件
    Dim Folder As Object                '定义变量为 对象
    Dim SubFolder As Object
    Dim File As Object
    Set Folder = Fso.GetFolder(sPath)      '设定为当前文件夹
    For Each File In Folder.Files          '搜索文件夹内所有文件
        If File.Name Like sFileType Then   '如果文件类似指定类型则
            mf = mf + 1
            ReDim Preserve arrf(1 To mf)   '重定义变量
            arrf(mf) = sPath & "\" & File.Name     '记录文件的名称
        End If
    Next
    If Folder.SubFolders.Count > 0 Then            '如果有子文件夹
        For Each SubFolder In Folder.SubFolders    '搜索每个子文件夹
            Call GetFiles(SubFolder.Path, sFileType, Fso)    '给出参数回调本程序
        Next
    End If
    Set Folder = Nothing    ' 释放空间
    Set File = Nothing
    Set SubFolder = Nothing
End Sub

su45

zjdh 发表于 2014-10-26 18:02
Dim WithEvents app As Application    '定义变量 app 为 应用程序
Dim MyPath$
Dim arrf(), mf&

zjdh辛苦！

80013025

zjdh 发表于 2014-10-26 18:02
Dim WithEvents app As Application    '定义变量 app 为 应用程序
Dim MyPath$
Dim arrf(), mf&

恳请大侠！帮我解决这个汇总问题好吗？
http://www.excelpx.com/thread-333818-1-1.html