从关闭的工作簿 excel VBA 复制

copying from closed workbook excel VBA

提问by novak100

Ok I get to the point where code is reading data from closed workbook and can paste it into sheet2 in that workbook. This is my new code:

好的，我到了代码从关闭的工作簿中读取数据的地步，可以将其粘贴到该工作簿中的 sheet2 中。这是我的新代码：

    Sub Copy456()

    Dim iCol As Long
    Dim iSht As Long
    Dim i As Long



    'Fpath = "C:\testy" ' change to your directory
    'Fname = Dir(Fpath & "*.xlsx")

    Workbooks.Open ("run1.xlsx")

    For i = 1 To Worksheets.Count
        Worksheets(i).Activate

     ' Loop through columns
     For iSht = 1 To 6 ' no of sheets
     For iCol = 1 To 6 ' no of columns

        With Worksheets(i).Columns(iCol)

            If ((.Cells(1, 1).Value = "Time")) Then ' if first cell=Time then copy two columns
                Range(.Cells(1, 2), .End(xlDown)).Select
                Selection.Copy Destination:=Workbooks("Your Idea.xlsm").Worksheets("Sheet2").Columns((i + 1) + i).Cells(2, 1)
                Worksheets("Sheet2").Cells(i * 2 + 1) = Worksheets(i).Name
            Else
                ' do nothing

            End If
        End With

    Next iCol
    Next iSht
Next i
End Sub

But once I change that part of code:

但是一旦我更改了那部分代码：

            Selection.Copy Destination:=Worksheets("Sheet2").Columns((i + 1) + i).Cells(2, 1)

into that code:

进入该代码：

   Destination:=Workbooks("general.xlsx").Worksheets("Sheet2").Columns((i + 1) + i).Cells(2, 1)

It stop working issuing error: "subscription is out of range". File general.xlsx is an empty file which is closed as well.

它停止工作，发出错误：“订阅超出范围”。文件general.xlsx 是一个空文件，它也被关闭。

When I change code into:

当我将代码更改为：

`Selection.Copy Destination:=Workbooks("Your Idea.xlsm").Worksheets("Sheet2").Columns((i + 1) + i).Cells(2, 1)

It then issue an error: "1004 cannot change part of merged cell". File "Your Idea.xlsm" is the file from which I running this script.

然后它发出错误：“1004 无法更改合并单元格的一部分”。文件“Your Idea.xlsm”是我从中运行此脚本的文件。

Any help with this problem?

对这个问题有什么帮助吗？

回答by T I

try to avoid merged cells when making spreadsheets as in my humble experience they can come back to bite you. This is how I would roughly go about copying data from one sheet to another you will need to implement your own logic when iterating through and setting the actual ranges you require but it should give you some idea, as I said in my comment be more explicit when setting ranges and avoid magic.

在制作电子表格时尽量避免合并单元格，因为根据我的卑微经验，它们可能会反过来咬你。这就是我粗略地将数据从一张纸复制到另一张纸的方式，您需要在迭代和设置所需的实际范围时实现自己的逻辑，但它应该给您一些想法，正如我在评论中所说的更明确在设置范围时避免magic.

AFAIK you have to open files in order to manipulate them with VBA

AFAIK 你必须打开文件才能用 VBA 操作它们

Sub makeCopy()
    ' turn off features
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' some constants
    Const PATH = ""
    Const FILE = PATH & "FOO.xls"

    ' some variables
    Dim thisWb, otherWb As Workbook
    Dim thisWs, otherWs As Worksheet
    Dim i As Integer:   i = 0
    Dim c As Integer:   c = 0
    Dim thisRg, otherRg As Range

    ' some set-up
    Set thisWb = Application.ActiveWorkbook
    Set otherWb = Application.Workbooks.Open(FILE)

    ' count the number of worksheets in this workbook
    For Each thisWs In thisWb.Worksheets
        c = c + 1
    Next thisWs

    ' count the number of worksheets in the other workbook
    For Each thisWs In otherWb.Worksheets
        i = i + 1
    Next thisWs

    ' add more worksheets if required
    If c <= i Then
        For c = 1 To i
            thisWb.Worksheets.Add
        Next c
    End If

    ' reset i and c
    i = 0:    c = 0

    ' loop through other workbooks worksheets copying
    ' their contents into this workbook
    For Each otherWs In otherWb.Worksheets
        i = i + 1
        Set thisWs = thisWb.Worksheets(i)

        ' ADD YOUR OWN LOGIC FOR SETTING `thisRg` AND
        ' `otherRg` TO THE APPROPRIATE RANGE
        Set thisRg = thisWs.Range("A1:  C100")
        Set otherRg = otherWs.Range("A1:  C100")

        otherRg.Copy (thisRg)

    Next otherWs

    ' save this workbook
    thisWb.Save

    ' clean up  
    Set otherWs = Nothing
    otherWb.Close
    Set otherWb = Nothing
    Set thisWb = Nothing
    Set thisWs = Nothing

    ' restore features
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.Calculate

End Sub