Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
976to980
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
976to980
976to980
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Liste mit Nummern generieren (Makro?)

Liste mit Nummern generieren (Makro?)
23.05.2008 08:32:22
Markus
Hallo Excel-Gemeinde,
https://www.herber.de/bbs/user/52563.xls
Ich bin wieder mal mit meinem Latein am Ende. Ich muss (für einen Upload ins SAP) aus einem Bereich in einem Excel Tabellenblatt (im Beispiel Bereichsname Uebersicht_0200) eine Liste von Materialnummern generieren.
Das Resultat sollte etwa so wie in Blatt Upload aussehen. Es müssen alle (nichtleeren) Werte aus den verbundenen Zellen hintereinander aufgelistet werden.
Leider sind die Zellen verbunden, da ich die gleiche bedingte Formatierung von jeweils 3 Zellen nicht anders hingekriegt habe (siehe Beispiel).
Möglicherweise gibt es für mein Problem (Liste generieren) auch eine Lösung mit Formeln. Ich wäre für jede Hilfe dankbar.
Beste Grüsse
Markus

17
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Liste mit Nummern generieren (Makro?)
23.05.2008 09:07:00
stormy_weathers
Hallo Markus,
warum löst du den Zellverbund denn nicht temporär auf und kopierst dir die Daten, sortieren, ...
Gruß
stormy
P.S.: Aus genau solchen Gründen versuche ich immer mit der Zellformatierung "über Auswahl zentrieren" klar zu kommen...

AW: Liste mit Nummern generieren (Makro?)
23.05.2008 10:04:45
Markus
Hallo Stormy,
Ich muss diese Auswertung täglich machen und möchte den Aufwand reduzieren.
Die Zellformatierung "über Auswahl zentrieren" ist mir bekannt, das wäre auch kein Problem. Das Problem liegt in der bedingten Formatierung der Farben mit den Formeln (siehe Beispiel). Ich habe es nicht geschafft, dass dann alle 3 Felder die gleiche Farbe haben (auch die jetztigen Formeln habe ich nur mit Hilfe von Erich G. aus dem Forum hingekriegt).
Es wäre schön, wenn mir jemand einen Lösungsweg aufzeigen könnte. Wenn nicht, muss ich halt weiterhin die aufwendige manuelle Auswertung machen.
Beste Grüsse
Markus

Anzeige
AW: Liste mit Nummern generieren (Makro?)
23.05.2008 10:05:50
Markus
Frage noch offen

AW: Liste mit Nummern generieren (Makro?)
23.05.2008 12:17:22
fcs
Hallo Markus,
eine Auswertung per Formel ist schwierig bis unmöglich. Man müßte mit Funktion INDIREKT arbeiten und über einen komplizierten Algorithmus aus der Zeilennummer der Formel-Zelle im Blatt Upload die zugehörige Zelle im jeweiligen Werkblatt. Im Nachlauf müssen dann immer noch die Leereintrage aus der Liste entferntwerden.
Ich hab in der Datei ein Makro eingerichtet, das die Liste der Materialnummern erzeugt und auch noch ein paar anderer Daten ausliest. Welche Daten du übernehmen willst kannst du im Code festlegen, indem du die entsprechenden Zeilen zu Kommentaren machst.
Das Mako muss nicht unbedingt in der Datei installiert werden, du kannst es auch in einer anderen Datei oder der persönlichen Abeitsmappe speichern.
Das Makro geift immer auf das aktuelle Blatt bzw. die aktive Arbeitsmappe zu.
https://www.herber.de/bbs/user/52576.xls
Nachfolgend nochmals die verwendeten Prozeduren.
Gruß
Franz

