AW: variable Range
18.07.2018 16:02:50
fcs
Hallo Linda,
das Problem sind wahrscheinlich verbundene Zellen.
Ich hatte mich auch mit deinem Problem beschäfftigt.
Außer den Zellen in der Liste werden auch die Namen Der Dateien Alt/NEU) und der Tabellenblätter aus dem Blatt mit der Liste der Zelladressen ausgelesen - so muss mam im Code nichts ändern, wenn sich Namen ändern. Wenn die größe der verbundene Zellbereiche in Alt und Neu identisch ist sollte meine Lösung funktionieren.
Gruß
Franz
'Makro in einem allgeneinen Modul
'Beim Start der Makros musss das Blatt mit Zellen-Liste das aktive Blatt sein!
Sub prcDaten_von_ALT_nach_NEU()
'Überträgt die Inhalte der Zellen gemäß Liste in eine andere Mappe
Dim wkbAlt As Workbook, wkbNeu As Workbook
Dim wksAlt As Worksheet, wksNeu As Worksheet
Dim wksSteuerung As Worksheet
Dim arrZellen, intZ As Integer
Set wksSteuerung = ActiveSheet 'Blatt in 3. Datei mit Liste der Zellen
With wksSteuerung
' Werte für Datei- und Blattnamen aus Zelleneinlesen
Set wkbAlt = Application.Workbooks(.Range("G2").Text) 'ALte Datei
Set wksAlt = wkbAlt.Worksheets(.Range("F2").Text) 'altes Blatt
Set wkbNeu = Application.Workbooks(.Range("G4").Text) 'neue Datei
Set wksNeu = wkbNeu.Worksheets(.Range("F4").Text) 'neues Blatt
If MsgBox("Daten übertragen von: " & wkbAlt.Name & "!" & wksAlt.Name & vbLf & vbLf _
& "nach: " & wkbNeu.Name & "!" & wksNeu.Name, vbOKCancel, _
"D A T E N Ü B E R T R A G E N von ALT nach NEU") = vbCancel Then Exit Sub
'Zellenliste in Array übernehmen
arrZellen = .Range(.Cells(2, 2), .Cells(.Rows.Count, 3).End(xlUp))
End With
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
For intZ = LBound(arrZellen, 1) To UBound(arrZellen, 1)
'nur die Inhalte/Werte der Zellen von ALT nach NEU übertragen
' wksNeu.Range(arrZellen(intZ, 2)) = wksAlt.Range(arrZellen(intZ, 1))
'Zellen von ALT nach NEU kopieren Werte/Formeln/Formate
'kann Probleme bei Formeln bereiten (Zellbezüge) und verbundenen Zellen
With wksAlt.Range(arrZellen(intZ, 1))
If .MergeCells = True Then
.MergeArea.Copy wksNeu.Range(arrZellen(intZ, 2)).Resize(.MergeArea.Rows.Count, _
.MergeArea.Columns.Count)
Else
.Copy wksNeu.Range(arrZellen(intZ, 2))
End If
End With
Next
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
wkbNeu.Activate
MsgBox "Fertig"
End Sub