Copy Paste Несколько ячеек Excel VBA

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 Раздел:

Option Explicit 

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

You г 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 

ВС 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