AW: Zeilen auserten, kopieren und automatisch generier
23.03.2013 19:12:20
fcs
Hallo Mike,
die folgenden Makros fügst du im VBA-Editor unter dem Tabellenblatt "Ergebnis" ein.
Immer wenn das Blatt Ergebnis selektiert wird, dann wird per Makro die Daten in das Blatt Ergebnis neu übertragen. Voraussetzung ist natürlich, dass die Makros beim Öffnen der Datei aktiviert werden.
Gruß
Franz
'Code im VBA-Editor unter Tabelle "Ergebnis"
Private Sub Worksheet_Activate()
Call UpdateErgebnis
End Sub
Sub UpdateErgebnis()
Dim wksAllg As Worksheet, wksTab As Worksheet, wksErgebnis As Worksheet
Dim ZeilePos As Long, ZeileTab As Long, ZeileErg As Long, AnzTab As Long
Dim ZellePos As Range
Dim varPos As Variant
On Error GoTo Fehler
Set wksAllg = Worksheets("Allgemein")
Set wksErgebnis = Worksheets("Ergebnis")
Application.ScreenUpdating = False
With wksErgebnis
'vorhandene Inhalte im Ergebnisblatt ab Zeile 4 löschen
ZeileErg = .Cells(.Rows.Count, 2).End(xlUp).Row
If ZeileErg >= 4 Then
.Range(.Rows(4), .Rows(ZeileErg)).Clear
End If
ZeileErg = 3 'Zeile unterhalb der Werte eingetragen werden sollen
End With
With wksAllg
'Positionen in Tabelle Allgemein abarbeiten
For ZeilePos = 6 To .Cells(.Rows.Count, 3).End(xlUp).Row
If .Cells(ZeilePos, 3) "" Then
varPos = .Cells(ZeilePos, 3).Value
With wksErgebnis
ZeileErg = ZeileErg + 1
.Cells(ZeileErg, 2) = "Position"
.Cells(ZeileErg, 3) = varPos
ZeileErg = ZeileErg + 1
.Cells(ZeileErg, 4) = "Preis"
.Cells(ZeileErg, 5) = "Guthaben"
End With
AnzTab = 0 'Tabellenzähler zurücksetzen
'Daten in den Tabellenblättern auswerten
For ZeileTab = 6 To .Cells(.Rows.Count, 6).End(xlUp).Row
ZeileErg = ZeileErg + 1
'Tabellenname eintragen
wksErgebnis.Cells(ZeileErg, 2) = .Cells(ZeileTab, 6).Text
AnzTab = AnzTab + 1
Set wksTab = Worksheets(.Cells(ZeileTab, 6).Text)
With wksTab
'Positionsnummer in Spalte B im Tabellenblatt suchen
With .Range(.Cells(9, 2), .Cells(.Rows.Count, 2).End(xlUp))
Set ZellePos = .Find(what:=varPos, LookIn:=xlValues, lookat:=xlWhole)
End With
If ZellePos Is Nothing Then
'Positionsnummer in Tabellenblatt nicht gefunden
Else
'Daten zu Position in Ergebnis übertragen
wksErgebnis.Cells(ZeileErg, 4) = .Cells(ZellePos.Row, 4).Value 'Preis
wksErgebnis.Cells(ZeileErg, 5) = .Cells(ZellePos.Row, 5).Value 'Guthaben
End If
End With
NextWksTab:
Next ZeileTab
'Summenzeile eintragen inkl. Formeln
ZeileErg = ZeileErg + 1
With wksErgebnis
.Cells(ZeileErg, 2).Value = "Summe"
.Cells(ZeileErg, 4).FormulaR1C1 = "=SUM(R[-" & AnzTab & "]C:R[-1]C)"
.Cells(ZeileErg, 5).FormulaR1C1 = "=SUM(R[-" & AnzTab & "]C:R[-1]C)"
End With
ZeileErg = ZeileErg + 3 'Leerzeilen nach Summenzeile
End If
Next ZeilePos
End With
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 9 'Index-Fehler - Tabelle mit Name nicht vorhanden
Resume NextWksTab
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Application.ScreenUpdating = True
Set wksTab = Nothing: Set wksErgebnis = Nothing: Set wksAllg = Nothing
Set ZellePos = Nothing
End Sub