提取文件夹下面，每个工作簿指定列的内容。

lujun0323

提取O、P、Q列下面的数据
效果为
就是把文件夹下面所有的工作簿中的这些列的数据提取到一个表格当中去。现在文件中有20几个，实际有几千个，请大神帮忙！小弟拜谢！ 数据处理.rar (1.5 MB, 下载次数: 60)

2017-3-25 18:22 上传

点击文件名下载附件

lujun0323

这个没有人会吗？

skyzxh

应该不难吧？。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。

jiminyanyan

给你个代码，稍微作一下修改就可以了…………。
Sub vba入门jimin()
'扣扣494585639
    Dim MyPath$, MyName$, sh As Worksheet
    Dim brr(1 To 60000, 1 To 6)
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Cells.Clear
    MyPath = ThisWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xls*")
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            With GetObject(MyPath & MyName)
                m = m + 1
                If m = 1 Then
                    arr = .Sheets("sheet1").Range("a1:f" & .Sheets("sheet1").Range("b65535").End(xlUp).Row)
                    For i = 1 To UBound(arr)
                        k = k + 1
                        For j = 1 To UBound(arr, 2)
                            brr(k, j) = arr(i, j)
                        Next
                    Next
                Else
                     arr = .Sheets("sheet1").Range("a1:f" & .Sheets("sheet1").Range("b65535").End(xlUp).Row)
                    For i = 2 To UBound(arr)
                        k = k + 1
                        For j = 1 To UBound(arr, 2)
                            brr(k, j) = arr(i, j)
                        Next
                    Next
                End If
                .Close False
            End With
        End If
        MyName = Dir
    Loop
    Sheet1.Range("a1:f60000").ClearContents
    Sheet1.Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    Application.ScreenUpdating = True
End Sub

lujun0323

可是没有人回复呢

lsc900707

lujun0323 发表于 2017-3-25 20:38
可是没有人回复呢

Sub lsc()
t = Timer
myPath = ThisWorkbook.Path & "\"
MyName = Dir(myPath & "*.xls")
Application.ScreenUpdating = False
ReDim brr(1 To 30000, 1 To 3)
Do While MyName <> ""
    If MyName <> ThisWorkbook.Name Then
        n = n + 1
        Set sh = GetObject(myPath & MyName).Sheets(1)
        Arr = sh.[A3].CurrentRegion
        Workbooks(MyName).Close False
        For i = 1 To UBound(Arr)
            m = m + 1
            brr(m, 1) = Arr(i, 15): brr(m, 2) = Arr(i, 16): brr(m, 3) = Arr(i, 17)
        Next
    End If
    MyName = Dir
Loop
Set sh = Nothing
With Sheet1
     .Rows("1:30000").ClearContents
     .Columns(1).NumberFormatLocal = "@"
     .[A1].Resize(m, 3).Value = brr
End With
Application.ScreenUpdating = True
MsgBox "汇总完成！汇总了：" & n & "个工作表；共有：" & m & "行数据。" & vbCr & "用时：" & Format(Timer - t, "0.00") & "秒", vbInformation
End Sub

lsc900707

lujun0323 发表于 2017-3-25 20:38
可是没有人回复呢

Sub lsc()
t = Timer
myPath = ThisWorkbook.Path & "\"
MyName = Dir(myPath & "*.xls")
Application.ScreenUpdating = False
ReDim brr(1 To 30000, 1 To 3)
Do While MyName <> ""
    If MyName <> ThisWorkbook.Name Then
        n = n + 1
        Set sh = GetObject(myPath & MyName).Sheets(1)
        Arr = sh.[A3].CurrentRegion
        Workbooks(MyName).Close False
        For i = 1 To UBound(Arr)
            m = m + 1
            brr(m, 1) = Arr(i, 15): brr(m, 2) = Arr(i, 16): brr(m, 3) = Arr(i, 17)
        Next
    End If
    MyName = Dir
Loop
Set sh = Nothing
With Sheet1
     .Rows("1:30000").ClearContents
     .Columns(1).NumberFormatLocal = "@"
     .[A1].Resize(m, 3).Value = brr
End With
Application.ScreenUpdating = True
MsgBox "汇总完成！汇总了：" & n & "个工作表；共有：" & m & "行数据。" & vbCr & "用时：" & Format(Timer - t, "0.00") & "秒", vbInformation
End Sub

lsc900707

lujun0323 发表于 2017-3-25 20:38
可是没有人回复呢

代码发两次，两次都要审核，(&#65377;&#65381;&#8704;&#65381;)&#65417;&#65438;嗨！

jiminyanyan

lsc900707 发表于 2017-3-25 21:22
代码发两次，两次都要审核，(&#65377;&#65381;&#8704;&#65381;)&#65417;&#65438;嗨！

我好像不用审核的…………不知怎么回事……。

lsc900707

jiminyanyan 发表于 2017-3-25 21:39
我好像不用审核的…………不知怎么回事……。

那就奇怪了，从没遇到要审核的情况？我这段时间老是这样，都不知道怎么回事了。附件也老是传不上。