Kopieren in eine andere Datei

[heli]

Hallo liebes Forum !

Ich bin am verzweifeln, da ich mich mit einem Problem schon die längste Zeit herumschlage, komme aber nicht dahinter woran es liegt.
Ich mochte einen Textblock von einer Datei ("C:\Ordner1\Quelldatei.xlsm") in eine andere ("C:\Ordner2\Zieldatei.xlsm") kopieren und das in alle 12 Tabellenblätter. Der Code steht in der Quelldatei.
Nun habe ich festgestellt, dass es mit meinem Code immer nur stückweise funktioniert. z.B. lief es immer um 1 Tabelle weiter wenn ich die Kopie in der Zieldatei wieder gelöscht habe und das Makro zum wiederholten mal startete.
Ich habe keine Ahnung woran das liegen könnte bin aber sicher, dass Ihr mit Eurem umfangreichen Wissen gleich dahinter kommt.
Bitte um Eure geschätzte Hilfe.

P.S: Ich habe soeben festgestellt, dass der Fehler bei einer leeren "Zieldatei" nicht auftritt, also muss es an meiner vorhandenen "Zieldatei" liegen., aber wo ??

Liebe Grüße aus Innsbruck
Helmut

Code:

Sub Schriftblock_Kopieren()

Application.ScreenUpdating = False

Dim i, strPathQuelle, strFileQuelle, strFile,  strPath, mappen, gefunden
   
   strPath = "C:\Ordner2\"
   strFile = Dir(strPath & "Zieldatei.xlsm")
   strPathQuelle = "C:\Ordner1\"
   strFileQuelle = "Quelldatei.xlsm"

Do While strFile <> ""
   
   For Each mappen In Workbooks
   If mappen.Name = strFile Then
   gefunden = True
   End If
Next
   If Not gefunden = True Then

   Workbooks.Open Filename:=strPath & strFile
   End If

Windows(strFileQuelle).Activate
   
   Sheets("Tabelle1").Select
   Range("G4:G11").Select
   Application.CutCopyMode = False
   Selection.Copy
   
Windows(strFile).Activate

For i = 1 To 12

   Sheets(i).Select
   Sheets(i).Unprotect ("mth")
 
   ActiveSheet.Range("O23").Select
   Selection.PasteSpecial Paste:=xlValues
Next i
   
   'ActiveWorkbook.Save
   'ActiveWorkbook.Close SaveChanges:=True
   
strFile = Dir()
   
   If strFile = "" Then
   MsgBox "Keine weiteren Dateien vorhanden !", vbExclamation, "Hinweis"
   End If
Loop
   
End Sub

[Kuwer]

Hallo Helmut,

nach Deiner Beschreibung sieht mein Code so aus:

Option Explicit



Sub Schriftblock_Kopieren()

 Dim i As Long

 Dim oWbZ As Workbook

 Dim varQ As Variant

 

 Application.ScreenUpdating = False

 varQ = ThisWorkbook.Worksheets("Tabelle1").Range("G4:G11").Value

 On Error Resume Next

 Set oWbZ = Workbooks("Zieldatei.xlsm")

 If oWbZ Is Nothing Then

   Set oWbZ = Workbooks.Open("C:\Ordner2\Zieldatei.xlsm")

 End If

 On Error GoTo 0

 If Not oWbZ Is Nothing Then

   For i = 1 To 12

     With oWbZ.Worksheets(i)

       .Unprotect "mth"

       .Range("O23").Resize(UBound(varQ, 1), UBound(varQ, 2)).Value = varQ

       .Protect "mth"

     End With

   Next i

   'oWbZ.Save

   oWbZ.Close SaveChanges:=True

 Else

   MsgBox "Die Datei ""C:\Ordner2\Zieldatei.xlsm"" gibt es nicht!"

 End If

 Application.ScreenUpdating = True

End Sub

Gruß Uwe

[heli]

Hallo Uwe !

Vielen Dank für Deine Hilfe, mit Deinem Code funktioniert es.

Liebe Grüße
Helmut

[atilla]

Hallo Helmut,

es konnte bei Dir nicht funktionieren, weil das Kopierte nach dem aufheben des Blattschutzes verloren geht.

Teste Deinen Code mal so, dass Du vorher den Schutz aus den Tabellen aufhebst und die Zeile mit dem Blattschutz auskommentierst.

Natürlich ist Uwes Code für Dein Anliegen optimal aber unten Dein Code mit kleinen Änderungen, wie er funktionieren kann.
Es wird da nicht mehr kopiert (bei Uwe auch nicht!) , sondern der Inhalt des zu kopierenden Bereichs wird in eine Variable geschrieben.
Nach öffnen der Zielmappe wird aus dieser Variablen der Inhalt wieder an die entsprechenden Bereiche eingetragen.

Wie gesagt, es soll Dir nur zum besseren Verständnis dienen warum es mit Deinem Code zu Problemen kam.

Änderungen sind rot hervorgehoben und der Code ist von mir nicht getestet.


Sub Schriftblock_Kopieren()

Application.ScreenUpdating = False
Dim varFeld As Variant
Dim i, strPathQuelle, strFileQuelle, strFile, strPath, mappen, gefunden
   
   strPath = "C:\Ordner2\"
   strFile = Dir(strPath & "Zieldatei.xlsm")
   strPathQuelle = "C:\Ordner1\"
   strFileQuelle = "Quelldatei.xlsm"

Do While strFile <> ""
   
   For Each mappen In Workbooks
   If mappen.Name = strFile Then
   gefunden = True
   End If
Next
   If Not gefunden = True Then

   Workbooks.Open Filename:=strPath & strFile
   End If

Windows(strFileQuelle).Activate
   
   Sheets("Tabelle1").Select
   varFeld = Range("G4:G11").Value
   
Windows(strFile).Activate

For i = 1 To 12

   Sheets(i).Select
   Sheets(i).Unprotect ("mth")
 
   ActiveSheet.Range("O23:Q30") = varFeld
Next i
   
   'ActiveWorkbook.Save
   'ActiveWorkbook.Close SaveChanges:=True
   
strFile = Dir()
   
   If strFile = "" Then
   MsgBox "Keine weiteren Dateien vorhanden !", vbExclamation, "Hinweis"
   End If
Loop
   
End

[heli]

Hallo Atilla !

Vielen Dank für Deine Hilfe. Jetzt weiß ich auch wieso es nicht funktionierte.

Liebe Grüße
Helmut