AW: Fortsetz. Formel in VBA umschreiben
29.08.2007 07:31:25
Beverly
Hi Rainer,
soll dann für jede Kostenstelle eine neue Spalte angelegt werden? Und wie ist das mit den Varianten?
Für 1 Kostenstelle (Zelle B5 aus Stammdaten) sollte der Code für die 1. Variante (Gesamtsumme) dann so lauten
Sub kostenstelle_feststellen_var1()
Dim raZelleMain As Range
Dim raZelleTab1 As Range
Dim loLetzteMain As Long
Dim loLetzteStamm As Long
Dim loLetzteTab1 As Long
Dim loZeileStamm As Long
Dim loZeileTab1 As Long
Dim inAnzahlKunden As Integer
Dim doSumme As Double
Dim doQuotient As Double
Dim strAdrTab1 As String
Dim wsMain As Worksheet
Dim wsTab1 As Worksheet
Set wsMain = Worksheets("Mainlist")
Set wsTab1 = Worksheets("Tabelle1")
loLetzteMain = IIf(IsEmpty(wsMain.Cells(wsMain.Rows.Count, 2)), wsMain.Cells(wsMain.Rows. _
Count, 2).End(xlUp).Row, wsMain.Rows.Count)
loLetzteTab1 = IIf(IsEmpty(wsTab1.Cells(wsTab1.Rows.Count, 2)), wsTab1.Cells(wsTab1.Rows. _
Count, 2).End(xlUp).Row, wsTab1.Rows.Count)
Application.ScreenUpdating = False
doSumme = Application.WorksheetFunction.Sum(wsTab1.Range("B2:B" & loLetzteTab1))
With Worksheets("Stammdaten")
loLetzteStamm = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp). _
Row, .Rows.Count)
Set raZelleMain = wsMain.Range("B2:B" & loLetzteMain).Find(.Cells(5, 2), lookat:=xlPart) _
For loZeileStamm = 5 To loLetzteStamm
If Not raZelleMain Is Nothing Then
If doSumme 0 Then
doQuotient = raZelleMain.Offset(0, 1) * 100 / doSumme
Else
doQuotient = 0
End If
For loZeileTab1 = 2 To loLetzteTab1
Set raZelleTab1 = wsTab1.Range("A1:A" & loLetzteTab1).Find(.Cells( _
loZeileStamm, 4), lookat:=xlWhole)
If Not raZelleTab1 Is Nothing Then
strAdrTab1 = raZelleTab1.Address
Do
raZelleTab1.Offset(0, 2) = doQuotient * raZelleTab1.Offset(0, 1)
Set raZelleTab1 = wsTab1.Range("A1:A" & loLetzteTab1).FindNext( _
raZelleTab1)
Loop While Not raZelleTab1 Is Nothing And raZelleTab1.Address _
strAdrTab1
End If
Next loZeileTab1
Else
MsgBox "Kostenstelle " & .Cells(loZeileStamm, 2) & " in Tabelle 'Mainlist' _
nicht gefunden"
End If
Next loZeileStamm
End With
Application.ScreenUpdating = True
End Sub
Für die 2. Variante wäre es dann derselbe Code, nur dass die Zeile für Summenbildung so aussehen müsste
doSumme = Application.WorksheetFunction.SumIf(wsTab1.Range("A2:A" & loLetzteTab1), "Print*", _
wsTab1.Range("B2:B" & loLetzteTab1))
Bis später,
Karin