AW: Zellbereich mittels VBA kopieren?
21.08.2014 15:08:16
fcs
Hallo Christian,
nach folgend die eforderlichen Makros.
Wenn in "Recherche.xlsm" keine Makros enthalten sind, dann kann man die Datei auch ohne Makros speichern mit der Endung "xlsx".
Die Pfade und Namen der Dateien und die Namen der Tabellenblaätter im Code muss du noch anpassen.
Gruß
Franz
'Makro in einem allgemeinne Modul - z.B. in der Masterdatei
'Makro bei geöffneter/aktiver Masterdatei ausführen, z.B. bevor die Masterdatei _
geschlossen oder gespeichert wird.
Sub Recherche_Update()
'Recherche-Datei mit Daten aus Masterdatei aktualisieren
Dim wkbMaster As Workbook, wksMaster As Worksheet, Zeile_LM As Long
Dim wkbRecherche As Workbook, wksRecherche As Worksheet, Zeile_LR As Long
Dim StatusCalc As Long
If MsgBox("Recherche-Datei jetzt aktualisieren", _
vbQuestion + vbOKCancel, "Recherchedatei aktualisieren") _
= vbCancel Then Exit Sub
Set wkbMaster = ActiveWorkbook
Set wksMaster = wkbMaster.Worksheets("Kundenliste")
'Makrobremsen lösen
With Application
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set wkbRecherche = Application.Workbooks.Open(Filename:=wkbMaster.Path _
& Application.PathSeparator & "Recherche.xlsm")
Set wksRecherche = wkbRecherche.Worksheets("Kundenliste")
With wksRecherche
With .UsedRange
Zeile_LR = .Row + .Rows.Count - 1
End With
If Zeile_LR > 5 Then
'Altdaten löschen
With .Range(.Rows(6), .Rows(Zeile_LR))
.ClearContents
.ClearFormats
End With
End If
End With
With wksMaster
With .UsedRange
Zeile_LM = .Row + .Rows.Count - 1
End With
If Zeile_LR > 5 Then
'Daten kopieren nach Recherche
With .Range(.Rows(6), .Rows(Zeile_LM))
.Copy Destination:=wksRecherche.Cells(6, 1)
End With
End If
End With
wkbRecherche.Close savechanges:=True
'Makrobremsen zurücksetzen
With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
End With
End Sub
'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 = "Y:\Test\Recherche.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("Kundenliste")
'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("Kundenliste")
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