Das untenstehende Makro wurde mir vor ein paar Tagen von Tino zur Verfügung gestellt.
(Ein paar kleine Abänderungen wurden von mir vorgenommen.) Leider bringt es nicht den gewünschten Erfolg. Es läuft ohne Fehlermeldung durch -> d. h. es öffnet die Quelltabelle, hebt Blattschutz in der Quelltabelle auf, verweilt in der Quelltabelle und springt am Schluss wieder in die Zieltabelle zurück. Die eigentliche Aufgabe = Daten aus Quelltabelle kopieren und in Zieltabelle einfügen wird jedoch nicht ausgeführt. Ich konnte mit meinen VBA-Kenntnissen den Fehler leider nicht finden. Hat jemand von Euch eine Idee?
Sub Werte_importieren2()
'Start des Makros erfolgt aus der Zieltabelle
Tabelle1.Range("AM3").Value = 1
Dim Pfad_lokal As String
Dim wbZiel As Workbook, wsZiel As Worksheet
Dim wbQuelle As Workbook, wsQuelle As Worksheet, rngQuelle As Range
Dim nRQ&, nRZ&
Pfad_lokal = Range("AE5")
Set wsZiel = Tabelle1
Set wbQuelle = Workbooks.Open(Pfad_lokal)
Set wsQuelle = wbQuelle.Worksheets("Journal")
Sheets("Journal").Unprotect [KW]
For Each wsQuelle In wbQuelle.Worksheets
If wsQuelle.Name = "Journal" Then Exit For
Next wsQuelle
If Not wsQuelle Is Nothing Then
With wsQuelle
For nRQ = 204 To 12 Step -8
nRZ = wsZiel.Cells(wsZiel.Rows.Count, 3).End(xlUp).Row + 1
For Each rngQuelle In Union(.Cells(nRQ, 3), .Cells(nRQ, 9), .Cells(nRQ, 10))
'nur Werte
wsZiel.Cells(nRZ, rngQuelle.Column).Value = rngQuelle.Value
' 'kopieren mit Formel
' rngQuelle.Copy wsZiel.Cells(nRZ, rngQuelle.Column)
Next rngQuelle
Next nRQ
End With
Else
MsgBox "Journal nicht als Objektname gefunden!"
End If
'wbQuelle.Close SaveChanges:=False
Windows("Test.xlsm").Activate
Tabelle1.Cells(15, 3).Select
End Sub
Vielen Dank im VorausAlbert