[已解决]求助！用VBA将多个Excel中数据填入总表

hadesqu

我现在有一些数据是从机器上下来的，有100个excel表，我希望从采集表中的I列里的个别数据填入总表中，比如：

将1_ISM.xls中 I72的填入汇总表的B5，
                      I73 填入 C5
                      I74 填入 D5，
                      I75 填入 E5，
                      I82 填入 I5，
                      I83 填入 J5,
                      I80 填入K5,  
                      I81 填入 L5

请高手帮忙用VBA 解决下

最佳答案

月排行榜 / 总排行榜

爱疯

2015-8-5 10:31

Sub test()
    Dim p$, f$, A, B, t%, str$, tm&

    tm = Timer
    Application.ScreenUpdating = False
    Call test2
    A = Sheets(1).UsedRange
    p = ThisWorkbook.Path & "\"
    str = ThisWorkbook.Name

    f = Dir(p)
    Do While f <> ""
        If f <> str Then
            With GetObject(p & f)
                B = .Sheets(1).[I72:I83]
                .Close 0
            End With

            t = VBA.Split(f, "_")(0)
            t = (t - 1) * 7 + 1 + 4
            A(t, 2) = B(1, 1)
            A(t, 3) = B(2, 1)
            A(t, 4) = B(3, 1)
            A(t, 5) = B(4, 1)
            A(t, 9) = B(9, 1)
            A(t, 10) = B(10, 1)
            A(t, 11) = B(7, 1)
            A(t, 12) = B(8, 1)
        End If
        f = Dir
    Loop

    [a1].Resize(UBound(A), UBound(A, 2)) = A
    MsgBox Format(Timer - tm, "0.000") & "s 完成！"
End Sub

'可选，清除 "汇总.xlsm" 之前保存的数据
Sub test2()
    Dim A, i, j
    A = Sheets(1).UsedRange
    For i = 5 To UBound(A) Step 7
        For j = 2 To 5
            A(i, j) = ""
        Next j

        For j = 9 To 12
            A(i, j) = ""
        Next j
    Next i
    [a1].Resize(UBound(A), UBound(A, 2)) = A
End Sub


test2.rar (150.59 KB, 下载次数: 24)

2015-8-5 10:31 上传

点击文件名下载附件

跳转到最佳答案楼层

爱疯

没看懂。如果只2个文件，汇总后是怎样的？

hadesqu

爱疯 发表于 2015-8-4 23:26
没看懂。如果只2个文件，汇总后是怎样的？

不好意思 ，我重新上传了总汇表，我举了2个产品的例子，可以帮忙看看嘛？

爱疯

Sub test()
    Dim p$, f$, A, B, t%, str$, tm&

    tm = Timer
    Application.ScreenUpdating = False
    Call test2
    A = Sheets(1).UsedRange
    p = ThisWorkbook.Path & "\"
    str = ThisWorkbook.Name

    f = Dir(p)
    Do While f <> ""
        If f <> str Then
            With GetObject(p & f)
                B = .Sheets(1).[I72:I83]
                .Close 0
            End With

            t = VBA.Split(f, "_")(0)
            t = (t - 1) * 7 + 1 + 4
            A(t, 2) = B(1, 1)
            A(t, 3) = B(2, 1)
            A(t, 4) = B(3, 1)
            A(t, 5) = B(4, 1)
            A(t, 9) = B(9, 1)
            A(t, 10) = B(10, 1)
            A(t, 11) = B(7, 1)
            A(t, 12) = B(8, 1)
        End If
        f = Dir
    Loop

    [a1].Resize(UBound(A), UBound(A, 2)) = A
    MsgBox Format(Timer - tm, "0.000") & "s 完成！"
End Sub

'可选，清除 "汇总.xlsm" 之前保存的数据
Sub test2()
    Dim A, i, j
    A = Sheets(1).UsedRange
    For i = 5 To UBound(A) Step 7
        For j = 2 To 5
            A(i, j) = ""
        Next j

        For j = 9 To 12
            A(i, j) = ""
        Next j
    Next i
    [a1].Resize(UBound(A), UBound(A, 2)) = A
End Sub


test2.rar (150.59 KB, 下载次数: 24)

2015-8-5 10:31 上传

点击文件名下载附件

hadesqu

爱疯 发表于 2015-8-5 10:31
Sub test()
    Dim p$, f$, A, B, t%, str$, tm&

完美，谢谢~~~

hadesqu

爱疯 发表于 2015-8-5 10:31
Sub test()
    Dim p$, f$, A, B, t%, str$, tm&

你好，我发现个问题，有4列数据反了，K列的数据应该和I列的数据对调，L列的数据应该和J列的数据对调，可以再帮忙看吗

爱疯

hadesqu 发表于 2015-8-5 11:23
你好，我发现个问题，有4列数据反了，K列的数据应该和I列的数据对调，L列的数据应该和J列的数据对调，可以 ...

没懂你说的怎样不对应。

要不你把这8个等式，手工谁对应谁，下午再来改。。。。

hadesqu

爱疯 发表于 2015-8-5 11:35
没懂你说的怎样不对应。

要不你把这8个等式，手工谁对应谁，下午再来改。。。。

谢谢啦，我已经看懂你的程序了，学习了，自己已经改好位子了，谢谢~