AW: Daten auslesen und einlesen
09.12.2007 04:59:43
fcs
Hallo Heike,
ich hab die beiden gewünschten Makrofunktionen jetzt in eine separate Steuerungsdatei eingebaut, die ich benutze um generelle Änderungen an Dateien durchzuführen. So muss du die Makros nicht in jeder Datei installieren für die eine Zusammenstellung erstellt und die Formeln eingefügt werden sollen.
Per Klick auf 2 Zellen kannst du die Datei mit den Detaildatentabellen und die Datei mit den SVERWEIS-Daten auswählen. Danach werden im unteren Bereich automatisch die Formeltexte für die beiden Formeln berechnet.
In Spalte A sind unten die Zellen aufgelistet, deren Inhalt in die Zusammenfassung übertragen werdne soll.
Zusätzlich kannst du wählen, ob die Zusammenfassung in einer separaten Datei oder in der Datendatei erstellt werrden soll. Das Ausehen der Zusammenfassung kannst in dem Musterblatt in der Steuerungsdatei einstellen.
https://www.herber.de/bbs/user/48328.xls
Falls du die Prozeduren für die Zusammenfassung lieber in der Datei mit den Detaildaten anlegen willst, um die Aktualisierung der Übersicht schneller durchführem zu können, dann mussen diese wie folgt aussehen. Diese Prozeduren fügen falls erforderlich ein neues Tabellenblatt ein und übertragen dann die Datem. Der komplette Code muss in ein Modul.
Bei der Prozedur zur Erzeugung der SVERWEIS-Funktionen macht es wenig Sinn diese in jede Datei einzubauen, da die die Formln ja nur einmal eingefügt werden müssen.
Gruß
Franz
'### Prozeduren zur Übertragung der Daten aus den Tabellen in ein Übersichtsblatt ###
Option Explicit
'Name des Blattes für die Zusammenfassung
Private Const strZusammen As String = "Zusammenfassung"
Sub Zusammenfassung()
Dim ZellAdressen, wbThis As Workbook, wks As Worksheet
'Prüfen ob Zusammenfassung schon vorhanden
Set wbThis = ThisWorkbook
For Each wks In wbThis.Worksheets
If wks.Name = strZusammen Then
Exit For
End If
Next
If wks Is Nothing Then
'Neues Blatt für Zusammenfassung anlegen
wbThis.Worksheets.Add before:=wbThis.Sheets(1)
Set wks = ActiveSheet
With wks
.Name = strZusammen
'Titelzeilen beschriften und Spalten formatieren
.Cells(2, 1).Value = "Schachtbezeichnung"
.Cells(2, 2).Value = "Summe Sanierung"
.Cells(2, 3).Value = "Summe Neu"
.Cells(2, 4).Value = "Tabellenname"
.Range(.Columns(1), .Columns(4)).AutoFit
.Cells(1, 1).Value = "Zusammenfassung Schachtdaten"
.Columns(1).NumberFormat = "@"
.Columns(2).NumberFormat = "#,###,###"
.Columns(3).NumberFormat = "#,###,###"
.Columns(4).NumberFormat = "@"
'Zeilen 1 und 2 im Fenster fixieren
.Range("A3").Select
ActiveWindow.FreezePanes = True
End With
End If
'Zellen derren Werte in die Übersicht übertragen werden sollen
ZellAdressen = Array("F1", "E26", "F26")
'Sub-Routine aufrufen
Call BlattAktualisieren(wbQuelle:=wbThis, wbZiel:=wbThis, _
Blattname:=strZusammen, ZeileZ1:=3, arrZellen:=ZellAdressen, _
bTabName:=True, bKopieren:=False)
End Sub
Sub BlattAktualisieren(wbQuelle As Workbook, wbZiel As Workbook, Blattname$, _
ZeileZ1 As Long, arrZellen, _
Optional bTabName As Boolean = False, Optional bKopieren As Boolean = False)
'Daten aus den anderen Tabellenblättern werden als Liste im Blatt eingetragen
'wbQuelle = Datei mit den Datentabellen
'wbZiel = Datei mit der Übersichtstabelle
'Blattname = Name der Übersichtstabelle
'ZeileZ1 = 1. Zeile mit Daten im Übersichtsblatt mit Daten
'arrZellen = Array mit den Adressen der Zellen, die ausgelesen werden sollen
'bTabname = Wenn True wird in jeder Zeile der Quellen-Tabellenname eingetragen
'bKopieren = Wenn True, dann werden die Werte per Kopieren in die Übersicht übertragen _
erforderlich, wenn z.B. Währungsformate in den Quellen verwendet werden.
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim ZeileZ As Long, iI As Integer
Set wksZiel = wbZiel.Worksheets(Blattname)
Application.ScreenUpdating = False
With wksZiel
'Alte Daten in der Liste löschen
If .Cells.SpecialCells(xlCellTypeLastCell).Row >= ZeileZ1 Then
.Range(.Cells(ZeileZ1, 1), .Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
End If
'Tabellenblätter auslesen
ZeileZ = ZeileZ1
For Each wksQuelle In wbQuelle.Worksheets
If Not (wksQuelle.Name = wksZiel.Name) Then
For iI = LBound(arrZellen) To UBound(arrZellen)
If bKopieren = True Then
'Werte Übertragen per Kopierfunktion (erforderlich bei betimmten Zellformaten)
wksQuelle.Range(arrZellen(iI)).Copy
.Cells(ZeileZ, iI + 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Else
'Werte Übertragen per direkter Wertzuweisung (geht schneller)
.Cells(ZeileZ, iI + 1) = wksQuelle.Range(arrZellen(iI)).Value
End If
Next iI
If bTabName = True Then
'Tabellennamen hinter Daten eintragen
.Cells(ZeileZ, UBound(arrZellen) + 2) = wksQuelle.Name
End If
ZeileZ = ZeileZ + 1
End If
Next wksQuelle
End With
Application.ScreenUpdating = True
End Sub