数组提取数据

张雄友

数组提取数据，实现效果。

marchwen01

        Do Until rs.EOF
                If rs.Fields("TABLE_TYPE") = "TABLE" Then
                    s = Replace(rs("TABLE_NAME").Value, "'", "")
                    If Right(s, 1) = "$" Then
                        SQL = "select 物品,型号,数量 from [" & s & "] where 物品 is not null"
                        
                        On Error Resume Next
                        Set rst = cnn.Execute(SQL)
                        If Err.Number = -2147217904 Then GoTo next0
                        On Error GoTo 0
                        
                        If Not rst.EOF Then
                        arr = rst.GetRows()
                        For i = 0 To UBound(arr, 2)
                         c = Split(Filepath(x), "\")
                                m = m + 1
                                For j = 1 To 3
                                    If Right(Filepath(x), 4) = ".xls" Then
                                              If InStr(Filepath(x), "\") Then
                                                  brr(m, -2) = c(0)
                                                 brr(m, -1) = Left(c(1), Len(c(1)) - 4)
                                                Else
                                                     brr(m, -2) = a(UBound(a))
                                                      brr(m, -1) = Left(Filepath(x), Len(Filepath(x)) - 4)
                                                 End If
                                    Else
                                               If InStr(Filepath(x), "\") Then
                                               brr(m, -2) = c(0)
                                                    brr(m, -1) = Left(c(1), Len(c(1)) - 5)
                                               Else
                                                      brr(m, -2) = a(UBound(a))
                                                        brr(m, -1) = Left(Filepath(x), Len(Filepath(x)) - 5)
                                                    End If
                                    End If
                                    brr(m, 0) = Replace(Replace(s, "$", ""), "'", "")
                                    brr(m, j) = arr(j - 1, i)
                               Next
                        Next
                    End If
                    End If
                End If
next0:
            rs.MoveNext
        Loop



加几行容错就可以了。

文件夹名，工作薄名，工作表名，都可以写进 Sql语句的。

比如：

SELECT Mypath AS 文件夹名,Filepath(x) AS 工作薄名, s AS 工作表名,* FROM [S$]

张雄友

marchwen01 发表于 2015-4-29 08:55
Do Until rs.EOF
                If rs.Fields("TABLE_TYPE") = "TABLE" Then
                 ...

解决了一个大问题：但是这种写法会出错，您看看。
SQL = "select Mypath AS 文件夹名,Filepath(x) AS 工作薄名, s AS 工作表名,物品,型号,数量 from [" & s & "] where 物品 is not null"

marchwen01

张雄友 发表于 2015-4-29 12:55
解决了一个大问题：但是这种写法会出错，您看看。
SQL = "select Mypath AS 文件夹名,Filepath(x) AS 工 ...

Mypath Filepath(x) 这些都是变量来的，你直接写肯定会出错了。

这所以要用一个容错语句，是因为有些工作簿里面有空的工作表，遍历到空的工作表时，取不到数据才出错的。

marchwen01

做了一个，工作簿名和工作表名没加修整。

marchwen01

又改了一下你的代码，实在是不敢再弄斧了。

张雄友

marchwen01 发表于 2015-4-30 19:06
又改了一下你的代码，实在是不敢再弄斧了。

黄色单元格的文件夹名，是DD 才对。

marchwen01

张雄友 发表于 2015-4-30 21:44
黄色单元格的文件夹名，是DD 才对。

微调一下就可以了。

Sub GetData()
    Dim cnn As Object, rs As Object, SQL$, MyPath$, MyFile$, wb$, ws$, Folder$, x&, Filepath
    [A2:F65536].ClearContents
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
    Set cnn = CreateObject("ADODB.Connection")
    Folder = Split(MyPath, "\")(UBound(Split(MyPath, "\")) - 1)
    Filepath = GetName(MyPath)
   
    'cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Filepath(x)
    Select Case Application.Version * 1
    Case Is <= 11
        strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;Imex=1;Hdr=Yes';Data source="
    Case Is >= 12
        strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;Imex=1;Hdr=Yes';Data Source="
    End Select

    For x = 0 To UBound(Filepath)
        cnn.Open strConn & Filepath(x)
        
        If InStr(Filepath(x), "\") > 0 Then Folder = Split(Filepath(x), "\")(UBound(Split(Filepath(x), "\")) - 1)        
        Set rs = cnn.OpenSchema(20)
        Do Until rs.EOF
            If rs.Fields("TABLE_TYPE") = "TABLE" Then
                wb = Replace(Filepath(x), ".xls", "")
                If InStr(wb, "\") > 0 Then wb = Split(wb, "\")(UBound(Split(wb, "\")))
                ws = Replace(rs("TABLE_NAME").Value, "'", "")
                SQL = "SELECT '" & Folder & "' AS 文件夹名,'" & wb & "' AS 工作簿名,'" & Replace(ws, "$", "") & "' AS 工作表名,物品,型号,数量 FROM [" & ws & "] "
               
                On Error Resume Next
                Set rst = cnn.Execute(SQL)
                If Err.Number = -2147217904 Then GoTo Next0
                Cells(Rows.Count, 1).End(3).Offset(1).CopyFromRecordset cnn.Execute(SQL)
            End If
Next0:
            On Error GoTo 0
            rs.movenext
        Loop
        cnn.Close
    Next
    [A1].CurrentRegion.Columns.AutoFit
    Set rs = Nothing
    Set cnn = Nothing
End Sub


select case 判断版本移出循环体外。（这个微调跟取错文件夹的错误没有关系）
截取文件夹名称的那个 If 前移了一下，在进入循环工作表之前运行就可以了。

marchwen01

请看附件，又改了一点点。

LMY123

ADO,子文件夹