Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Liste mit Nummern generieren (Makro?)

Betrifft: Liste mit Nummern generieren (Makro?) von: Markus
Geschrieben am: 23.05.2008 08:32:22

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

  

Betrifft: AW: Liste mit Nummern generieren (Makro?) von: stormy_weathers
Geschrieben am: 23.05.2008 09:07:56

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...


  

Betrifft: AW: Liste mit Nummern generieren (Makro?) von: Markus
Geschrieben am: 23.05.2008 10:04:45

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


  

Betrifft: AW: Liste mit Nummern generieren (Makro?) von: Markus
Geschrieben am: 23.05.2008 10:05:50

Frage noch offen


  

Betrifft: AW: Liste mit Nummern generieren (Makro?) von: fcs
Geschrieben am: 23.05.2008 12:17:22

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




  

Betrifft: AW: Liste mit Nummern generieren (Makro?) von: Markus
Geschrieben am: 23.05.2008 13:26:29

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


  

Betrifft: AW: Liste mit Nummern generieren (Makro?) von: Renee
Geschrieben am: 23.05.2008 10:12:21

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


  

Betrifft: AW: Liste mit Nummern generieren (Makro?) von: Markus
Geschrieben am: 23.05.2008 11:03:02

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?


  

Betrifft: kleiner Fehler, grosse Wirkung... von: Renee
Geschrieben am: 23.05.2008 11:22:11

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


  

Betrifft: AW: kleiner Fehler, grosse Wirkung... von: Markus
Geschrieben am: 23.05.2008 12:57:22

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


  

Betrifft: AW: Liste mit Nummern generieren (Makro?) von: Rudi Maintaire
Geschrieben am: 23.05.2008 11:22:26

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


  

Betrifft: kleiner und wesentlich feiner ;-) (owT) von: Renee
Geschrieben am: 23.05.2008 11:37:28




  

Betrifft: AW: Liste mit Nummern generieren (Makro?) von: Markus
Geschrieben am: 23.05.2008 13:15:44

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


  

Betrifft: Hilfe ! (@Renée, Franz oder Rudi) von: Markus
Geschrieben am: 23.05.2008 14:24:57

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


  

Betrifft: AW: Hilfe ! (@Renée, Franz oder Rudi) von: fcs
Geschrieben am: 23.05.2008 15:46:35

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




  

Betrifft: AW: Hilfe ! (@Renée, Franz oder Rudi) von: Markus
Geschrieben am: 23.05.2008 15:59:41

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


  

Betrifft: AW: Hilfe ! (@Renée, Franz oder Rudi) von: fcs
Geschrieben am: 23.05.2008 16:24:04

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




  

Betrifft: AW: Hilfe ! (@Renée, Franz oder Rudi) von: Markus
Geschrieben am: 23.05.2008 16:34:55

Der Tag ist gerettet!
Ich bin begeistert.
Mein Chef ist zufrieden.

Ab auf die Insel!!

Grossen Dank und schönes Wochenende!

Markus


 

Beiträge aus den Excel-Beispielen zum Thema "Liste mit Nummern generieren (Makro?)"