Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1108to1112
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro und Formatierung

Makro und Formatierung
udo
Hallo, ich wäre sehr dankbar wenn ihr mir helfen könntet.
Ich muss mehrere Aufgabenlisten in einer Gesamtübersicht zusammenführen. Die Listen sind gleich aufgebaut. Nun habe ich ein Makro gefunde, welches auch eigentlich gut funktioniert.
Das Problem ist nur, dass das Makro die Formatierung der Datenquellen übernimmt und ich diese Gesamtübersich gerne selbst formatieren würde. Sodass sich nur die Daten aktualisieren aber das Aussehen immer gleich bleibt.
Der Code ist folgender:
Option Explicit
Const HomeDatei = "LeereArbeitsmappe.xls"              'Name Arbeitsmappe Makro-Excel-Datei
Const HomeDaten = "Import-Daten"          'Name Tabellenblatt Daten-Import
Const HomeListe = "Datei-Liste"           'Name Tabellenblatt Datei-Liste
Const HomeZeile = 3                       'Erste Zeile Einfügen
Const CopyZeile = 3                       'Erste Zeile Kopieren
Const ListDatei = "A1"                    'Zelle erster Dateiname
Const ErrMsg = "Abbruch! Datei existiert nicht: "
Sub SheetsImport()
Dim WksHome As Worksheet, WksList As Worksheet, EndLine As Integer, NextLine As Integer
Dim WkbCopy As Workbook, WksCopy As Worksheet, Fso As Object, File As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set WksHome = Workbooks(HomeDatei).Sheets(HomeDaten)
Set WksList = Workbooks(HomeDatei).Sheets(HomeListe)
EndLine = GetEndLine(WksHome):  NextLine = HomeZeile
If EndLine >= HomeZeile Then WksHome.Rows("3:" & EndLine).Cells.Clear
Application.ScreenUpdating = False
For Each File In WksList.Range(ListDatei).CurrentRegion
If Fso.FileExists(File) = False Then
Application.ScreenUpdating = True
MsgBox ErrMsg & File, vbExclamation, "Fehler":  Exit Sub
End If
Set WkbCopy = Workbooks.Open(File):  Set WksCopy = WkbCopy.Sheets(1)
EndLine = GetEndLine(WksCopy)
If EndLine >= CopyZeile Then
WksCopy.Rows("3:" & EndLine).Copy
WksHome.Rows(NextLine).Insert Shift:=xlDown
Application.CutCopyMode = False
WkbCopy.Saved = True:  WkbCopy.Close
NextLine = GetEndLine(WksHome) + 1
End If
Next
Application.ScreenUpdating = True
Cells.Clearformats
End Sub
Private Function GetEndLine(ByRef Wks) As Integer
GetEndLine = Wks.Cells(Wks.Rows.Count, "A").End(xlUp).Row
End Function
Wie man sehen kann, habe ich die Zeile Cells.Clearformats selbst hinzugefügt. Sie bewirkt aber, dass das Format meiner Gesamtübersicht jedes mal komplett gelöscht wird. Also perfekt wäre es, wenn er wirklich nur die Werte kopieren würde und ich in meiner Gesamtübersicht die Zahlenformate und Farben in einer Spalte vor formatieren könnte.
Hoffe ist einigermassen verständlich. Danke schonmal.

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
Zuweisung statt Copy
22.10.2009 12:14:08
Erich
Hi Udo,
probier mal (ungetestet):

