Question

我每天需要将数十个单独的单元格从日常报告复制到母版。需要复制的单元格位于每日报表的不同行中，需要粘贴到主页中的各个单元格中。

我的VBA：

`Sub COPYCELL()
Dim wbk As Workbook

strFirstFile = "c:\daily_report-2016-07-19.xlsx"
strSecondFile = "c:\testbook.xlsx"

Set wbk = Workbooks.Open(strFirstFile)
With wbk.Sheets("(Data)")

    Range("C31", "D31", "E31").Copy



End With

Set wbk = Workbooks.Open(strSecondFile)
With wbk.Sheets("Sheet1")
    Range("KD213", "KE213", "KJ213").PasteSpecial




End With

End Sub

`

因此C31转到KD213，D31转到KE213等。但这会产生错误，因为excel只能处理2个要复制的单元格。

任何人都知道如何添加额外的复制单元格和目的地？

谢谢！

Answer 1

这是一个简单的方法：

Sub COPYCELL()

    Dim wbk1 As Workbook, wbk2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet

    strFirstFile = "c:\daily_report-2016-07-19.xlsx"
    strSecondFile = "c:\testbook.xlsx"

    Set wbk1 = Workbooks.Open(strFirstFile)
    Set ws1 = wbk1.Sheets("(Data)")

    Set wbk2 = Workbooks.Open(strSecondFile)
    Set ws2 = wbk2.Sheets("Sheet1")

    With ws2

        .Range("KD213").Value = ws1.Range("C31").Value
        .Range("KE213").Value = ws1.Range("D31").Value
        .Range("KJ213").Value = ws1.Range("E31").Value

    End With

End Sub

Answer 2

您可以使用名为 Sub CopyManyRanges（Range_Orig As String，Range_Dest As String）的短子程序调用尽可能多的范围（当前是手动的）

选项明确部分：

Option Explicit

Dim wb_first As Workbook
Dim wb_second As Workbook
Dim sht_data As Worksheet
Dim sht_1 As Worksheet

您的 COPYCELL 例程：

Sub COPYCELL()

Dim strFirstFile As String
Dim strSecondFile As String  

strFirstFile = "c:\daily_report-2016-07-19.xlsx"
strSecondFile = "c:\testbook.xlsx"

Set wb_first = Workbooks.Open(strFirstFile)
Set wb_second = Workbooks.Open(strSecondFile)

Set sht_data = wb_first.Sheets("(Data)")
Set sht_1 = wb_second.Sheets("Sheet1")

' you can add a For Loop here
Call CopyManyRanges("C31", "KD213")
Call CopyManyRanges("D31", "KE213")
Call CopyManyRanges("E31", "KJ213")

End Sub

Sun CopyManyRanges 例程：

Sub CopyManyRanges(Range_Orig As String, Range_Dest As String)

sht_data.Range(Range_Orig).Copy
sht_1.Range(Range_Dest).PasteSpecial

End Sub

Answer 3

这是通过捕获范围然后循环遍历它们的另一种方法。只需确保按正确的顺序设置范围。

Sub COPYCELL()

    Dim wbk As Workbook
    Dim strFile as String

    strFile = "c:\daily_report-2016-07-19.xlsx"
    Set wbk = Workbooks.Open(strFile)

    Dim rng1 as Range 
    Set rng1 = wbk.Sheets("(Data)").Range("C31,D31,E31") 'add more as needed

    wbk.Close false

    strFile = "c:\testbook.xlsx"
    Set wbk = Workbooks.Open(strFile)

    Dim rng2 as Range
    Set rng2 = wbk.Sheets("Sheet1").Range("KD213,KE213,KJ213") 'add more as needed 

    Dim i as Long
    For each cel in rng2
        cel.Value = rng1.Cells(i+1)
        i = i + 1
    Next

    wkb.Close True

End Sub

复制粘贴多个单元格Excel VBA

3 个答案: