Kompliziertes VBA Makro

Hi @ All, ich hoffe sehr das hier einige VBA Profis unter euch sind und mir bei ner schwierigen Aufgabe helfen könnt...

Ich habe folgende Situation:

ich habe eine Excel Tabelle die nach diesem Schema aufgebaut ist:

Spalte A Spalte B Spalte C

Unrelevant Hans 001
Unrelevant Hans 005
Unrelevant Hans 003
Unrelevant Hans 007
Unrelevant Hans 008
Unrelevant Frank 002
Unrelevant Bernd 003
Unrelevant Bernd 005
Unrelevant Hans 009

Nun bräuchte ich ein Makro das folgendes erfüllt:

1. Wenn in Spalte B mehr als 4 Einträge mit dem gleichem Namen bestehen, hier z.B bei Hans, dann sollen alle Zeilen ausser eine gelöscht werden und in der Zeile die noch geblieben ist soll dann in Spalte C "irgendwas" hineingeschrieben werden!

2. Hat ein Name in Spalte B mehr als einen aber weniger als 5 dann soll wieder nur eine Zeile bleiben und in Spalte C sollen dann die Einträge der ganzen Zeilen zusammengefasst werden. Also im Beispiel von Bernd:

unrelevant Bernd 003 + 005

3. Hat ein Name nur einen Eintrag soll nichts passieren!

Könnt ihr mir dabei ein wenig helfen? Das wäre wirklich super...

 

Darf die Liste nach Spalte B sortiert werden? Dann wäre es nicht sehr schwer ein Makro zu schreiben.

 

Hallo Lambert,

Das sollte kein Problem sein...
Man muss ja nicht alles verstehen wollen, aber... wenn es mehr als 4 Hans gibt... werden die dann alle entlassen ?

1. Ist das eine dynamische Tabelle ?
Kommen immer wieder neue Zeilen dazu ?
Oder werden vorhandene Einträge geändert ?

2. Wie soll das Makro gestartet werden ?
Automatisch, jedes Mal, wenn Zeilen hinzugefügt, oder allenfalls vorhandene Zeilen verändert werden ?
Oder kommt ein Button aufs Blatt... und der User startet nach Bedarf ?

3. Wie sieht die Tabelle aus ?
In Zeile 1 sind die Spaltenüberschriften, ab Zeile 2 sind die Datensätze ?
Unter dem letzten Datensatz ist nichts mehr, nur leere Zeilen ?


Jetzt habe ich leider keine Zeit mehr, aber wenn Du meinen Fragen beantwortest...
...wirst Du meinen Vorschlag morgen zum Frühstück sehen...

Gruss Urs

 

Hallo, ja das ist kein Problem! Kann gerne sortiert werden...


@ Urs

vorhandene werden geändert!

User startet nach Bedarf!

Richtig!

Ich danke dir...

 

Ich hab noch was vergessen zu erwähnen, im Falle 2 steht in Spalte C: 002 + irgendetwas....

Später soll dann alles was nach dem Leerzeichen kommt ignoriert werden! Also nur 002 + 003 + etc... nicht 002 blablub + 003....

 

Hallo Lambert,

Teste dieses Makro an einer Kopie der Nutzdatei.
Viel Zeit zum Testen hatte ich nicht mehr, hoffen wir es klappt...

Im VB-Editor den Code in den Unterordner des zu bearbeitenden Blattes kopieren.

Code:

Option Explicit
Private Sub TabelleBereinigen()

Dim rngSort As Range, uRow, dRow, lCol, rCol, xCol, yCol, zCol
Dim xRow, xName, xNum, xRep, xVal, xRem, i
            'sucht unterste Zeilennummer
dRow = Columns(2).End(xlDown).Row
''''' an Deine Tabelle anpassen
uRow = 2        'oberste Zeilennummer
                'zum Sortieren die Spalten der ganzen Tabelle verwenden
lCol = 1        'linke Spaltennummer 1 = A
rCol = 7        'rechte Spaltennummer zB 7 = G
xCol = 2        'Sortierspalte zum Bearbeiten 2 = B
yCol = 3        'Spalte mit den Werten 3 = C
zCol = 5        'ev.Sortierspalte zum Zurücksetzen der Sortierung zB 5 = E
xRem = "irgendwas"      '= Deine Bemerkung, wenn mehr als 4 gleiche Namen
'''''
                'sortiert nach Spalte xCol = 2 = B
Set rngSort = ActiveSheet.Range(Cells(uRow, lCol), Cells(dRow, rCol))
    rngSort.Sort Key1:=Columns(xCol), order1:=xlAscending, header:=xlNo

Cells(uRow, xCol).Select