Option Explicit
Const lngSpalteU As Long = 3          'Spalte für Eintrag Materialnummer in Up-Load-Liste
Const lngZeileU As Long = 4           'Startzeile Eintrage für Upload
Const strUpload As String = "Upload"  'Name des Blatts mit Up-Load-Liste
Sub UpLoadListe()
Dim wksUpload As Worksheet, objWks As Worksheet
Dim strErgebnis As String
Dim lngZeile As Long, varAuswahl1, varAuswahl
On Error GoTo Fehler
varAuswahl1 = Application.InputBox(Prompt:="Aus welchen Blättern sollen " _
& "Materialnummern in Upload-Liste übertragen werden?" & vbLf & vbLf _
& "1 = Aktuelles Blatt : " & ActiveSheet.Name & vbLf _
& "2 = Alle Blätter deren Name mit ""Werk"" beginnt", _
Title:="Werk-Blatt Materialnummernliste für Upload erstellen", Default:=1, Type:=1)
If varAuswahl1 = 0 Then GoTo Beenden 'Abbrechen gewählt
Set wksUpload = ActiveWorkbook.Worksheets(strUpload)
With wksUpload
If .Cells(.Rows.Count, lngSpalteU).End(xlUp).Row > lngZeileU Then
varAuswahl = MsgBox(Prompt:="Im Upload-Blatt stehen schon Daten. " & vbLf _
& "Daten löschen?" & vbLf & vbLf _
& "Bei Nein werden die Einträge am Ende der Liste fortgesetzt.", _
Buttons:=vbYesNoCancel + vbQuestion, _
Title:="Material-Nummer in Upload-Liste übertragen")
Select Case varAuswahl
Case vbYes
.Range(.Rows(lngZeileU), _
.Rows(.Cells(.Rows.Count, lngSpalteU).End(xlUp).Row)).ClearContents
lngZeile = lngZeileU - 1
Case vbNo
lngZeile = .Cells(.Rows.Count, lngSpalteU).End(xlUp).Row
Case vbCancel
GoTo Beenden
End Select
End If
Select Case varAuswahl1
Case 1 'Aktuelle Tabelle auswerten
strErgebnis = fncUpLoadListe(wksWerk:=ActiveSheet, _
wksListe:=wksUpload, lngZeileListe:=lngZeile)
If strErgebnis  "" Then
MsgBox strErgebnis
End If
Case 2 'Alle Werk_... Tabellen auswerten
For Each objWks In ActiveWorkbook.Worksheets
lngZeile = .Cells(.Rows.Count, lngSpalteU).End(xlUp).Row
Select Case objWks.Name
Case strUpload, "Werk_Liste" 'Liste der Ausnahmen
'do nothing
Case Else
If LCase(Left(objWks.Name, 4)) = "werk" Then
strErgebnis = fncUpLoadListe(wksWerk:=objWks, wksListe:=wksUpload, _
lngZeileListe:=IIf(lngZeile >= lngZeileU, lngZeile, lngZeileU - 1))
If strErgebnis  "" Then
MsgBox strErgebnis
End If
End If
End Select
Next
Case Else
MsgBox "Keine gültige Option für Tabellenauswertung"
End Select
End With
GoTo Beenden
Fehler:
MsgBox "Fehler-Nr. " & Err.Number & " ist aufgetreten!" & vbLf & Err.Description _
& vbLf & " in Prozedur: UpLoadListe"
Beenden:
Set wksUpload = Nothing: Set objWks = Nothing
End Sub
Private Function fncUpLoadListe(wksWerk As Worksheet, wksListe As Worksheet, _
lngZeileListe As Long) As String
Dim lngSpalteW As Long, lngZeileW As Long
Dim varAuswahl As Variant
On Error GoTo Fehler
With wksWerk
'Suche in Zeile 10 bis zur letzen Zeile mit Eintrag in Spalte B, jede 2. Zeile
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For lngZeileW = 10 To .Cells(.Rows.Count, 2).End(xlUp).Row Step 2
'Suche in Spalte F bis AA, jede 3. Spalte
For lngSpalteW = 6 To 27 Step 3
If Not IsEmpty(.Cells(lngZeileW, lngSpalteW)) Then
lngZeileListe = lngZeileListe + 1
wksListe.Cells(lngZeileListe, lngSpalteU - 2).Value = _
.Name                                          'Blattname
wksListe.Cells(lngZeileListe, lngSpalteU - 1).Value = _
.Cells(9, lngSpalteW).Value                    'Status aus Zeile 9
wksListe.Cells(lngZeileListe, lngSpalteU).Value = _
.Cells(lngZeileW, lngSpalteW).Value            'Material Nummer
wksListe.Cells(lngZeileListe, lngSpalteU + 1).Value = _
.Cells(lngZeileW + 1, lngSpalteW).Value        'Vorhanden
wksListe.Cells(lngZeileListe, lngSpalteU + 2).Value = _
.Cells(lngZeileW + 1, lngSpalteW + 1).Value    'Bestellt
wksListe.Cells(lngZeileListe, lngSpalteU + 3).Value = _
.Cells(lngZeileW + 1, lngSpalteW + 2).Value    'Reserviert
End If
Next
Next
End With
fncUpLoadListe = ""
GoTo Beenden
Fehler:
fncUpLoadListe = "Fehler-Nr. " & Err.Number & " ist aufgetreten!" & vbLf & Err.Description _
& vbLf & " in Prozedur: fncUpLoadListe"
Beenden:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Function


