复制粘贴多个单元格Excel VBA

Question

I have tens of individual cells that need to be copied from a daily report to a master sheet every day. The cells that need to be copied are found on different rows in the daily report, and need to be paste into various cells in the master.

My 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

`

So C31 goes to KD213, D31 to KE213 etc.. but this gives an error since excel can only deal with 2 cells to copy.

Anyone know how to add additional copy cells and destinations?

Thanks!

Answer 1

Here is a simple way:

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

You can call as many ranges (currently manually) as you wish with a short sub-routine called Sub CopyManyRanges(Range_Orig As String, Range_Dest As String)

Option Explicit Section:

Option Explicit

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

Your COPYCELL Routine:

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 Routine:

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

Here's another way to do it by capturing the ranges then looping through them. Just make sure you set the ranges in the proper order.

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