[已解决]添加基础表进行代码测试

excel白兔

帮助用VBA判断H列的工作薄的工作表是否存在，如果存在在测试J列里显示有或无。首先H列是变化的也就是说H的工作薄的工作表不固定 从12行判定到149行H67,68,69不判定因为那个也是表头（注意这个工作薄和判定的工作薄在一个文件夹下）可能判定的工作薄的工作表不止一个比如H列有4个工作薄一起判定相互别影响了，这个用的ADO方式处理）




这个文件夹的路径是随即的 也就是当前打开的工作薄的路径  这个工作薄和要查找的工作薄是一个路径下的这个能判定出来吗？（可能在服务器上可能在桌面上可能在D盘里，可以肯定的是打开编写程序的工作薄和其他要查找的工作薄都在一个文件夹下不知道这样能做出来吗老师？

最佳答案

月排行榜 / 总排行榜

雪舞子

2014-3-11 14:46

不知道为什么，用标签粘贴代码总是有几个显示不全，直接贴一下：

Sub test()
    Dim cnn As Object, rst As Object
    Dim arr, wkb$, wkt$, str$, i%, k%
    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    arr = [h12:h149]
    ReDim brr(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        k = InStr(arr(i, 1), "]")
        If k > 6 Then
            wkb = Mid(arr(i, 1), 2, k - 2)
            If Dir(ThisWorkbook.Path & "\" & wkb) = "" Then
                brr(i, 1) = "无此档案"
            Else
                wkt = Replace(Mid(arr(i, 1), k + 1, InStr(arr(i, 1), "!") - k - 2), ".", "#")
                cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no;imex=1';data source=" & ThisWorkbook.Path & "\" & wkb
                '                cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 Xml;HDR=no;imex=1';Data Source=" & ThisWorkbook.Path & "\" & wkb
                Set rst = cnn.OpenSchema(20)
                Do Until rst.EOF
                    If rst!TABLE_TYPE = "TABLE" And Right(rst!TABLE_NAME.Value, 2) = "$'" Then
                        str = Replace(Replace(rst!TABLE_NAME.Value, "'", ""), "$", "")
                    End If
                    If wkt = str Then brr(i, 1) = "有此档案": k = 0: Exit Do
                    rst.MoveNext
                Loop
                If k > 0 Then brr(i, 1) = "无此档案"
                rst.Close
                cnn.Close
            End If
        Else
            brr(i, 1) = ""
        End If
    Next
    [j12].Resize(UBound(brr)) = brr
    MsgBox "整理结束", , "提示"
End Sub

跳转到最佳答案楼层

雪舞子

ADO方式访问整理，楼主测试：

1. Sub test()
   
2.     Dim cnn As Object, rst As Object
   
3.     Dim arr, wkb$, wkt$, str$, i%, k%
   
4.     Set cnn = CreateObject("ADODB.Connection")
   
5.     Set rst = CreateObject("ADODB.Recordset")
   
6.     arr = [h12:h149]
   
7.     ReDim brr(1 To UBound(arr), 1 To 1)
   
8.     For i = 1 To UBound(arr)
   
9.         k = InStr(arr(i, 1), "]")
   
10.         If k > 6 Then
    
11.             wkb = Mid(arr(i, 1), 2, k - 2)
    
12.             If Dir(ThisWorkbook.Path & "" & wkb) = "" Then
    
13.                 brr(i, 1) = "无此档案"
    
14.             Else
    
15.                 wkt = Replace(Mid(arr(i, 1), k + 1, InStr(arr(i, 1), "!") - k - 2), ".", "#")
    
16.                 cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no;imex=1';data source=" & ThisWorkbook.Path & "" & wkb
    
17.                 '                cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 Xml;HDR=no;imex=1';Data Source=" & ThisWorkbook.Path & "" & wkb
    
18.                 Set rst = cnn.OpenSchema(20)
    
19.                 Do Until rst.EOF
    
20.                     If rst!TABLE_TYPE = "TABLE" And Right(rst!TABLE_NAME.Value, 2) = "" Then
    
21.                         str = Replace(Replace(rst!TABLE_NAME.Value, "'", ""), "$", "")
    
22.                     End If
    
23.                     If wkt = str Then brr(i, 1) = "有此档案": k = 0: Exit Do
    
24.                     rst.MoveNext
    
25.                 Loop
    
26.                 If k > 0 Then brr(i, 1) = "无此档案"
    
27.                 rst.Close
    
28.                 cnn.Close
    
29.             End If
    
30.         Else
    
31.             brr(i, 1) = ""
    
32.         End If
    
33.     Next
    
34.     [j12].Resize(UBound(brr)) = brr
    
35.     MsgBox "整理结束", , "提示"
    
36. End Sub

复制代码

雪舞子

不知道为什么，用标签粘贴代码总是有几个显示不全，直接贴一下：

Sub test()
    Dim cnn As Object, rst As Object
    Dim arr, wkb$, wkt$, str$, i%, k%
    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    arr = [h12:h149]
    ReDim brr(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        k = InStr(arr(i, 1), "]")
        If k > 6 Then
            wkb = Mid(arr(i, 1), 2, k - 2)
            If Dir(ThisWorkbook.Path & "\" & wkb) = "" Then
                brr(i, 1) = "无此档案"
            Else
                wkt = Replace(Mid(arr(i, 1), k + 1, InStr(arr(i, 1), "!") - k - 2), ".", "#")
                cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no;imex=1';data source=" & ThisWorkbook.Path & "\" & wkb
                '                cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 Xml;HDR=no;imex=1';Data Source=" & ThisWorkbook.Path & "\" & wkb
                Set rst = cnn.OpenSchema(20)
                Do Until rst.EOF
                    If rst!TABLE_TYPE = "TABLE" And Right(rst!TABLE_NAME.Value, 2) = "$'" Then
                        str = Replace(Replace(rst!TABLE_NAME.Value, "'", ""), "$", "")
                    End If
                    If wkt = str Then brr(i, 1) = "有此档案": k = 0: Exit Do
                    rst.MoveNext
                Loop
                If k > 0 Then brr(i, 1) = "无此档案"
                rst.Close
                cnn.Close
            End If
        Else
            brr(i, 1) = ""
        End If
    Next
    [j12].Resize(UBound(brr)) = brr
    MsgBox "整理结束", , "提示"
End Sub

excel白兔

怎么给金币呀 不会呀