Anzeige
AW: Liste mit Nummern generieren (Makro?)
23.05.2008 13:26:00
Markus
Hallo Franz,
Ich bin wirklich erschlagen. Innerhalb von kürzester Zeit erhalte ich 3 verschiedene Vorschläge, die alle mein Problem lösen.
Dein Vorschlag hat mich jedoch ins Grübeln gebracht und weckt neue Begehrlichkeiten.......
Ich bin jedoch schon auf dem Absprung und muss packen gehn. Es geht morgen sehr früh ab in den Urlaub.
Ich werde mir -nach meinem Urlaub- nochmals einige Gedanken machen müssen.
So oder so, im Moment bin ich mehr als zufrieden.
Die allerbesten Grüsse an alle Beteiligten.
Markus

AW: Liste mit Nummern generieren (Makro?)
23.05.2008 10:12:21
Renee
Hi Markus,
Der Vorschlag unten erstellt die Liste, ab der aktiven Zelle für den 'entsprechenden' Bereichsnamen (Code gehört in ein Modul und wird mit MatereialNrListe aufgerufen).

Sub MaterialNrListe()
Call ExtractListe("Übersicht_200")
End Sub
Sub ExtractListe(tBereichsName As String)
Dim tStartCell As String
Dim lCol As Long, lRow As Long, lColE As Long, lRowE As Long
Dim lListIx As Long
lColE = Range(ActiveWorkbook.Names(tBereichsName).RefersTo).Columns.Count - 3
lRowE = Range(ActiveWorkbook.Names(tBereichsName).RefersTo).Columns.Count - 1
tStartCell = Replace(Left(ActiveWorkbook.Names(tBereichsName).RefersTo, _
InStr(ActiveWorkbook.Names(tBereichsName).RefersTo, ":") - 1), "=", "")
If ActiveCell.Value  "" Then
MsgBox "Listenbereich muss leer sein!", vbCritical + vbOKOnly, "Materialliste"
Exit Sub
End If
For lRow = 0 To lRowE Step 2
For lCol = 0 To lColE
If Range(tStartCell).Offset(lRow, lCol)  "" Then
ActiveCell.Offset(lListIx, 0).Value = _
Range(tStartCell).Offset(lRow, lCol).Value
lListIx = lListIx + 1
End If
Next lCol
Next lRow
End Sub


GreetZ Renée

