[已解决]求助，帮忙改个代码

menlgr

帮忙改个代码，要提取工作薄中所有工作表的某些单元格，汇总到台帐工作薄的指定单元格，我的这个总是提示无法打开台帐，各位大神帮忙看看

最佳答案

月排行榜 / 总排行榜

爱疯

2016-6-14 16:01

Sub test()
    Dim myPath$, AK As Workbook, OAK As Workbook
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set OAK = ActiveWorkbook
    myPath = ThisWorkbook.Path & "/"    '把文件路径定义给变量
    Application.ScreenUpdating = False    '冻结屏幕，以防屏幕抖动
    Set FD = fso.GetFolder(myPath)
    I = 1
    ii = 2

    For Each f In FD.Files
        If InStr(f.Name, OAK.Name) = 0 Then

            Set AK = Workbooks.Open(f.Path, True)
            AK.ActiveSheet.Range("c4").Copy OAK.Sheets(I).Range("a" & ii)
            AK.ActiveSheet.Range("d2").Copy OAK.Sheets(I).Range("b" & ii)
            AK.ActiveSheet.Range("b3").Copy OAK.Sheets(I).Range("c" & ii)
            AK.ActiveSheet.Range("b4").Copy OAK.Sheets(I).Range("d" & ii)
            AK.ActiveSheet.Range("d4").Copy OAK.Sheets(I).Range("e" & ii)
            AK.ActiveSheet.Range("d3").Copy OAK.Sheets(I).Range("f" & ii)
            AK.ActiveSheet.Range("b5").Copy OAK.Sheets(I).Range("g" & ii)
            AK.ActiveSheet.Range("d5").Copy OAK.Sheets(I).Range("h" & ii)
            AK.ActiveSheet.Range("f5").Copy OAK.Sheets(I).Range("i" & ii)
            AK.ActiveSheet.Range("h5").Copy OAK.Sheets(I).Range("j" & ii)
            AK.ActiveSheet.Range("h6").Copy OAK.Sheets(I).Range("k" & ii)
            AK.ActiveSheet.Range("d6").Copy OAK.Sheets(I).Range("l" & ii)
            AK.ActiveSheet.Range("f4").Copy OAK.Sheets(I).Range("m" & ii)
            AK.ActiveSheet.Range("f6").Copy OAK.Sheets(I).Range("n" & ii)
            AK.ActiveSheet.Range("f2").Copy OAK.Sheets(I).Range("o" & ii)
            AK.ActiveSheet.Range("f3").Copy OAK.Sheets(I).Range("p" & ii)
            AK.Close False
            I = I + 1
            ii = ii + 1

        End If
    Next
    Application.ScreenUpdating = True    '冻结屏幕,此类语句一般成对使用End Sub
End Sub




你测试看下？

跳转到最佳答案楼层

爱疯

代码所在的工作簿，和要打开工作簿，名称一样，都叫"台帐.xlsm"。

把代码所在工作簿改为别的名称。再运行，看下？

menlgr

爱疯 发表于 2016-6-14 15:28
代码所在的工作簿，和要打开工作簿，名称一样，都叫"台帐.xlsm"。

把代码所在工作簿改为别的名称。再运行 ...

改了名字，不出现那个提示了，但是点击执行，闪一下，然后没有反应

爱疯

Sub test()
    Dim myPath$, AK As Workbook, OAK As Workbook
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set OAK = ActiveWorkbook
    myPath = ThisWorkbook.Path & "/"    '把文件路径定义给变量
    Application.ScreenUpdating = False    '冻结屏幕，以防屏幕抖动
    Set FD = fso.GetFolder(myPath)
    I = 1
    ii = 2

    For Each f In FD.Files
        If InStr(f.Name, OAK.Name) = 0 Then

            Set AK = Workbooks.Open(f.Path, True)
            AK.ActiveSheet.Range("c4").Copy OAK.Sheets(I).Range("a" & ii)
            AK.ActiveSheet.Range("d2").Copy OAK.Sheets(I).Range("b" & ii)
            AK.ActiveSheet.Range("b3").Copy OAK.Sheets(I).Range("c" & ii)
            AK.ActiveSheet.Range("b4").Copy OAK.Sheets(I).Range("d" & ii)
            AK.ActiveSheet.Range("d4").Copy OAK.Sheets(I).Range("e" & ii)
            AK.ActiveSheet.Range("d3").Copy OAK.Sheets(I).Range("f" & ii)
            AK.ActiveSheet.Range("b5").Copy OAK.Sheets(I).Range("g" & ii)
            AK.ActiveSheet.Range("d5").Copy OAK.Sheets(I).Range("h" & ii)
            AK.ActiveSheet.Range("f5").Copy OAK.Sheets(I).Range("i" & ii)
            AK.ActiveSheet.Range("h5").Copy OAK.Sheets(I).Range("j" & ii)
            AK.ActiveSheet.Range("h6").Copy OAK.Sheets(I).Range("k" & ii)
            AK.ActiveSheet.Range("d6").Copy OAK.Sheets(I).Range("l" & ii)
            AK.ActiveSheet.Range("f4").Copy OAK.Sheets(I).Range("m" & ii)
            AK.ActiveSheet.Range("f6").Copy OAK.Sheets(I).Range("n" & ii)
            AK.ActiveSheet.Range("f2").Copy OAK.Sheets(I).Range("o" & ii)
            AK.ActiveSheet.Range("f3").Copy OAK.Sheets(I).Range("p" & ii)
            AK.Close False
            I = I + 1
            ii = ii + 1

        End If
    Next
    Application.ScreenUpdating = True    '冻结屏幕,此类语句一般成对使用End Sub
