Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

RE: Formatierung automatisch übertragen

Betrifft: RE: Formatierung automatisch übertragen von: Schmitty
Geschrieben am: 03.09.2014 11:58:31

Hallo,

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
Jetzt ist aber das Ziel-Tabellenbaltt schreibgeschützt.
Um das zu umgehen, gibt es ja den Code
    ActiveSheet.Unprotect Password:=""
der hier aber leider nicht funktioniert.

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
Ist das Ziel-Tabellenbaltt nicht schreibgeschütz, läuft das Makro ohne Probleme.

Hat jemand eine Idee, wo der Haken in meinem Code ist?

Gruß
Christian

  

Betrifft: AW: RE: Formatierung automatisch übertragen von: Schmitty
Geschrieben am: 03.09.2014 13:06:56

Hallo,

Kommando zurück, habe den Fehler gerade gefunden!

Wenn es jemanden interessiert, hier die Lösung:

Mein Code steht ja unter "DieseArbeitsmape". Aus diesem Grund muss ich genau definieren, welchen Blattschutz ich deaktivieren möchte. Sprich, der richtige Code lautete in meinem Fall:

  ActiveWorkbook.Sheets("Blatt 1").Unprotect Password:=""
Gruß
Christian


 

Beiträge aus den Excel-Beispielen zum Thema "RE: Formatierung automatisch übertragen"