Anzeige
AW: Liste mit Nummern generieren (Makro?)
23.05.2008 11:03:02
Markus
Hallo Renée
https://www.herber.de/bbs/user/52572.xls
Du hast mir schon bei meinem letzten Problem (Autofiltereinstellung über mehrere Tabellenblätter) sehr geholfen (Ist übrigens in derselben Datei). Ich bin Dir wirklich sehr dankbar.
Dein Programm funktioniert beinahe perfekt. Genau so hatte ich es mir vorgestellt.
Leider hört die Liste bei der Nummer 50098606 auf Zeile 32 auf.
Der Bereich müsste eigentlich richtig definiert sein oder habe ich einen Fehler gemacht? Die Originalliste ist noch wesentlich grösser, ich habe einfach Zeilen gelöscht. Aber auch bei der Originaldatei hört die Liste an demselben Ort auf.
Kannst Du nochmals drauf schauen?

Anzeige
kleiner Fehler, grosse Wirkung...
23.05.2008 11:22:11
Renee
Hi Markus,

statt:
lRowE = Range(ActiveWorkbook.Names(tBereichsName).RefersTo).Columns.Count - 1
muss es heissen:
lRowE = Range(ActiveWorkbook.Names(tBereichsName).RefersTo).Rows.Count - 1


GreetZ Renée

AW: kleiner Fehler, grosse Wirkung...
23.05.2008 12:57:22
Markus
Hallo Reneé,
Dank Dir habe ich mein kleines Projekt noch vor meinem morgigen Abflug in den Urlaub abschliessen können. Dein Programm funktioniert tadellos. Tausend Dank.
Herzliche Grüsse
Markus

AW: Liste mit Nummern generieren (Makro?)
23.05.2008 11:22:26
Rudi
Hallo,
versuch's so:

Sub tt()
Dim rngC As Range
For Each rngC In Sheets(1).Range("Übersicht_200")
If rngC.MergeArea.Cells.Count = 3 Then
Sheets("upload").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = rngC(1)
End If
Next
End Sub


Gruß
Rudi

Anzeige
kleiner und wesentlich feiner ;-) (owT)
23.05.2008 11:37:00
Renee

AW: Liste mit Nummern generieren (Makro?)
23.05.2008 13:15:00
Markus
Hallo Rudi,
Vielen Dank auch Dir für Deinen Vorschlag. Funktioniert (wie auch der korrigierte von Renée) tadellos.
Ein Phänomen ist mir aufgefallen. Bei Deiner Liste sind (im Gegensatz zu Renées) einige Zahlen linksbündig aufgelistet. Die Überprüfung zeigte, dass diese in meiner Vorgabe als Text formatiert waren. In meinem Fall war dies nicht relevant, da der Upload anscheinend mit Zahlen und Texten funktioniert.
Auch Dir vielen Dank und beste Grüsse.
Markus

Hilfe ! (@Renée, Franz oder Rudi)
23.05.2008 14:24:57
Markus
https://www.herber.de/bbs/user/52578.xls
In letzter Minute ist doch noch ein grösseres Problem aufgetaucht.
Ich wage kaum nochmals zu fragen.
Die Excel - Auswertung ist wegen der zu grossen Datenmenge im Download zum Erliegen gekommen.
Ich müsste die Anzahl Datensätze im Download reduzieren.
Siehe Beispiel im Ordner Download_SQ01.
Alle mehrfachen Datensätze mit gleichem Inhalt in den Spalten A,C und F müssten eliminiert werden. (Am liebsten Zellen löschen und nach oben verschieben). Die Inhalte der übrigen Spalten sind nicht relevant und werden nicht gebraucht.
Vielleicht hat jemand heute noch Zeit ?
Liebe Grüsse
Markus

Anzeige
AW: Hilfe ! (@Renée, Franz oder Rudi)
23.05.2008 15:46:00
fcs
Hallo Markus,
ich bei mir eine Löschroutine ausgegraben und an deine Tabelle angepasst.
In deiner Beispielmappe waren keine doppelten Sätze enthalten. Spalte A und C oft identisch aber F dann verschieden.
Vor dem 1. Lauf des Makros Sicherheitskopie machen!!!
Die Löschaktion kann nicht rückgängig gmacht werden!!!!!
Kopiere das Makro am besten in ein separates Modul.
Das Makro bearbeitet jeweils die aktive Tabelle.
Gruß
Franz