End Sub




你测试看下？

menlgr

爱疯 发表于 2016-6-14 16:01
Sub test()
    Dim myPath$, AK As Workbook, OAK As Workbook
    Set fso = CreateObject("Scripting. ...

有两个问题，1、提取出来的是公式，2、不循环，只提取了一个，请大神帮忙看看是什么原因了

爱疯

你先上传一个能够打开的测试文件，替换掉"试验报告.xlsx"

这样别人才好测试

menlgr

爱疯 发表于 2016-6-14 16:57
你先上传一个能够打开的测试文件，替换掉"试验报告.xlsx"

这样别人才好测试

改了一下试验报告的后缀，改成.xls了，您看一下

爱疯

Sub test()
    Dim myPath$, AK As Workbook, OAK As Workbook
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set OAK = ActiveWorkbook
    Set FD = fso.GetFolder(ThisWorkbook.Path)
    Application.ScreenUpdating = False    '冻结屏幕，以防屏幕抖动
    OAK.Sheets(1).Range("a3:g65536").ClearContents

    For Each f In FD.Files
        If InStr(f.Name, OAK.Name) = 0 Then
            Set AK = Workbooks.Open(f.Path, True)
            For i = 1 To AK.Sheets.Count
                With AK.Sheets(i)
                    .Range("l7").Copy OAK.Sheets(1).Cells(i + 2, "a")
                    .Range("c6").Copy OAK.Sheets(1).Cells(i + 2, "b")
                    .Range("l6").Copy OAK.Sheets(1).Cells(i + 2, "c")
                    .Range("a10").Copy OAK.Sheets(1).Cells(i + 2, "d")
                    .Range("h10").Copy OAK.Sheets(1).Cells(i + 2, "e")
                    .Range("j10").Copy OAK.Sheets(1).Cells(i + 2, "f")
                    .Range("l10").Copy OAK.Sheets(1).Cells(i + 2, "g")
                End With
            Next i
            AK.Close False
        End If
    Next
End Sub

menlgr

爱疯 发表于 2016-6-14 17:34
Sub test()
    Dim myPath$, AK As Workbook, OAK As Workbook
    Set fso = CreateObject("Scripting. ...

基本上很不错了，但是换了个里头有公式的表格，提取出来的就是公式，您看看

爱疯

Sub test()
    Dim AK As Workbook, OAK As Workbook
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set OAK = ActiveWorkbook
    Set FD = fso.GetFolder(ThisWorkbook.Path)

    For Each f In FD.Files
        If InStr(f.Name, OAK.Name) = 0 Then
            Set AK = Workbooks.Open(f.Path, True)
            For i = 1 To AK.Sheets.Count
                With AK.Sheets(i)
                    OAK.Sheets(1).Cells(i + 5, "b") = .[L7]
                    OAK.Sheets(1).Cells(i + 5, "c") = .[C6]
                    OAK.Sheets(1).Cells(i + 5, "d") = .[J10]
                    OAK.Sheets(1).Cells(i + 5, "e") = .[H10]
                    OAK.Sheets(1).Cells(i + 5, "f") = .[L10]
                    OAK.Sheets(1).Cells(i + 5, "g") = .[A10]
                    OAK.Sheets(1).Cells(i + 5, "h") = .[L4]
                End With
            Next i
            AK.Close False
        End If
    Next
End Sub