AW: gleiche Zeile filtern
17.06.2007 20:48:00
Klaus-Dieter
Hallo David,
anbei die Makros:
Option Explicit
' geschrieben von Klaus-Dieter Oppermann (2005)
' Die Makros dürfen frei verwendet werden, solange
' mein Name und der Hinweis auf meine Internetseite
' nicht entfernt werden
' Globale Variablen deklarieren
Dim sziel As Integer ' Letzte Spalte
Dim zziel As Integer ' Letzte Zeile
Dim lbrg As Excel.Range ' Zähler für Beschriftungen
Dim lbl As MSForms.Label ' Beschriftungen
Dim w As Long ' Obere Objektposition (Textboxen)
Dim x As Long ' Obere Objektposition (Beschriftungen)
Dim xk As Long ' Obere Objektposition (Kontrollkästchen)
Dim obj As Object ' Formularobjekte
Dim azo As Integer ' Zähler für Objekte
Dim spa As String ' Überschrift für Ergebnisspalte
Dim ziel As Integer ' letzte Spalte
Private Sub ComboBox1_Change()
' Zeigt die Tabellenblätter der aktiven Arbeitsmappe an
' geschrieben von Klaus-Dieter Oppermann (2005)
' Variablen deklarieren
Dim Blatt As Object ' Tabellenblätter
ComboBox9.Clear ' Inhalte aus ComboBox löschen
Workbooks(ComboBox1.Text).Activate ' Ausgewählte Arbeitsmappe aktivieren
For Each Blatt In ActiveWorkbook.Sheets ' Beginn Suche nach Tabellennamen
With ComboBox9 ' Gefundene Namen in Combobox einlesen
.AddItem Blatt.Name ' "
End With ' "
Next Blatt ' Schleifenzähler plus 1
End Sub
Private Sub ComboBox11_Change()
' Zeigt die Inhalte der ersten Tabellenzeile
' geschrieben von Klaus-Dieter Oppermann (2005)
azo = 0
For Each obj In Me.Controls ' Beginn Suche der Textboxen
If Left(TypeName(obj), 7) = "TextBox" Then ' wenn Objekt = Textbox, dann ...
azo = azo + 1 ' ... Zähler plus 1
obj.Value = Worksheets(Me.ComboBox9.Text). _
Cells(Me.ComboBox11.Value, azo) ' ... Zellinhalt in ComboBox einlesen
End If ' Ende Bedingung
Next obj ' Schleifenzähler plus 1
End Sub
Private Sub ComboBox4_Change()
' Beschriftet das UserForm mit den Spaltenüberschriften
' geschrieben von Klaus-Dieter Oppermann (2005)
' Variablen deklarieren
Dim r As Integer, s As Integer
Dim t As Integer, l As Integer
Dim AM As Object
Dim tbrg As Excel.Range
Dim ktrg As Excel.Range
Dim tebo As MSForms.TextBox
'Dim lbl As MSForms.Label 'doppelt
Dim ktk As MSForms.CheckBox
Dim sp, we As Integer
' Werte zuweisen
sziel = Worksheets(Me.ComboBox9.Text).Range("IV" & _
Me.ComboBox4.Value).End(xlToLeft).Column ' letzte Spalte mit Inhalt ermitteln
If sziel > 13 Then sziel = 13
DoppelteDaten.Height = sziel * 15 + 300 ' Höhe des UserForm aus Anzahl der _
Objekte berechnen
' Textboxen erzeugen
ziel = Range("IV" & Me.ComboBox4.Value).End _
(xlToLeft).Column ' Letzte Spalte ermitteln
If ziel > 26 Then ziel = 26 ' Begrenzung auf 26 Spalten
Range("A" & Me.ComboBox4.Value, Cells _
(Me.ComboBox4.Value, ziel)).Select ' Anzahl der Beschriftungen ermitteln
x = 145 ' Variable für Positionierung der _
ersten TextBox
xk = 140 ' Variable für Positionierung des _
ersten Kontrollkästchens
w = 140 ' Variable für Positionierung der _
ersten Beschriftung
For Each tbrg In Selection ' Start der Schleife zum Erzeugen der _
TextBoxen
Set tebo = Me.Controls.Add("Forms.TextBox.1") ' TextBox zufügen
If w >= 400 Then ' wenn Wert > 400, dann ...
t = -260 ' ... Wert t korrigieren
l = 250 ' ... Wert l korrigieren
DoppelteDaten.Width = 550 ' ... Breite des UserForm festlegen
End If ' Ende der Bedingung
With tebo ' Parameter für Textbox ...
.Left = 96 + l ' ... Position linke Seite
.Top = w + t ' ... Oberkante
.Width = 120 ' ... Breite
End With ' Ende Parameter übergeben
w = w + 20 ' Variable für Oberkante hochzählen
Next tbrg ' Wendepunkt für Schleife
' Kontrollkästchen (CheckBoxen) erzeugen
l = 0 ' Wert l auf null
t = 0 ' Wert t auf null
Range("A" & 1, Cells(1, ziel)).Select ' Anzahl der Beschriftungen ermitteln
For Each ktrg In Selection ' Start der Schleife zum Erzeugen der _
Labels
Set ktk = Me.Controls.Add("Forms.CheckBox.1") ' Label zufügen
If xk >= 400 Then ' wenn xk > 400, dann ...
t = -260 ' ... Wert t korrigieren
l = 250 ' ... Wert l korrigieren
End If ' Ende der Bedingung
With ktk ' Parameter für CheckBox ...
.Left = 220 + l ' ... Position linke Seite
.Top = xk + t ' ... Position Oberkante
.Width = 70 ' ... Breite
End With ' Ende Parameter übergeben
xk = xk + 20 ' Variable für Oberkante hochzählen
Next ktrg ' Wendepunkt für Schleife
Cells(1, 1).Select ' Zelle A1 selektieren
' Schaltflächen positionieren
With CommandButton2 ' Parameter an Schaltfläche 1 übergeben _
.Top = sziel * 15 + 220 ' ... Punkt für Oberkante berechnen
.Left = 244 ' ... Position linke Seite
End With ' Ende Parameter übergeben
With CommandButton1 ' Parameter an Schaltfläche 2 übergeben _
.Top = sziel * 15 + 220 ' ... Punkt für Oberkante berechnen
.Left = 134 ' ... Position linke Seite
End With ' Ende Parameter übergeben
With CommandButton3 ' Parameter an Schaltfläche 2 übergeben _
.Top = sziel * 15 + 220 ' ... Punkt für Oberkante berechnen
.Left = 24 ' ... Position linke Seite
End With ' Ende Parameter übergeben
With meineseite ' Schriftfeld positionieren
.Top = sziel * 15 + 256 ' Oberkante
.Left = 20 ' Linke Seite
End With ' Ende der Positionierung
x = 145 ' Variable für Positionierung der _
ersten TextBox
ziel = Range("IV" & Me.ComboBox4.Value).End _
(xlToLeft).Column ' Letzte Spalte ermitteln
If ziel > 26 Then ziel = 26 ' Begrenzung auf 26 Spalten
Range("A" & Me.ComboBox4.Value, Cells(Me.ComboBox4. _
Value, ziel)).Select ' Anzahl der Beschriftungen ermitteln
l = 0 ' Wert l auf null
t = 0 ' Wert t auf null
For Each lbrg In Selection ' Start der Schleife zum Erzeugen der _
Labels
Set lbl = Me.Controls.Add("Forms.Label.1") ' Label zufügen
If x >= 400 Then ' wenn Wert > 400, dann ...
t = -260 ' ... Wert t korrigieren
l = 250 ' ... Wert l korrigieren
End If ' Ende der Bedingung
With lbl ' Parameter für Label ...
.Caption = lbrg.Value ' ... Text zuweisen
.Font.bold = True ' ... Schriftart = Fett
.Left = 25 + l ' ... Position linke Seite
.Top = x + t ' ... Position Oberkante
.Width = 70 ' ... Breite
End With ' Ende Parameter übergeben
x = x + 20 ' Variable für Oberkante hochzählen
' If lbl.Caption "" Then zo = zo + 1 ' wenn Text vorhanden, dann Zähler zo _
plus 1
Next lbrg ' Wendepunkt für Schleife
ComboBox11.Value = Me.ComboBox4.Value + 1 ' 1. Tabellenzeile vorschlagen
' Spalte für Bemerkung vorschlagen
sp = ActiveCell.SpecialCells(xlLastCell).Column + 1 ' erste freie Spalte
we = sp Mod 26 ' Wert für Spaltenbuchstaben berechnen
If we = 0 Then we = 26 ' Fehlerkorrektur
If sp > 26 Then ComboBox10.Value = Chr(Int(sp / 26) + 64) ' ersten Buchstaben berechnen und _
eintragen
ComboBox10.Value = ComboBox10.Value & Chr(we + 64) ' zweiten Buchstaben berechnen und _
eintragen
End Sub
Private Sub ComboBox9_Change()
' Aktiviert das ausgewählte Tabellenblatt
Worksheets(ComboBox9.Text).Activate ' Tabellenblatt aktivieren
End Sub
Private Sub CommandButton1_Click()
' Schließt das UserForm ohne seine Inhalte zu löschen
DoppelteDaten.Hide
End Sub
Private Sub CommandButton2_Click()
' vergleicht Datensätze innerhalb einer Tabelle auf Duplikate
' geschrieben von Klaus-Dieter Oppermann (2005)
' Variablen deklarieren
Dim s As Long ' Schleifenzähler
Dim t As Long ' Schleifenzähler
Dim strg As String ' Werte für Array
Dim arr As Variant ' Array für Vergleichswerte
Dim arr2 As Variant ' Array für Bemerkungen
Dim az As Integer ' Marker für Vergleichssplaten
Dim obj As Object ' Formularobjekte
Dim endtab As Integer ' Tabellenende
Dim starttab ' Erste Tabellenzeile
starttab = Me.ComboBox11.Value ' Erste Zeile ermitteln
spa = "" ' Variableninhalt löschen
endtab = ActiveCell.SpecialCells(xlLastCell).Row ' Tabellenende ermitteln
ReDim arr(endtab) ' Array für Vergelichswerte
ReDim arr2(endtab, 0) ' Array für Bemerkungen
For s = starttab To endtab ' Laufe von 1. Zeile bis Tabellenende
For Each obj In Me.Controls ' durchlaufe alle Objekte
If Left(TypeName(obj), 8) = "CheckBox" Then ' wenn Objekt = Kontrollkästchen, dann . _
If obj.Value = True Then ' ... prüfe ob aktiviert, wenn ja, dann _
az = Right(obj.Name, Len(obj.Name) - 8) ' ... Objektnummer in Variable az
strg = strg & Cells(s, az) ' ... Zellinhalt(e) der gewählten _
Spalte(n) in Variable
End If ' Ende der Bedingung
End If ' Ende der Bedingung
Next obj ' nächstes Objekt
arr(s - 2) = strg ' Variable in in Array
strg = "" ' Variableninhalt löschen
Next s ' Schleifenzähler plus 1
' Duplikate suchen
For s = starttab To endtab ' gehe von Zeile 2 bis Tabellenende
For t = starttab To endtab ' gehe von Zeile 2 bis Tabellenende
If arr2(s - 2, 0) = "Duplikat" Then Exit For ' wenn Duplikat bereits festgestellt, _
dann Ausstieg
If s t Then ' wenn s ungleich t, dann ...
If arr(s - 2) = arr(t - 2) Then arr2 _
(t - 2, 0) = "Duplikat" ' ... vergleichen, wenn gleich, dann _
Text Duplikat in Array schrieben
End If ' Ende Bedingung
Next t ' Schleifenzähler plus 1
Next s ' Schleifenzähler plus 1
Range(Me.ComboBox10.Text & 2, Me.ComboBox10.Text & _
endtab) = arr2 ' Bemerkung(en) (Duplikat) in Spalte _
eintragen
Range(Me.ComboBox10.Text & 2, Me.ComboBox10.Text & _
endtab).HorizontalAlignment = xlRight ' Textausrichtung auf rechts
For Each obj In Me.Controls ' durchlaufe alle Objekte
If Left(TypeName(obj), 8) = "CheckBox" Then ' wenn Objekt = Kontrollkästchen, dann . _
If obj.Value = True Then ' ... prüfe ob aktiviert, wenn ja, dann _
spa = spa & Chr(Right(obj.Name, Len _
(obj.Name) - 8) + 64) & " " ' ... Spaltenbezeichnung und _
Leerzeichen in Variable
End If ' Ende der Bedingung
End If ' Ende der Bedingung
Next obj ' Nächstes Objekt aufrufen
Cells(Me.ComboBox4.Value, ActiveCell.SpecialCells _
(xlLastCell).Column) = spa ' Bezeichnung(en) der geprüften Spalten _
in Überschriftenzeile einfügen
End Sub
Private Sub CommandButton3_Click()
' Doppelte Datensätze löschen
' geschrieben von Klaus-Dieter Oppermann (2005)
' Variablen deklarieren
Dim sz As Long ' Schleifenzähler für Zeilen
Dim ant As String ' Meldung für MsgBox
ant = MsgBox(prompt:= _
"Die Daten(sätze) werden unwiederruflich gelöscht " _
& Chr(10) & "Ist das beabsichtigt?", Buttons:= _
vbYesNo + vbExclamation, Title:= _
"Warnung! © Klaus-Dieter Oppermann") ' MsgBox ausgeben
If ant = vbNo Then Exit Sub ' wenn Button nein betätigt, dann _
Ausstieg
For sz = ActiveCell.SpecialCells(xlLastCell).Row _
To Me.ComboBox11.Value Step -1 ' laufe von letzter Zeile zum _
Tabellenanfang
If Cells(sz, ActiveCell.SpecialCells(xlLastCell) _
.Column) = "Duplikat" Then ' wenn Bemerkung = Duplikat, dann ...
Rows(sz).Delete Shift:=xlUp ' ... Tabellenzeile löschen
End If ' Ende der Bedingung
Next sz ' Schleifenzähler plus 1
End Sub
Private Sub UserForm_Initialize()
' Startparameter an UserForm übergeben
' geschrieben von Klaus-Dieter Oppermann (2005)
' Variablen deklarieren
Dim AM As Object ' Arbeitsmappen
Dim s As Integer ' Schleifenzähler
DoppelteDaten.Caption = "Doppelte Daten suchen © Klaus-Dieter _
Oppermann" ' Titel festlegen
' Arbeitsmappennamen in ComboBox1 einlesen
For Each AM In Application.Workbooks ' suche geöffnete Arbeitsmappen
With ComboBox1 ' ComboBox1 öffnen
.AddItem AM.Name ' Name zufügen
End With ' Ende der Bedingung
Next AM ' nächste Arbeitsmappe suchen
' Buchstaben in ComboBox10 einlesen
For s = 1 To 26 ' laufe von 1 bis 26
With ComboBox10 ' öffne ComboBox
.AddItem Chr(s + 64) ' schreibe Buchstaben von A bis Z
End With ' Ende der Bedingung
Next s
' Zahlen in ComboBox 4 und ComboBox 11
For s = 1 To 25 ' laufe von 1 bis 25
With ComboBox4 ' öffne ComboBox 4
.AddItem s ' schreibe Zahlen von 1 bis 25
End With ' Ende der Bedingung
With ComboBox11 ' öffne ComboBox 11
.AddItem s ' schreibe Zahlen von 1 bis 25
End With ' Ende der Bedingung
Next s ' Schleifenzähle plus 1
' Schaltflächen beschriften und formatieren
With CommandButton2 ' Parameter an Schaltfläche 1 übergeben _
.Caption = "Daten vergleichen" ' ... Text eintragen
.Font.bold = True ' ... Schriftart = Fett
.ForeColor = &HFF0000 ' ... Schriftfarbe = blau
.Left = 244 ' ... Position linke Seite
End With ' Ende Parameter übergeben
With CommandButton1 ' Parameter an Schaltfläche 2 übergeben _
.Caption = "Formular schließen" ' ... Text eintragen
.Font.bold = True ' ... Schriftart = Fett
.ForeColor = &HFF& ' ... Schriftfarbe = rot
.Left = 134 ' ... Position linke Seite
End With ' Ende Parameter übergeben
With CommandButton3 ' Parameter an Schaltfläche 2 übergeben _
.Caption = "Doppelte Datensätze löschen" ' ... Text eintragen
.WordWrap = True ' ... Zeilenumbruch einschalten
.Font.bold = True ' ... Schriftart = Fett
.ForeColor = &HFF& ' ... Schriftfarbe = rot
.Left = 24 ' ... Position linke Seite
End With ' Ende Parameter übergeben
End Sub
Du brauchst im UserForm fünf ComboBoxen mit den Namen ComboBox1, ComboBox9, ComboBox 4, ComboBox11 und ComboBox10. Sowie drei Schaltflächen mit den Namen CommandButton3, CommandButton1 und CommandButton2.
Viele Grüße Klaus-Dieter
Online-Excel