Do
    xRow = ActiveCell.Row
    xName = ActiveCell.Value
    xNum = xNum + 1
    If xName = ActiveCell.Offset(-1, 0).Value Then
        If xNum < 5 Then
            xVal = xVal & " + " & Left(Cells(xRow, yCol).Value, 3)
        Else
            xVal = xRem
        End If
        If xName <> ActiveCell.Offset(1, 0).Value Then
            If xNum = 1 Then
                xNum = 0
            
            Else
                ActiveCell.Offset(-(xNum - 1), 0).Select
                ActiveCell.Offset(0, 1).Value = xVal
                For i = 0 To xNum - 2
                    Rows(xRow - i).EntireRow.Delete
                Next
                xNum = 0
            End If
        End If
    Else
        xVal = Left(ActiveCell.Offset(0, 1).Value, 3)
        If ActiveCell.Offset(1, 0).Value = xName Then
            xNum = 1
        Else
            xNum = 0
        End If
    End If
    ActiveCell.Offset(1, 0).Select

Loop While ActiveCell.Value <> ""

'''''nur wenn benötigt, sonst diese 2 Zeilen weglassen
                'sortiert zurück zB nach Spalte zCol = 5 = E
Set rngSort = ActiveSheet.Range(Cells(uRow, lCol), Cells(dRow, rCol))
    rngSort.Sort Key1:=Columns(zCol), order1:=xlAscending, header:=xlNo
'''''

Set rngSort = Nothing

End Sub

Gruss Urs

 

Hallo Urs...

Ich danke dir...das funktioniert wunderbar...Aber eine Sach estimmt nicht ganz...Bei der Sache wo er Spalte C hintereinander stellt 002 + 003 + ...Da nimmt er nur die ersten 3 Zeichen! Er soll aber alles bis zum ersten Leerzeichen nehmen!

Und vielleicht bekommst du das noch hin, das wenn mehr als vier sind soll ja "irgendwas" stehen, schaffst du das auch das dann "irgendwas x" steht? Also x soll eine fortlaufende Nummer sein...Also beim ersten Mal "Irgendwas 1 " dann "iregdnwas 2"...

Das wäre echt super....

 

Hallo Lambert,

So müsste es klappen...

- bis zum ersten Leerzeichen = Ok
Damit im String allfällig vorangestellte Leerzeichen keinen Aerger machen, habe ich diese "weggetrimt"

- xRem mit fortlaufender Ordnungsnummer = OK
Bei Deinen Anpassungen am Anfang des Subs >
> xRem hat ein Leerzeichen zum Trennen von Text und Zahl > lassen oder entfernen
> xOrd = 100 bedeutet > 1.Ordnungsnummer = 101 ...damit alle Ordnungsnummern gleiche Stellenzahl haben...
...anpassen oder auf 0 setzen

Code:

Option Explicit
Private Sub TabelleBereinigen()

Dim rngSort As Range, uRow, dRow, lCol, rCol, xCol, yCol, zCol
Dim xRow, xName, xNum, xStr, xRep, xVal, xRem, xOrd, i
                'sucht unterste Zeilennummer
dRow = Columns(2).End(xlDown).Row
''''' an Deine Tabelle anpassen
uRow = 2                'oberste Zeilennummer
                'zum Sortieren die Spalten der ganzen Tabelle verwenden
lCol = 1                'linke Spaltennummer 1 = A
rCol = 7                'rechte Spaltennummer zB 7 = G
xCol = 2                'Sortierspalte zum Bearbeiten 2 = B
yCol = 3                'Spalte mit den Werten 3 = C
zCol = 5                'ev.Sortierspalte zum Zurücksetzen der Sortierung zB 5 = E
xRem = "irgendwas "     '= Deine Bemerkung, wenn mehr als 4 gleiche Namen
xOrd = 100              'Start-Ordnungsnummer für xRem, hier 1.Nummer = 101
'''''
                        'sortiert nach Spalte xCol = 2 = B
Set rngSort = ActiveSheet.Range(Cells(uRow, lCol), Cells(dRow, rCol))
    rngSort.Sort Key1:=Columns(xCol), order1:=xlAscending, header:=xlNo

Cells(uRow, xCol).Select

Do
    xRow = ActiveCell.Row
    xName = ActiveCell.Value
    xNum = xNum + 1
    xStr = Trim(Cells(xRow, yCol).Value)
    If xName = ActiveCell.Offset(-1, 0).Value Then
        If xNum < 5 Then
            xVal = xVal & " + " & Left(xStr, InStr(xStr, " ") - 1)
        Else
            xVal = xRem
        End If
        If xName <> ActiveCell.Offset(1, 0).Value Then
            If xNum = 1 Then
                xNum = 0
            
            Else
                ActiveCell.Offset(-(xNum - 1), 0).Select
                If xVal = xRem Then
                    xOrd = xOrd + 1
                    ActiveCell.Offset(0, 1).Value = xVal & xOrd
                Else
                    ActiveCell.Offset(0, 1).Value = xVal
                End If
                For i = 0 To xNum - 2
                    Rows(xRow - i).EntireRow.Delete
                Next
                xNum = 0
            End If
        End If
    Else
        xVal = Left(xStr, InStr(xStr, " ") - 1)
        If ActiveCell.Offset(1, 0).Value = xName Then
            xNum = 1
        Else
            xNum = 0
        End If
    End If
    ActiveCell.Offset(1, 0).Select

