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