Option Explicit
Sub DoppelteLoeschen_Download()
'MAkro zum Eleminieren von Daten zeilen im Blatt Download_SQ01, die in den _
Splaten A, S und F identisch
Dim varMeldung As Variant, wks As Worksheet
Set wks = ActiveSheet
With wks
'Bereich Spalte A bis Spalte L, Zeile 2 bis letzte Zeile
varMeldung = DuplikateLoeschen(objWks:=wks, strBereich:=.Range(.Cells(2, 1), _
.Cells(.Rows.Count, 1).End(xlUp).Offset(0, 11)).Address, _
bolSort:=True, bolMeldung:=True)
If varMeldung = "" Then
'do nothing
Else
MsgBox varMeldung
End If
End With
End Sub
Public Function DuplikateLoeschen(objWks As Worksheet, strBereich As String, _
Optional bolSort As Boolean = False, _
Optional bolMeldung As Boolean = False) As String
'Tabellen-Zeilen die identisch in Spalte A, C und F sind des Bereiches entfernen
'objWks     = Tabellenblatt in dem die Doppelten entfernt werden sollen
'strBereich = Bereichsname oder Zellbereich
'bolSort    = True:  Sortierung der Daten in der Tabelle bleibt erhalten _
False: Tabelle wird nach der Duplikate-Spalte sortiert
'bolMeldung = True:  Meldung über Anzahl gelöschte Zeilen wird angezeigt _
False: Meldung wird nicht angezeigt
Dim rngData As Range
Dim rngSort As Range
Dim rngVergleich As Range
Dim nRowsDel As Long
Application.ScreenUpdating = False
On Error GoTo Fehler
With objWks
'Duplikate-Bereich setzen
Set rngData = .Range(strBereich)
If rngData.Rows.Count = 1 Then
MsgBox "Der Datenbeich enthält nur eine Zeile, keine Doppelten möglich."
GoTo Beenden
ElseIf Application.WorksheetFunction.CountA(rngData.Columns(1)) = 0 Then
MsgBox "Der Datenbereich enthält keine Daten!"
GoTo Beenden
End If
'2 Hilfs-Spalten links von Spalte A einfügen
.Range(.Columns(1), Columns(2)).Insert shift:=xlShiftToRight
End With
If bolSort = True Then
Set rngSort = rngData.Columns(1).Offset(0, -rngData.Column + 1)
'Formel für Zeilenummer in Sotierbereich einfügen
rngSort.Formula = "=ROW()"
'Formel duch Werte ersetzen
rngSort.Value = rngSort.Value
End If
'Tabellen-Zeilen nach Duplikatespalten 1., 3., 6. Spalte sortieren
With rngData
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, _
key1:=.Cells(1, 3), order1:=xlAscending, _
key1:=.Cells(1, 6), order1:=xlAscending, header:=xlNo
End With
'Bereich in 2. Spalte für Vergleich definieren
Set rngVergleich = rngData.Columns(1).Offset(0, -rngData.Column + 2)
'Formel für Zeilenvergleich einfügen, dann durch Werte ersetzen
With rngVergleich
'Vergleichformel für die 3 Zellen in den beiden Zeilen
.FormulaR1C1 = "=IF(RC[1]&RC[3]&RC[6]=R[-1]C[1]&R[-1]C[3]&R[-1]C[6],TRUE,RC[-1])"
.Value = .Value
'Anzahl Zeilen vor dem Löschen
nRowsDel = objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Row
'Zeilen mit Wert WAHR in Vergleichsspalte löschen
'Tabellenzeilen nach Vergleichsspalte sortieren (Sortiert zu löschende ans Ende)
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
'Letzten Eintrag in Vergleichsspalte prüfen und ggf. Zeilen löschen
If objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Value = True Then
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete shift:=xlShiftUp
End If
'Anzahl gelöschte Zeilen
nRowsDel = nRowsDel - objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Row
End With
If bolSort = True Then
'Tabellen-Zeilen wieder in alte Reihenfolge sortieren
With rngSort
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
End With
Else
'Tabellen-Zeilen nach Duplikate-Spalte sortieren
With rngData
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
End With
End If
'Hilfsspalten wieder löschen
With objWks
.Range(.Columns(1), .Columns(2)).Delete shift:=xlShiftToLeft
End With
If bolMeldung = True Then
MsgBox Prompt:="Es wurden " & nRowsDel & " doppelte Datensätze gelöscht!", _
Buttons:=vbOKOnly + vbInformation, _
Title:="Doppelte Datensätze löschen"
End If
DuplikateLoeschen = ""
GoTo Beenden
Fehler:
DuplikateLoeschen = "Fehler bei Ausführung der Prozedur ""DuplikateLöschen""" _
& vbLf & vbLf _
& "Fehler Nummer: " & Err.Number & vbLf & Err.Description
If Not rngSort Is Nothing Then
'Hilfsspalten wieder löschen
With objWks
.Range(.Columns(1), .Columns(2)).Delete shift:=xlShiftToLeft
End With
End If
Beenden:
Set rngData = Nothing: Set rngSort = Nothing: Set rngVergleich = Nothing
Application.ScreenUpdating = True
End Function


