Kopieren Paste mehrere Zellen Excel VBA

Question

Ich habe Dutzende von einzelnen Zellen, die jeden Tag von einem täglichen Bericht auf ein Hauptblatt kopiert werden müssen. Die Zellen, die kopiert werden müssen, werden in verschiedenen Zeilen im täglichen Bericht gefunden und müssen in verschiedene Zellen im Master eingefügt werden.

Mein 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 geht C31 zu KD213, D31 zu KE213 etc .. aber das gibt einen Fehler, da Excel nur mit 2-Zellen umgehen kann zu kopieren.

Wer weiß, wie man zusätzliche Kopierzellen und Ziele hinzufügt?

Danke!

Answer 1

Hier ist eine einfache Art und Weise:

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

Sie können beliebig viele Bereiche nennen (derzeit manuell), wie Sie mit einem kurzen Unterroutine Sub CopyManyRanges (Range_Orig As String, Range_Dest As String) genannt wollen

Option Explicit Sektion:

Option Explicit 

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

Sie r 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

Hier ist eine andere Möglichkeit, es zu tun, indem die Bereiche dann durch sie Looping zu erfassen. Stellen Sie nur sicher, dass Sie die Bereiche in der richtigen Reihenfolge festlegen.

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