Loop While ActiveCell.Value <> ""

'''''nur wenn benötigt, sonst diese 2 Zeilen weglassen
                'sortiert zurück zB nach Spalte zCol = 5 = E
Set rngSort = ActiveSheet.Range(Cells(uRow, lCol), Cells(dRow, rCol))
    rngSort.Sort Key1:=Columns(zCol), order1:=xlAscending, header:=xlNo
'''''

Set rngSort = Nothing

End Sub

Gruss Urs

 

Boah du bist echt Super...So wie es jetzt ist ist es Perfekt! Ich danke dir Vielmals!

 

Hi Urs2,

eine letzte Bitte habe noch! Es funktioniert jetzt alles Super, bloss eine Sache habe ich vergessen! Und zwar stehen in Zeile D - AW auch noch Daten drinne! Es sind aber immer die gleichen Einträge bei Namen mit mehreren Einträgen!
Diese Einträge müssen natürlich auch mit übernommen werden! Verstehst du was ich meine?

Also die Einträge in den Zeilen D - AW werden nicht gelöscht sondern verschieben sich!

 

Habs selber schon gelöst....dank dir!

 

Aus Deiner PN >>>

1. Ich helfe prinzipiell nur im Forum, nicht über PN
2. ...weil nur ich weiss, ob ich helfen könnte und,... ob mich das Problem überhaupt interessiert
3. ...und weil ich fern von Allwissenheit bin... andere Leute wissen andere Sachen besser...

Gerade Dein Problem >>> Ich sehe zum ersten mal HTML-Tags... für was die gut sind, kann ich nur erahnen...

Ich verstehe das so >
- die verschiedenen Tags werden einfach hintereinander geschrieben, ohne Trenner
- wenn ein Leerzeichen oder sonst was dazwischen steht, müsste man den Code noch anpassen
- wenn der bestimmter Tag mehrmals vorkommt, sollen alle bis auf einen gelöscht werden - Reihenfolge irrelevant
- wenn etwa der erste bleiben sollte und erst die nächsten gelöscht werden sollen, muss man den Code auch noch anpassen

Versuche es mit diesem Code > an einer Kopie der Nutzdatei, Code in den Ordner des Blattes einfügen >>>

Code:

Option Explicit

Sub Konzentrieren()

Dim xOrig As String, xCell As Range, xVal As String, _
    yVal As String, yLen As Integer, numR As Integer
        
            'Suchstring 1 mal irgendwo in einer Zelle abgelegt, zB in C4
xOrig = Range[COLOR="Red"]("C4")[/COLOR].Value

            'für jede in Spalte G markierte Zelle wird gemacht
For Each xCell In Selection
    xVal = xCell.Value
    yVal = xVal
            'zählt die Vorkommen des Suchstrings
    Do
        yLen = Len(yVal)
            'löscht jedes Vorkommen im Hilfsstring
        yVal = Replace(yVal, xOrig, "", , 1)
            'wenn vor und nach "Löschen" Strings gleich lang > fertig
        If yLen = Len(yVal) Then Exit Do
        numR = numR + 1
    Loop
            'wenn Vorkommen > 1
    If numR > 1 Then
            'löscht alle bis auf eins
        yVal = Replace(xVal, xOrig, "", , numR - 1)
            'schreibt bereinigten String in Zelle
        xCell.Value = yVal
    End If
            'setzt Zähler zurück
    numR = 0
Next

End Sub

Funktion >
- den zu suchenden String irgendwo auf dem Blatt in eine Zelle schreiben, den roten Range im Code anpassen
- in der zu bearbeitenden Spalte (also wohl G) die gewünschten Zellen markieren >>> Makro starten

Vielleicht habe ich diese Tags sogar richtig verstanden...

Gruss Urs

 

Hi, das funktioniert sehr gut bis auf das er die Strings die er rauslöscht mit leerzeichen ersetzt...kann man das so ändern das auch die leerzeichen weg sind?:

 

...nein, das tut er nicht !

Die Zeile...
yVal = Replace(xVal, xOrig, "", , numR - 1)
...ersetzt den entfernten String durch "", also durch Nichts.
Das zusätzliche Leerzeichen muss im Original-String schon drin sein...

Ich kann im origString aber nicht nach " origString" oder "origString " suchen lassen, denn das erste Vorkommen hat vorne nie ein Leerzeichen, das letzte hinten nie. Eines der beiden würde also nicht gefunden.

Ich muss mir da noch etwas einfallen lassen...
...zeig dazu einmal einen dieser ellenlangen Original-Tags und den gleichen, wie er korrigiert sein soll - hier als Code eingefügt
(ich habe ja keine Ahnung, wie die Tags richtig oder falsch geschrieben sind...)

Gruss Urs

 

Habs wieder mal selbst hinbekommen-....Hab nen bisschen aus deinem Makros gelernt! Trotzdem Vielen Dank!