AW: Summieren von Tabellenzeilen
22.10.2008 08:46:36
Tabellenzeilen
Hallo David,
grundsätzlich ok, aber ich habe ja trotzdem noch die Thematik, daß ich die Tage dann immer manuell angeben muß. Ich habe mal den Code angehängt, vielleicht wird es dann klarer. Ich lasse heute mit einem Makro eine Datei auslesen, die mir verschiedene Werte für einen Mitarbeiter importiert, andere werden manuell dazu geschrieben und das für jeden tag. In dem Tabellenblatt Summe wird der gesamte Monat dargestellt, allerdings nur als Einzelwert, so daß ich eine Entwicklung des Mitarbeiters über die einzelnen Monatstage nicht verfolgen kann. Das war die Frage, ob ich unterhalb der Summenzeile jedes Mitarbeiters auch noch die Einzelzeilen darstellen kann.
Sry wegen dem Nicknamen, ich bin hier nicht so oft.
Rainer
ption Explicit
Public i_Zeile, i_Spalte As Integer
Public s_Spalte As String
Private Sub f_Tabellensuche(s_Tabelle, b_Kontrolle)
Dim Wb As Workbook
Dim b As Byte
Set Wb = ActiveWorkbook
For b = 1 To Wb.Sheets.Count
If s_Tabelle = Wb.Sheets(b).Name Then
b_Kontrolle = True
GoTo Ende
Else
b_Kontrolle = False
End If
Next b
Ende:
End Sub
Private Sub f_Tabellenkopie(s_Tabellevon, s_Tabellenach, s_NeuerName) 'Kopie der _
Tagesvorlage machen
Worksheets(s_Tabellevon).Visible = True 'Die Volage einblenden
Worksheets(s_Tabellevon).Copy After:=Worksheets(1) 'Die Vorlage kopieren
Worksheets(s_Tabellevon).Visible = False ' Die vorlage wieder _
ausblenden
ActiveSheet.Name = s_NeuerName
Worksheets(s_NeuerName).Tab.ColorIndex = 35
End Sub
Private Sub f_Datumsstring(b_Tag, s_allg_Tab)
Dim s_Tabelle, s_Tag, s_Monat, s_Jahr As String
If b_Tag
Private Sub f_Filterabfrage(s_Tabellevon, s_Tabellenach)
Worksheets(s_Tabellevon).Activate
If ActiveSheet.AutoFilterMode Then Selection.AutoFilter
Worksheets(s_Tabellenach).Activate
End Sub
Private Sub Zellensuche(s_Quelltabelle, s_Suchbereich, SucheWert)
Dim o_Suche As Object
Dim s_Suche, s_Spalte_A, s_Spalte_B As String
Dim b_Länge, b_Suche As Byte
Dim s_Zellenadresse As String
s_Zellenadresse = ""
b_Suche = 0
'In der Quelltabelle nach Überschrift 'Suchwort' suchen
With Worksheets(s_Quelltabelle).Range(s_Suchbereich)
Set o_Suche = .Find(SucheWert, LookIn:=xlValues) 'Find(Wert der gesucht wird, ?)
If o_Suche Is Nothing Then Set o_Suche = .Find(SucheWert, LookIn:=xlFormulas) 'Find( _
Wert der gesucht wird, ?)
If Not o_Suche Is Nothing Then 'wenn Suche nicht leer ist
If o_Suche = SucheWert Then
s_Zellenadresse = o_Suche.Address
'Else
' Do
' Set o_Suche = .FindNext(o_Suche)
' s_Zellenadresse = o_Suche.Address
' Loop While Not o_Suche = SucheWert
End If
End If
End With
If s_Zellenadresse "" Then
b_Länge = Len(s_Zellenadresse)
s_Spalte = Right(s_Zellenadresse, b_Länge - 1)
b_Suche = InStr(s_Spalte, "$")
i_Zeile = Right(s_Spalte, b_Länge - 1 - b_Suche)
i_Zeile = i_Zeile * 1
s_Spalte = Left(s_Spalte, b_Suche - 1)
b_Länge = Len(s_Spalte)
If b_Länge = 2 Then
s_Spalte_A = Left(s_Spalte, 1)
s_Spalte_B = Right(s_Spalte, 1)
i_Spalte = (Asc(s_Spalte_A) - 64) * 26 + Asc(s_Spalte_B) - 64
i_Spalte = i_Spalte * 1
Else
i_Spalte = Asc(s_Spalte) - 64
End If
Else
i_Zeile = 0
i_Spalte = 0
s_Spalte = ""
End If
End Sub
Sub Monatsbericht()
Const c_Tage As Byte = 31
Dim b_Kontrolle As Boolean
Dim b_Tag, b_Spalte As Byte
Dim i, i_Zeilenach, i_Zeilevon, i_Nummer As Integer
Dim s_Tabellevon, s_Tabellenach, s_NeuerName, s_allg_Tab As String
Dim Zwischenwert, Wert As Double
b_Kontrolle = True
s_Tabellevon = "Vorlage Monat"
s_Tabellenach = "Database"
s_NeuerName = Range("Monatsname")
i_Zeilenach = 15 'Startzeile zum schreiben in die Zieltabelle
b_Spalte = 1 'Startspalte zum auslesen in der Quelltabelle
Call f_Tabellensuche(s_NeuerName, b_Kontrolle)
If b_Kontrolle Then
MsgBox "Für diesem Monat ist schon ein Bericht vorhanden! Diesen bitte erst löschen."
Else
Call f_Tabellenkopie(s_Tabellevon, s_Tabellenach, s_NeuerName)
s_Tabellenach = s_NeuerName
Worksheets(s_NeuerName).Range("B11") = _
Worksheets("Database").Range("Monatsname") & " " & Worksheets("Database").Range("Jahr4")
For b_Tag = 1 To c_Tage
s_allg_Tab = ""
i_Zeilevon = 15 'Startzeile zum auslesen in der Quelltabelle
Call f_Datumsstring(b_Tag, s_allg_Tab)
s_Tabellevon = s_allg_Tab
Worksheets(s_NeuerName).Range("B10") = "ist bei " & s_Tabellevon
Call f_Tabellensuche(s_Tabellevon, b_Kontrolle)
If b_Kontrolle Then
Worksheets(s_Tabellevon).Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
Call f_Filterabfrage(s_Tabellevon, s_Tabellenach) 'Filter ist in Zeile 14
Do While Worksheets(s_Tabellevon).Cells(i_Zeilevon, 1) ""
i_Nummer = Worksheets(s_Tabellevon).Cells(i_Zeilevon, 1)
Call Zellensuche(s_Tabellenach, "A:A", i_Nummer)
If i_Zeile = 0 Then 'Der Agenten wurde nicht gefunden.
'Agent wird neu in den Monatsbericht aufgenommen.
'kopieren der Vorlage ans Ende.
For i = 0 To 3
Worksheets(s_Tabellenach).Cells(i_Zeilenach, b_Spalte + i) = _
Worksheets(s_Tabellevon).Cells(i_Zeilevon, b_Spalte + i)
Next i
For i = 4 To 21
Zwischenwert = Worksheets(s_Tabellevon).Cells(i_Zeilevon, b_Spalte + i)
If Zwischenwert = "" Then Zwischenwert = 0
Worksheets(s_Tabellenach).Cells(i_Zeilenach, b_Spalte + i) = Zwischenwert
Next i
i_Zeilenach = i_Zeilenach + 1
Rows(i_Zeilenach).Insert Shift:=xlDown
'---------------------------------------
Else
'Der Agent wird in der Monatsliste schon gefunden
For i = 4 To 17
Zwischenwert = Worksheets(s_Tabellevon).Cells(i_Zeilevon, b_Spalte + i)
Wert = Worksheets(s_Tabellenach).Cells(i_Zeile, b_Spalte + i)
If Zwischenwert = "" Then Zwischenwert = 0
Worksheets(s_Tabellenach).Cells(i_Zeile, b_Spalte + i) = _
Zwischenwert + Wert
Next i
End If
i_Zeilevon = i_Zeilevon + 1
Loop
End If
Next b_Tag
End If
Range("P13:W13").AutoFill Destination:=Range("P13:W" & i_Zeilenach - 1), Type:=xlFillDefault
Rows(14).Clear
Worksheets(s_NeuerName).Range("B10").Clear
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
End Sub