Kopieren wenn Registerkartenname = Zellenwert
18.04.2018 16:32:27
Mario
ich habe ein Problem das meine bescheidenden VBA Kenntnisse leider übersteigt und hoffe hier einmal wieder fachkundige Hilfe zu finden.
Es geht um folgendes, ich möchte gerne das Werte von einer Arbeitsmappe (Sourcefile), in welchem sich auch das Makro befindet, in eine andere (Targetfile) kopiert werden und zwar nur wenn die Namen der Arbeitsblätter übereinstimmen.
Ich habe es mit folgendem VBA code versucht, leider funktioniert die Syntax in der Schleife nicht. Ich bekomme einen Anwendungsfehler in dieser Zeile:
Worksheets(ws.Name).Range(Cells(25, 3), Cells(25, 17)).Copy
Konnte im Internet leider aber auch nicht raus finden wie es richtig wäre
Zudem würde ich es gerne mit einer Schleife machen, anstatt mit zwei, damit das Makro schneller läuft. Ich beziehe mich in der Schleife für das Targetfile auf Range("N1").Value, weil dort der Name jeweiligen Arbeitsblätter eingetragen steht.
Option Explicit
Sub Import_Basisdatei()
Dim strPath As String, strDataName As String, strSearch As String
Dim ws As Worksheet
Dim Sourcefile As Workbook, Targetfile As Workbook
Dim raFind As Range
Dim i As Integer, WS_Count As Integer
Application.AskToUpdateLinks = False
Application.AutomationSecurity = msoAutomationSecurityLow
strPath = ThisWorkbook.Worksheets("Menu").Range("C52") 'Pfad Zieldatei
strDataName = ThisWorkbook.Worksheets("Menu").Range("C53") 'Name Zieldatei
Set Targetfile = Workbooks.Open(strPath & strDataName, UpdateLinks:=0, ReadOnly:=False)
WS_Count = ActiveWorkbook.Worksheets.Count
Set Sourcefile = ThisWorkbook
With Sourcefile
For Each ws In Worksheets
For i = 1 To WS_Count
If ws.Name = Targetfile.Worksheets(i).Range("N1").Value Then
Worksheets(ws.Name).Range(Cells(25, 3), Cells(25, 17)).Copy
Targetfile.Worksheets(i).Range("C23").PasteSpecial Paste:=xlPasteValues
End If
Next i
Next ws
End With
Targetfile.Close SaveChanges:=False
Application.AskToUpdateLinks = True
Application.AutomationSecurity = msoAutomationSecurityByUI
End Sub
Mit freundlichen Grüßen
Mario