Anzeige
AW: Hilfe ! (@Renée, Franz oder Rudi)
23.05.2008 15:59:00
Markus
Hallo Franz,
Logisch, ich bin so blöd! In der Hitze des Gefechts habe ich noch die Frage falsch formuliert.
Es sollte heissen:
Alle mehrfachen Datensätze mit gleichem Inhalt in den Spalten A und C müssten eliminiert werden. (Am liebsten Zellen löschen und nach oben verschieben). Die Inhalte der übrigen Spalten sind nicht relevant und werden nicht gebraucht.
Das Problem sind ja gerade die unterschiedlichen Werte in F, die für mich nicht relevant sind.
Ich bin wirklich reif für die Insel.
Grüsse
Markus

AW: Hilfe ! (@Renée, Franz oder Rudi)
23.05.2008 16:24:04
fcs
Hallo Markus,
hier die angepasste Version die die Spalten A und C auf identische prüft.
Schüß und schonne Urlaub.
Franz

Sub DoppelteLoeschen_Download()
'MAkro zum Eleminieren von Daten zeilen im Blatt Download_SQ01, die in den _
Spalten A und C identisch
Dim varMeldung As Variant, wks As Worksheet
Set wks = ActiveSheet
With wks
'Bereich Spalte A bis Spalte L, Zeile 2 bis letzte Zeile
varMeldung = DuplikateLoeschen(objWks:=wks, strBereich:=.Range(.Cells(2, 1), _
.Cells(.Rows.Count, 1).End(xlUp).Offset(0, 11)).Address, _
bolSort:=True, bolMeldung:=True)
If varMeldung = "" Then
'do nothing
Else
MsgBox varMeldung
End If
End With
End Sub
Public Function DuplikateLoeschen(objWks As Worksheet, strBereich As String, _
Optional bolSort As Boolean = False, _
Optional bolMeldung As Boolean = False) As String
'Tabellen-Zeilen die identisch in Spalte A und C sind des Bereiches entfernen
'objWks     = Tabellenblatt in dem die Doppelten entfernt werden sollen
'strBereich = Bereichsname oder Zellbereich
'bolSort    = True:  Sortierung der Daten in der Tabelle bleibt erhalten _
False: Tabelle wird nach der Duplikate-Spalte sortiert
'bolMeldung = True:  Meldung über Anzahl gelöschte Zeilen wird angezeigt _
False: Meldung wird nicht angezeigt
Dim rngData As Range
Dim rngSort As Range
Dim rngVergleich As Range
Dim nRowsDel As Long
Application.ScreenUpdating = False
On Error GoTo Fehler
With objWks
'Duplikate-Bereich setzen
Set rngData = .Range(strBereich)
If rngData.Rows.Count = 1 Then
MsgBox "Der Datenbeich enthält nur eine Zeile, keine Doppelten möglich."
GoTo Beenden
ElseIf Application.WorksheetFunction.CountA(rngData.Columns(1)) = 0 Then
MsgBox "Der Datenbereich enthält keine Daten!"
GoTo Beenden
End If
'2 Hilfs-Spalten links von Spalte A einfügen
.Range(.Columns(1), Columns(2)).Insert shift:=xlShiftToRight
End With
If bolSort = True Then
Set rngSort = rngData.Columns(1).Offset(0, -rngData.Column + 1)
'Formel für Zeilenummer in Sotierbereich einfügen
rngSort.Formula = "=ROW()"
'Formel duch Werte ersetzen
rngSort.Value = rngSort.Value
End If
'Tabellen-Zeilen nach Duplikatespalten 1., 3. Spalte sortieren
With rngData
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, _
key1:=.Cells(1, 3), order1:=xlAscending, header:=xlNo
End With
'Bereich in 2. Spalte für Vergleich definieren
Set rngVergleich = rngData.Columns(1).Offset(0, -rngData.Column + 2)
'Formel für Zeilenvergleich einfügen, dann durch Werte ersetzen
With rngVergleich
'Vergleichformel für die 2 Zellen in den beiden Zeilen
.FormulaR1C1 = "=IF(RC[1]&RC[3]=R[-1]C[1]&R[-1]C[3],TRUE,RC[-1])"
.Value = .Value
'Anzahl Zeilen vor dem Löschen
nRowsDel = objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Row
'Zeilen mit Wert WAHR in Vergleichsspalte löschen
'Tabellenzeilen nach Vergleichsspalte sortieren (Sortiert zu löschende ans Ende)
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
'Letzten Eintrag in Vergleichsspalte prüfen und ggf. Zeilen löschen
If objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Value = True Then
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete shift:=xlShiftUp
End If
'Anzahl gelöschte Zeilen
nRowsDel = nRowsDel - objWks.Cells(objWks.Rows.Count, .Column).End(xlUp).Row
End With
If bolSort = True Then
'Tabellen-Zeilen wieder in alte Reihenfolge sortieren
With rngSort
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
End With
Else
'Tabellen-Zeilen nach Duplikate-Spalte sortieren
With rngData
.EntireRow.Sort key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
End With
End If
'Hilfsspalten wieder löschen
With objWks
.Range(.Columns(1), .Columns(2)).Delete shift:=xlShiftToLeft
End With
If bolMeldung = True Then
MsgBox Prompt:="Es wurden " & nRowsDel & " doppelte Datensätze gelöscht!", _
Buttons:=vbOKOnly + vbInformation, _
Title:="Doppelte Datensätze löschen"
End If
DuplikateLoeschen = ""
GoTo Beenden
Fehler:
DuplikateLoeschen = "Fehler bei Ausführung der Prozedur ""DuplikateLöschen""" _
& vbLf & vbLf _
& "Fehler Nummer: " & Err.Number & vbLf & Err.Description
If Not rngSort Is Nothing Then
'Hilfsspalten wieder löschen
With objWks
.Range(.Columns(1), .Columns(2)).Delete shift:=xlShiftToLeft
End With
End If
Beenden:
Set rngData = Nothing: Set rngSort = Nothing: Set rngVergleich = Nothing
Application.ScreenUpdating = True
End Function


Anzeige
AW: Hilfe ! (@Renée, Franz oder Rudi)
23.05.2008 16:34:00
Markus
Der Tag ist gerettet!
Ich bin begeistert.
Mein Chef ist zufrieden.
Ab auf die Insel!!
Grossen Dank und schönes Wochenende!
Markus

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige