AW: Mehrfache zusammenfassen
18.05.2006 17:04:54
Erich
Hallo Tremker,
versuchs mal mit den beiden Makros:
Option Explicit
Sub Zusammenfassen_mit_Like()
Dim wsErg As Worksheet
Dim zUR As Long, zz As Long, ss As Integer, z2 As Long, s2 As Integer
Dim tt As String, strT As String, lngSum As Long, posK As Integer
Dim rgCur As Range, rgGef As Range, aend As Boolean
Sheets(1).Copy after:=Sheets(1)
Set wsErg = ActiveSheet
zUR = ActiveSheet.UsedRange.Rows.Count
For zz = 1 To zUR
For ss = 1 To Cells(zz, Columns.Count).End(xlToLeft).Column
If Not IsEmpty(Cells(zz, ss)) Then
Set rgCur = Cells(zz, ss)
tt = rgCur.Value
posK = InStrRev(tt, "(")
strT = Left(tt, posK - 1)
lngSum = 1 * Mid(tt, posK + 1, Len(tt) - posK - 1)
aend = False
For z2 = zz To zUR
For s2 = 1 To Cells(zz, Columns.Count).End(xlToLeft).Column
If (z2 > zz Or s2 > ss) And _
(Cells(z2, s2) Like strT & "(#)" _
Or Cells(z2, s2) Like strT & "(##)" _
Or Cells(z2, s2) Like strT & "(###)" _
Or Cells(z2, s2) Like strT & "(####)" _
Or Cells(z2, s2) Like strT & "(#####)" _
Or Cells(z2, s2) Like strT & "(######)") Then
Set rgGef = Cells(z2, s2)
tt = rgGef.Value
posK = InStrRev(tt, "(")
If posK <> Len(strT) + 1 Then
MsgBox "Name in Zelle" & rgGef.Address(0, 0) & "enthält '('"
Else
lngSum = lngSum + Mid(tt, posK + 1, Len(tt) - posK - 1)
rgGef.ClearContents
aend = True
End If
End If
Next s2
Next z2
If aend Then rgCur = strT & "(" & lngSum & ")"
End If
Next ss
Next zz
End Sub
Sub Zusammenfassen_mit_Find()
Dim wsErg As Worksheet
Dim zUR As Long, sUR As Integer, zz As Long, ss As Integer
Dim tt As String, strT As String, lngSum As Long, posK As Integer
Dim rgCur As Range, rgSuch As Range, rgGef As Range
Dim erstAdr As String, curAdr As String, aend As Boolean
Sheets(1).Copy after:=Sheets(1)
Set wsErg = ActiveSheet
zUR = ActiveSheet.UsedRange.Rows.Count
sUR = ActiveSheet.UsedRange.Columns.Count
For zz = 1 To zUR
For ss = 1 To Cells(zz, Columns.Count).End(xlToLeft).Column
If Not IsEmpty(Cells(zz, ss)) Then
Set rgCur = Cells(zz, ss)
tt = rgCur.Value
curAdr = rgCur.Address
posK = InStrRev(tt, "(")
strT = Left(tt, posK - 1)
lngSum = 1 * Mid(tt, posK + 1, Len(tt) - posK - 1)
Set rgSuch = Range(Cells(zz, 1), Cells(zUR, sUR))
Set rgGef = rgSuch.Find(What:=strT & "(", _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)
erstAdr = rgGef.Address
aend = False
Do
If rgGef.Address <> curAdr Then
tt = rgGef.Value
posK = InStrRev(tt, "(")
If posK <> Len(strT) + 1 Then
MsgBox "Name in Zelle" & rgGef.Address(0, 0) & "enthält '('"
Else
lngSum = lngSum + Mid(tt, posK + 1, Len(tt) - posK - 1)
rgGef.ClearContents
aend = True
End If
End If
Set rgGef = rgSuch.FindNext(rgGef)
Loop While Not rgGef Is Nothing And rgGef.Address <> erstAdr
If aend Then rgCur = strT & "(" & lngSum & ")"
End If
Next ss
Next zz
End Sub
Die erzeugen eine neue Tabelle1 (2) aus Tabelle1:
|
| Tabelle1 |
| | A | B | C | | 1 | Name1(1) | Nammme2(3) | Nammmmmmmmme3(5) | | 2 | Name4(11) | Name5(33) | Name4(abc(55) | | 3 | Name5(111) | Namen5(333) | Name4(555) | |
| |
| Tabelle1 (2) |
| | A | B | C | | 1 | Name1(1) | Nammme2(3) | Nammmmmmmmme3(5) | | 2 | Name4(566) | Name5(144) | Name4(abc(55) | | 3 | | Namen5(333) | | |
| |
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort