AW: summe mit VBA
22.04.2007 15:32:00
Dan
Hallo,
andere Moeglichkeit hier.
Man muss/kann dabei volgende Konstanten setzen:
Private Const TESTED_COLLUMN As String = "B" ... Column mit den test-Texts
Private Const SUMMED_COLLUMN As String = "F" ... Column mit den Daten fuer die SUMA
Private Const RESULT_COLLUMN As Long = 10 ... Column wo die Formel geschrieben wird
Private Const HEADER_ROWS_COUNT As Long = 1 ... Anzahl der Kopf-Zeilen, die ignoriert werden sollen
Private Const TESTED_TEXT As String = "DEV" ... der gesuchte Teil des Textes, z.B hier werden alle Zellen mit 'DEV' drinn gefunden
Das Ergebnis : in die Spalte SUMMED_COLLUMN wird die SUMMA-Formel geschrieben.
Hier der Code. Der Code sollte in ein Standart module kopiert werden. Gruss Dan, cz.
---------------------------------------------------------------------------------------------------------------------------------------
Option Explicit
Private Const TESTED_COLLUMN As String = "B"
Private Const SUMMED_COLLUMN As String = "F"
Private Const RESULT_COLLUMN As Long = 10
Private Const HEADER_ROWS_COUNT As Long = 1
Private Const TESTED_TEXT As String = "DEV"
Public Sub SumWithTest()
Dim foundOnRows()
Dim testedCells As Range
Dim testedCell As Range
Dim testedTextFoundCount As Integer
Dim someWereFound As Boolean
Dim i As Long
On Error GoTo Err_SumCompience
' set the range, where the tested text are located
Set testedCells = Application.Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns( _
TESTED_COLLUMN))
Set testedCells = testedCells.Resize(testedCells.Rows.Count - HEADER_ROWS_COUNT, _
testedCells.Columns.Count)
Set testedCells = testedCells.Offset(HEADER_ROWS_COUNT, 0)
testedTextFoundCount = 0
someWereFound = False
' find the tested texts and save its rows to an array
For Each testedCell In testedCells
If (testedCell.Value Like "*" & TESTED_TEXT & "*") Then
ReDim Preserve foundOnRows(testedTextFoundCount)
foundOnRows(testedTextFoundCount) = testedCell.Row
testedTextFoundCount = testedTextFoundCount + 1
someWereFound = True
End If
Next testedCell
If (someWereFound = False) Then
Exit Sub
End If
' go through the array and paste the formulas to the sheet
For i = LBound(foundOnRows) To UBound(foundOnRows)
If (i