Option Explicit
Const HomeDatei = "LeereArbeitsmappe.xls"              'Name Arbeitsmappe Makro-Excel-Datei
Const HomeDaten = "Import-Daten"          'Name Tabellenblatt Daten-Import
Const HomeListe = "Datei-Liste"           'Name Tabellenblatt Datei-Liste
Const HomeZeile = 3                       'Erste Zeile Einfügen
Const CopyZeile = 3                       'Erste Zeile Kopieren
Const ListDatei = "A1"                    'Zelle erster Dateiname
Const ErrMsg = "Abbruch! Datei existiert nicht: "
Sub SheetsImport()
Dim WksHome As Worksheet, WksList As Worksheet, EndLine As Long, NextLine As Long
Dim WkbCopy As Workbook, WksCopy As Worksheet, Fso As Object, rngFile As Range
Dim lngAnzZ As Long, lngAnzS As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
Set WksHome = Workbooks(HomeDatei).Sheets(HomeDaten)
Set WksList = Workbooks(HomeDatei).Sheets(HomeListe)
EndLine = GetEndLine(WksHome)
NextLine = HomeZeile
If EndLine >= HomeZeile Then WksHome.Rows("3:" & EndLine).Clear
'    Application.ScreenUpdating = False  ' NACH dem Test aktivieren
For Each rngFile In WksList.Range(ListDatei).CurrentRegion
If Fso.FileExists(rngFile) = False Then
Application.ScreenUpdating = True
MsgBox ErrMsg & rngFile, vbExclamation, "Fehler":  Exit Sub
End If
Set WkbCopy = Workbooks.Open(rngFile)
Set WksCopy = WkbCopy.Sheets(1)
EndLine = GetEndLine(WksCopy)
If EndLine >= CopyZeile Then
lngAnzZ = EndLine - CopyZeile + 1       ' Anzahl zu kopierender Zeilen
lngAnzS = WksCopy.Columns.Count         ' alle Spalten werden kopiert
WksHome.Cells(NextLine, 1).Resize(lngAnzZ, lngAnzS) = _
WksCopy.Cells(CopyZeile, 1).Resize(lngAnzZ, lngAnzS).Value
WkbCopy.Close SaveChanges:=False
NextLine = NextLine + lngAnzZ + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Private Function GetEndLine(ByRef Wks) As Long
GetEndLine = Wks.Cells(Wks.Rows.Count, 1).End(xlUp).Row
End Function
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige
AW: Zuweisung statt Copy
22.10.2009 12:38:05
udo
Hallo, danke das ging schnell. Funktioniert so wie mein erste Code die Formate werden leider immer noch gelöscht.
AW: Zuweisung statt Copy
22.10.2009 12:41:31
udo
Also wenn ich das Makro das erste mal auf einem leeren Blatt ausführe bleibt die Formatierung, wenn ich es jedoch nochmal starte (um die Daten zu aktualisieren) wirds gelöscht.
Formate werden nicht geändert
22.10.2009 13:09:04
Erich
Hi Udo,
das kann ich nicht glauben.
Der Code, den ich gepostet habe, ändert nichts an irgend welchen Formaten - er bewegt nur Werte.
Arbeitest du (in der Zieltabelle) vielleicht mit bedingter Formatierung?
Dann hätten die Werte Einfluss auf das Format.
Den Satz "wenn ich das Makro das erste mal auf einem leeren Blatt ausführe bleibt die Formatierung"
verstehe ich nicht. Welche Formatierung bleibt da? Hast du das leere Blatt vorher formatiert?
Ebenso verstehe ich nicht:
"wenn ich es jedoch nochmal starte (um die Daten zu aktualisieren) wirds gelöscht"
Was heißt "wirds gelöscht"? Ist das Format nachher überall "Standard"?
Das ließe vermuten, dass du irgendwo die Methode ClearFormats aufrufst.
In meinem Code steht das nicht.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige
AW: Formate werden nicht geändert
22.10.2009 13:20:29
udo
Hallo,
Danke für deine Hilfe, sorry hab mich glaube ich nicht genau ausgedrückt.
Also führe das Makro (so wie es oben von dir steht und als Modul eingefügt) aus dann füllt sich das Tabellenblatt mit den Werten. Ich Färbe dann die erste Spalte gelb die zweite Spalte grün. Führe ich das Makro erneut aus, sodass er nochmal die Daten aus den beiden Listen holt und in meine Gesamtübersicht hineinkopiert, sind die Farben weg. Alles ist wieder weiß.
Lösche ich nun alle Werte in der Gesamtübersicht, färbe die erste Spalte geld und führe das Makro aus, ist die Spalte nach wie vor gelb. Führe ich das Makro erneut aus ist wieder alles weiß.
Anzeige
Formate wurden doch gelöscht
22.10.2009 16:04:09
Erich
Hi Udo,
sorry, da habe ich etwas übersehen! Ziemlich vorn in der Prozedur stand:
WksHome.Rows("3:" & EndLine).Clear
Clear habe ich in ClearContents geändert - dann bleiben die Formate bestehen.
Daneben habe ich hoch ein paar Kleinigkeiten ergänzt/geändert. Z. B. steht
WkbCopy.Close SaveChanges:=False
jetzt nach dem End If - damit auch dann geschlossen wird, wenn keine Zeilen zu kopieren sind.
Probier mal

Sub SheetsImport()
Dim WksHome As Worksheet, WksList As Worksheet, EndLine As Long, NextLine As Long
Dim WkbCopy As Workbook, WksCopy As Worksheet, Fso As Object, rngFile As Range
Dim lngAnzZ As Long, lngAnzS As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
Set WksHome = Workbooks(HomeDatei).Sheets(HomeDaten)
Set WksList = Workbooks(HomeDatei).Sheets(HomeListe)
EndLine = GetEndLine(WksHome)
NextLine = HomeZeile
If EndLine >= HomeZeile Then WksHome.Rows("3:" & EndLine).ClearContents
'    Application.ScreenUpdating = False  ' NACH dem Test aktivieren
Application.EnableEvents = False
For Each rngFile In WksList.Range(ListDatei).CurrentRegion
If Fso.FileExists(rngFile) = False Then
Application.ScreenUpdating = True
MsgBox ErrMsg & rngFile, vbExclamation, "Fehler":  Exit Sub
End If
Set WkbCopy = Workbooks.Open(rngFile, False, True)
Set WksCopy = WkbCopy.Sheets(1)
EndLine = GetEndLine(WksCopy)
If EndLine >= CopyZeile Then
lngAnzZ = EndLine - CopyZeile + 1       ' Anzahl zu kopierender Zeilen
lngAnzS = WksCopy.Columns.Count         ' alle Spalten werden kopiert
WksHome.Cells(NextLine, 1).Resize(lngAnzZ, lngAnzS) = _
WksCopy.Cells(CopyZeile, 1).Resize(lngAnzZ, lngAnzS).Value
NextLine = NextLine + lngAnzZ
End If
WkbCopy.Close SaveChanges:=False
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige
AW: Formate wurden doch gelöscht
23.10.2009 09:19:24
udo
Hallo, nochmal vielen Dank für deine Mühe.
Ich bekomme beim Ausführen des Makros jetzt ein Fehler: "Sub oder Funktion nicht definiert". Und GetEndLine ist blau markiert. Mache ich etwas falsch?
zuviel gelöscht?
23.10.2009 09:53:52
Erich
Hi Udo,
vermutlich hast du beim Auswechseln des Makros SheetsImport die dreizeilige Funktion GetEndLine
versehentlich gelöscht.
Ich hatte diese Fkt. nicht noch einmal mit gepostet, weil daran ja nichts zu ändern war.
Sie steht ja auch schon zweimal weiter oben in diesem Thread.
Kopier die drei Zeilen einfach wieder unter "End Sub" unter das Makro - dann sollte es laufen.
Verwende dabei besser meine Version der Fkt - mit Long statt Integer.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige
AW: zuviel gelöscht?
23.10.2009 10:10:55
udo
Aaah funktioniert super, Danke nochmal!

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige