RE: Formatierung automatisch übertragen
03.09.2014 11:58:31
Schmitty
ich hatte hier letzte Woche ein Thema aufgemacht und kann jetzt leider nicht darauf antworten. Deshalb mache ich hier noch mal ein Thema neu auf.
Ich möchte gerne Die Formatierung bestimmter Zellen von einer Ausgangsdatei in eine Zieldatei übernehmen.
Mit der Hilfe des Users FCS (oder Franz ;-)) habe ich auch einen passenden VBA-Code erhalten:
'Makros unter "DieseArbeitsmape" der lokalen Datei
Private Sub Workbook_Open()
Call Lokal_Update
End Sub
Private Sub Lokal_Update()
'Lokale Datei mit den Formatierungen aus der Recherche-Datei aktualisieren
Dim wkbLokal As Workbook, wksLokal As Worksheet, Zeile_LL As Long
Dim wkbRecherche As Workbook, wksRecherche As Worksheet, Zeile_LR As Long
Dim strRecherche As String
Dim StatusCalc As Long
'Pfad\Dateiname der Recherchedatei
strRecherche = "Z:\Kartei\Adressen.xlsm"
'Prüfen ob Recherche-Datei vorhanden
If Dir(strRecherche) = "" Then
MsgBox "Recherche-Datei """ & strRecherche & """ nicht gefunden!", _
vbOKOnly, "Recherche-Datei suchen"
End If
Application.StatusBar = "Formatierung wird mit Recherchedatei abgeglichen"
Set wkbLokal = ThisWorkbook
Set wksLokal = wkbLokal.Worksheets("Schmitz GmbH")
'Makrobremsen lösen
With Application
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Recherche-Datei schreibgeschützt öffnen
Set wkbRecherche = Application.Workbooks.Open(strRecherche, ReadOnly:=True, UpdateLinks:= _
False)
Set wksRecherche = wkbRecherche.Worksheets("Schmitz GmbH")
With wksLokal
With .UsedRange
Zeile_LL = .Row + .Rows.Count - 1
End With
If Zeile_LL > 5 Then
'alte Formatierungen löschen
With .Range(.Rows(6), .Rows(Zeile_LL))
.ClearFormats
End With
End If
End With
With wksRecherche
With .UsedRange
Zeile_LR = .Row + .Rows.Count - 1
End With
If Zeile_LR > 5 Then
With .Range(.Rows(6), .Rows(Zeile_LR))
.Copy
wksLokal.Cells(6, 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With
End If
End With
wkbRecherche.Close savechanges:=False
Range("A6").Select
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
End With
Application.StatusBar = False
End Sub
Um das zu umgehen, gibt es ja den Code
ActiveSheet.Unprotect Password:=""
So sieht im Moment mein Code aus:
'Makros unter "DieseArbeitsmape" der lokalen Datei
Private Sub Workbook_Open()
ActiveSheet.Unprotect Password:=""
Call Lokal_Update
End Sub
Private Sub Lokal_Update()
ActiveSheet.Unprotect Password:=""
'Lokale Datei mit den Formatierungen aus der Recherche-Datei aktualisieren
Dim wkbLokal As Workbook, wksLokal As Worksheet, Zeile_LL As Long
Dim wkbRecherche As Workbook, wksRecherche As Worksheet, Zeile_LR As Long
Dim strRecherche As String
Dim StatusCalc As Long
'Pfad\Dateiname der Recherchedatei
strRecherche = "Z:\Kartei\Adressen.xlsm"
'Prüfen ob Recherche-Datei vorhanden
If Dir(strRecherche) = "" Then
MsgBox "Recherche-Datei """ & strRecherche & """ nicht gefunden!", _
vbOKOnly, "Recherche-Datei suchen"
End If
Application.StatusBar = "Formatierung wird mit Recherchedatei abgeglichen"
Set wkbLokal = ThisWorkbook
Set wksLokal = wkbLokal.Worksheets("Schmitz GmbH")
'Makrobremsen lösen
With Application
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Recherche-Datei schreibgeschützt öffnen
Set wkbRecherche = Application.Workbooks.Open(strRecherche, ReadOnly:=True, UpdateLinks:= _
False)
Set wksRecherche = wkbRecherche.Worksheets("Schmitz GmbH")
With wksLokal
With .UsedRange
Zeile_LL = .Row + .Rows.Count - 1
End With
If Zeile_LL > 5 Then
'alte Formatierungen löschen
With .Range(.Rows(6), .Rows(Zeile_LL))
.ClearFormats
End With
End If
End With
With wksRecherche
With .UsedRange
Zeile_LR = .Row + .Rows.Count - 1
End With
If Zeile_LR > 5 Then
With .Range(.Rows(6), .Rows(Zeile_LR))
.Copy
wksLokal.Cells(6, 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With
End If
End With
wkbRecherche.Close savechanges:=False
Range("A6").Select
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
End With
Application.StatusBar = False
End Sub
Hat jemand eine Idee, wo der Haken in meinem Code ist?
Gruß
Christian