AW: Hilfe bei Makro
07.06.2007 09:05:00
Dan
Hi,
ja ich bin wieder wach :-). Den code einfach in ein standard module kopieren. Also den code kopieren, dann excel starten, Alt + F11 druecken, menue insert/module auswaehlen und den inhalt des clipboards in den module hinzufuegen (paste). Dann nur noch den cursor in die sub main posten und F5 druecken, so wird der code ausgefuehrt. Vorher ein test-sheet vorberreiten, also sheet wo sich irgendwelche test-daten befinden.
Ok, besser waere vieleicht, wenn ich die Datei mit dem Code hochlade, also die datei ist hier:
https://www.herber.de/bbs/user/43070.xls
Der code in der datei versucht folgendes zu machen : erstmals alle duplicities ausm used range entfernen, danach sollen also nur unique werte bleiben. Diesen Code habe ich mit englischen Komentaren komentiert. Und danach versuch der code die duplicities auch innehalb vom der zellen zu entfernen, also das problem mit dem Paul Markus Stefan usw.
Also die Datei downloaden, oeffnen, Alt + F11 druecken, den cursor in main posten, F5. Danach die test daten pruefen.
Ok und der komplette code in der datei sieht so aus:
===========================================================================
Option Explicit
' Hier ist der main entry point:
Public Sub main()
Call RemoveDuplicateEntriesInUsedRange
Call RemoveDuplicatePartsInUsedRangeCells
End Sub
' In this sub all the cells in the used range on the active sheet
' are tested for their duplicates.
' Only first one occurance of each different cell-value is left in the used range,
' all other occurances are deleted. So after the sub finishes, each cell-value
' in the used range will be unique.
' Method used : compare each cell value with all other values.
' Each cell, which had some duplicities will be marked with a blue color.
' Each cell, where the value was deleted due to its duplicity will be makked with red.
Public Sub RemoveDuplicateEntriesInUsedRange()
On Error GoTo Err_RemoveDuplicateEntries
Dim cellOuther As Range
Dim cellInner As Range
Dim cellsInUsedRangeOnActiveSheet As Range
Application.ScreenUpdating = False
Set cellsInUsedRangeOnActiveSheet = ActiveSheet.UsedRange.Cells
For Each cellOuther In cellsInUsedRangeOnActiveSheet
' do not compare empty cells
If (cellOuther.Value = "") Then
GoTo continue_outer
End If
For Each cellInner In cellsInUsedRangeOnActiveSheet
' do not compare empty cells
' do not compare the cell with it self
If (cellInner.Value = "" Or cellInner.Row = cellOuther.Row And cellInner.Column = _
cellOuther.Column) Then
GoTo continue_inner
End If
If (VBA.Trim(cellOuther.Value) = VBA.Trim(cellInner.Value)) Then
cellInner.Value = "" ' delete the duplicate value
cellInner.Interior.Color = VBA.RGB(255, 0, 0) ' mark the cell where the value _
was deleted with red
cellOuther.Interior.Color = VBA.RGB(0, 0, 255) ' mark the cell which had some _
duplicities with blue
End If
continue_inner:
Next cellInner
continue_outer:
Next cellOuther
Application.ScreenUpdating = True
Exit Sub
Err_RemoveDuplicateEntries:
Application.ScreenUpdating = True
VBA.MsgBox Err.Description & "[" & Err.Number & "]", vbCritical, "Error in ' _
RemoveDuplicateEntries'"
End Sub
' Paul Stefan Paul Markus Paul Stefan Markus Paul Paul
Public Sub RemoveDuplicatePartsInUsedRangeCells()
On Error GoTo Err_RemoveDuplicatePartsInUsedRangeCells
Dim targetCell, cellTextParts
Dim i, j, result
' fuer alle zellen im used range
For Each targetCell In ActiveSheet.UsedRange.Cells
' den Text in ein array an den spaces splitten
cellTextParts = VBA.Split(VBA.Trim(targetCell.Value), " ")
' keine trennzeichen, keine sub-texte vorhanden, continue
If (VBA.IsArray(cellTextParts) = False) Then
GoTo continue_targetCell
End If
' das array duchgehen, alle mit allen vergleichen, die doppelten strings auf "" setzen
For i = LBound(cellTextParts) To UBound(cellTextParts)
If (cellTextParts(i) "") Then
For j = i + 1 To UBound(cellTextParts)
If (VBA.Trim(cellTextParts(i)) = VBA.Trim(cellTextParts(j))) Then
cellTextParts(j) = ""
End If
Next j
End If
Next i
' den gesammten text wiederherstellen
result = ""
For i = LBound(cellTextParts) To UBound(cellTextParts)
If (cellTextParts(i) "") Then
If (result = "") Then
result = cellTextParts(i)
Else
result = result & " " & cellTextParts(i)
End If
End If
Next i
' den text ohne doppelte sub-texte zurueck in die Zelle schreiben
targetCell.Value = result
continue_targetCell:
Next targetCell
Exit Sub
Err_RemoveDuplicatePartsInUsedRangeCells:
VBA.MsgBox Err.Description & "[" & Err.Number & "]", vbCritical, "Error in ' _
RemoveDuplicatePartsInUsedRangeCells'"
End Sub
===========================================================================
Gruss Dan, cz