[已解决]提取数据不全，只提取了一个表的。

张雄友

提取每个表最后一行总数据，提取数据不全，只提取了一个表的。

最佳答案

月排行榜 / 总排行榜

zjdh

2015-3-21 08:54

张雄友 发表于 2015-3-21 05:08
提取后一共是15行数据，怎么有75行？是用 open 方法遍历文件夹的。

Sub 提取每个表最后一行总数据()
    Dim mypath$, wj$, wb As Workbook, i&, j&, sh As Worksheet
    Dim arr, brr(1 To 60000, 1 To 9), s&
    [A2:I65536].ClearContents
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        mypath = .SelectedItems(1) & "\"
    End With
   Set w = Application.WorksheetFunction
    s = 0
    Filepath = GetName(mypath)
    For kk = 0 To UBound(Filepath)
        Set wb = Workbooks.Open(Filepath(kk))
        For Each sh In wb.Sheets
            If w.CountA(sh.UsedRange) Then
                    arr = sh.UsedRange
                    n = UBound(arr): s = s + 1
                    brr(s, 1) = s: brr(s, 2) = arr(1, 1)
                    For j = 3 To UBound(arr, 2)
                        brr(s, j) = arr(n, j)
                    Next
            End If
        Next
        wb.Close 0
    Next
    Range("D2").Resize(s, UBound(brr, 2)) = brr
    Application.ScreenUpdating = True
End Sub
Function GetName(lj As String)
    Dim MyName, dic, Did, i, t, F, tt, MyFileName
    Set dic = CreateObject("Scripting.Dictionary")
    Set Did = CreateObject("Scripting.Dictionary")
    dic.Add (lj), ""
    i = 0
    Do While i < dic.Count
        Ke = dic.Keys
        MyName = Dir(Ke(i), vbDirectory)
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then
                    dic.Add (Ke(i) & MyName & "\"), ""
                End If
            End If
            MyName = Dir
        Loop
        i = i + 1
    Loop
    For Each Ke In dic.Keys
        MyFileName = Dir(Ke & "*.xls*")
        Do While MyFileName <> ""
            If MyFileName <> ThisWorkbook.Name Then Did.Add (Ke & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    GetName = Did.Keys
End Function

跳转到最佳答案楼层

zjdh

提取每个表最后一行总数据.rar (13.99 KB, 下载次数: 0)

2015-3-20 20:36 上传

点击文件名下载附件

张雄友

zjdh 发表于 2015-3-20 20:12

无法下载附件。

dsmch

1. Sub Macro1()
   
2. Dim mypath$, wj$, wb As Workbook, i%, j%
   
3. Dim arr, brr(1 To 60000, 1 To 9), s&
   
4. Application.ScreenUpdating = False
   
5. '[a2:i65536].ClearContents
   
6. With Application.FileDialog(msoFileDialogFolderPicker)
   
7.       .InitialFileName = ThisWorkbook.Path & ""
   
8.       If .Show = False Then Exit Sub
   
9.       mypath = .SelectedItems(1) & ""
   
10.       wj = Dir(mypath & "*.xls*")
    
11.       Do While wj <> ""
    
12.         Set wb = Workbooks.Open(mypath & wj)
    
13.         For i = 1 To wb.Sheets.Count
    
14.             arr = wb.Sheets(i).UsedRange
    
15.             n = UBound(arr): s = s + 1
    
16.             brr(s, 1) = s: brr(s, 2) = arr(1, 1)
    
17.             For j = 3 To UBound(arr, 2)
    
18.                 brr(s, j) = arr(n, j)
    
19.             Next
    
20.         Next
    
21.         wb.Close 0
    
22.         wj = Dir
    
23.       Loop
    
24.   End With
    
25.   Range("a14").Resize(s, UBound(brr, 2)) = brr
    
26. Application.ScreenUpdating = True
    
27. End Sub

复制代码

张雄友

dsmch 发表于 2015-3-21 02:35

提取后一共是15行数据，怎么有75行？是用 open 方法遍历文件夹的。

张雄友

dsmch 发表于 2015-3-21 02:35

我的意思是您的代码只适合一个文件夹的，如果有多个文件夹就是不可以的。

zjdh

提取每个表最后一行总数据.rar (12.92 KB, 下载次数: 5)

2015-3-21 08:17 上传

点击文件名下载附件

zjdh

你的情况数组的大小是不确定的，而数组的扩容只能是第2维，你的格式与数组行、列相反，所以要用Transpose转置。

zjdh

zjdh 发表于 2015-3-21 08:30
你的情况数组的大小是不确定的，而数组的扩容只能是第2维，你的格式与数组行、列相反，所以要用Transpose转 ...

我的附件不存在5楼的问题啊。

zjdh

张雄友 发表于 2015-3-21 05:08
提取后一共是15行数据，怎么有75行？是用 open 方法遍历文件夹的。

Sub 提取每个表最后一行总数据()
    Dim mypath$, wj$, wb As Workbook, i&, j&, sh As Worksheet
    Dim arr, brr(1 To 60000, 1 To 9), s&
    [A2:I65536].ClearContents
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        mypath = .SelectedItems(1) & "\"
    End With
   Set w = Application.WorksheetFunction
    s = 0
    Filepath = GetName(mypath)
    For kk = 0 To UBound(Filepath)
        Set wb = Workbooks.Open(Filepath(kk))
        For Each sh In wb.Sheets
            If w.CountA(sh.UsedRange) Then
                    arr = sh.UsedRange
                    n = UBound(arr): s = s + 1
                    brr(s, 1) = s: brr(s, 2) = arr(1, 1)
                    For j = 3 To UBound(arr, 2)
                        brr(s, j) = arr(n, j)
                    Next
            End If
        Next
        wb.Close 0
    Next
    Range("D2").Resize(s, UBound(brr, 2)) = brr
    Application.ScreenUpdating = True
End Sub
Function GetName(lj As String)
    Dim MyName, dic, Did, i, t, F, tt, MyFileName
    Set dic = CreateObject("Scripting.Dictionary")
    Set Did = CreateObject("Scripting.Dictionary")
    dic.Add (lj), ""
    i = 0
    Do While i < dic.Count
        Ke = dic.Keys
        MyName = Dir(Ke(i), vbDirectory)
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then
                    dic.Add (Ke(i) & MyName & "\"), ""
                End If
            End If
            MyName = Dir
        Loop
        i = i + 1
    Loop
    For Each Ke In dic.Keys
        MyFileName = Dir(Ke & "*.xls*")
        Do While MyFileName <> ""
            If MyFileName <> ThisWorkbook.Name Then Did.Add (Ke & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    GetName = Did.Keys
End Function