verheirates Paar erkennen

Next l wks2.Range("A:A").Clear wks2.Cells.Sort Key1:=wks2.Range("C2"), Order1:=xlAscending, Key2:=wks2.Range("E2") _ , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _ False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _ :=xlSortNormal For A = wks2.Range("B65000").End(xlUp).Row To 2 Step -1 If (wks2.Cells(A, 3) & wks2.Cells(A, 5)) = (wks2.Cells(A - 1, 3) & wks2.Cells(A - 1, 5)) Then wks2.Cells(A - 1, 4) = wks2.Cells(A - 1, 4) & IIf(InStr(1, wks2.Cells(A, 4), " und ") > 0, ", ", _ _ " und ") & wks2.Cells(A, 4) wks2.Rows(wks2.Cells(A, 3).Row).Delete Shift:=xlUp End If

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi
sorry ist jetzt keine Lösung, aber mal so als Anmerkung
wenn du die Ehepaare auf diese Weise herausfinden kannst, brauchst du schon etwas glück , denn
- heutzutage haben Ehepartner nicht zwingend den gleichen Nachnamen, jeder kann seinen Namen behalten
- Häufige Namen (Schmitt, Meier, Müller usw) können in einer Strasse ja öfters auftauchen, da müsstest du zumindest die Hausnummr mit prüfen, um nicht die Falschen miteinander zu Verheiraten. Bei Hochhäusern hilft dir noch nicht mal das.
- auch bei kleinen Wohneinheiten kommt es oft vor, daß die Kinder noch im gleichen Haus wohnen wie die Eltern, dh. auch hier ist die Hausnummer kein eindeutiger Hinweis.
also mir wär das Risiko zu gross, daß ich da mal die Falschen verheirate, dann lieber jedem seinen eigenen Brief geschickt.
zumindest solltest du bei jedem auf diese Weise gefundenen Paar auch prüfen obs auch wirklich so ist, bevor du es in deine Liste übernimmst.
Gruß, Daniel

Option Explicit Sub GetRelation() Dim i As Long, k As Long Dim varList(), varRel With Sheets("Tabelle1") For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row varRel = Application.Match(CLng(.Cells(i, 1)), .Columns(2), 0) If CLng(.Cells(i, 2)) = 0 Then ReDim Preserve varList(5, k) If IsError(varRel) Then varList(0, k) = .Cells(i, 3) 'Anrede varList(1, k) = .Cells(i, 5) 'Vorname Else varList(1, k) = _ .Cells(i, 5) & " und " & .Cells(varRel, 5) 'Vornamen End If varList(2, k) = .Cells(i, 4) 'Nachname varList(3, k) = .Cells(i, 8) 'Strasse varList(4, k) = .Cells(i, 6) 'PLZ varList(5, k) = .Cells(i, 7) 'Stadt k = k + 1 End If Next End With With Sheets("Tabelle2") .Cells.Delete .Range(.Cells(2, 1), .Cells(UBound(varList, 2) + 2, 6)) = Application.Transpose(varList) .Columns.AutoFit End With End Sub

Sub Übertrage_In_Neue() Dim wkb1 As Workbook Dim wks1 As Worksheet Dim wkb2 As Workbook Dim wks2 As Worksheet Dim myArray() Dim A As Long Dim l As Long Set wkb1 = ThisWorkbook Set wks1 = wkb1.Worksheets("Mitgliederliste") Application.ScreenUpdating = False l = 0 For A = 1 To wks1.CheckBoxes.Count If wks1.CheckBoxes(A) = 1 Then l = l + 1 ReDim Preserve myArray(l) myArray(l) = wks1.Rows(Cells(A + 7, 1).Row).Address End If Next A Set wkb2 = Workbooks.Add Set wks2 = wkb2.Worksheets("Tabelle1") wks1.Range("7:7").Copy wks2.Range("A1").PasteSpecial For l = 1 To UBound(myArray) wks1.Range(myArray(l)).Copy wks2.Range("a" & l + 1).PasteSpecial Next l wks2.Range("A:A").Clear wks2.Cells.Sort Key1:=wks2.Range("C2"), Order1:=xlAscending, Key2:=wks2.Range("E2") _ , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _ False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _ :=xlSortNormal For A = wks2.Range("B65000").End(xlUp).Row To 2 Step -1 If (wks2.Cells(A, 3) & wks2.Cells(A, 5)) = (wks2.Cells(A - 1, 3) & wks2.Cells(A - 1, 5)) _ Then wks2.Cells(A - 1, 4) = wks2.Cells(A - 1, 4) & IIf(InStr(1, wks2.Cells(A, 4), " und " _ ) > 0, ", ", _ " und ") & wks2.Cells(A, 4) wks2.Rows(wks2.Cells(A, 3).Row).Delete Shift:=xlUp End If Next A wks2.Cells.Columns.AutoFit wks2.Range("A1").Select Application.ScreenUpdating = True ActiveWorkbook.SaveAs Filename:="Liste.xls", FileFormat:=xlNormal ActiveWorkbook.Close End Sub

With Sheets("Tabelle1") For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row If .CheckBoxes(A) = 1 Then varRel = Application.Match(CLng(.Cells(i, 1)), .Columns(2), 0) If CLng(.Cells(i, 2)) = 0 Then '...usw

Hallo Daniel,
abgesehen vom Thema "Steuerelemente in einer Tabelle", stellt sich die Frage nach dem Handling.
Wenn du z.B. 150 von 300 Einträgen auswählen musst, dann wünsch ich viel Spaß...
Hier mein Ansatz:
Durch die CheckBoxes wird das ganze etwas komplexer, aber das Prinzip ist das gleiche.
- wie gehabt, den Bezug bei den "Männer" setzen, um den Vornamen der Frau zuerst aufzuführen.
- wie gehabt, nur ganze Zahlen in SpalteB und SpalteM.
- wenn von einem Paar nur ein Partner angewählt ist, wird nur dieser in die Liste übertragen.
Gib mir Bescheid, wie du damit parat kommst.
Grüße
Christian


Option Explicit
Sub CreateList()
Dim wkb As Workbook
Dim lngRows() As Long, varList(), varRel
Dim blnRel As Boolean, blnMale As Boolean, blnData As Boolean
Dim i As Long, j As Long, k As Long
ReDim lngRows(0)
With ThisWorkbook.Sheets("Mitgliederliste")
For i = 8 To .Cells(.Rows.Count, 2).End(xlUp).Row
blnRel = 0: blnMale = 0
If .Cells(i, 1) Then
varRel = IIf(.Cells(i, 13) = "", _
Application.Match(CLng(.Cells(i, 2)), .Columns(13), 0), _
Application.Match(CLng(.Cells(i, 13)), .Columns(2), 0))
blnMale = .Cells(i, 13)  ""
If IsError(Application.Match(i, lngRows, 0)) Then
ReDim Preserve varList(5, k)
blnData = True
If Not IsError(varRel) Then
If .Cells(varRel, 1) Then
blnRel = True
ReDim Preserve lngRows(j)
lngRows(j) = varRel
j = j + 1
End If
End If
If Not blnRel Then
varList(0, k) = .Cells(i, 14)                      'Anrede
varList(1, k) = .Cells(i, 4)                       'Vorname
Else
varList(1, k) = IIf(blnMale, _
.Cells(varRel, 4) & " und " & .Cells(i, 4), _
.Cells(i, 4) & " und " & .Cells(varRel, 4))     'Vornamen
End If
varList(0, k) = .Cells(i, 14)
varList(2, k) = .Cells(i, 3)                          'Nachname
varList(3, k) = .Cells(i, 5)                          'Strasse
varList(4, k) = .Cells(i, 6)                          'PLZ
varList(5, k) = .Cells(i, 7)                          'Stadt
k = k + 1
ReDim Preserve lngRows(j)
lngRows(j) = i
j = j + 1
End If
End If
Next
End With
If Not blnData Then
MsgBox "keine Auswahl getroffen", 48
Else
Application.ScreenUpdating = False
Set wkb = Workbooks.Add
With wkb.Worksheets(1)
.Range(.Cells(1, 1), .Cells(1, 6)) = _
Array("Anrede", "Vorname", "Nachname", "Strasse", "PLZ", "Stadt")
.Range(.Cells(2, 1), .Cells(UBound(varList, 2) + 2, 6)) = _
Application.Transpose(varList)
.Columns.AutoFit
End With
wkb.Close True, ThisWorkbook.Path & "\Liste.xls"
Application.ScreenUpdating = True
End If
End Sub

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

verheirates Paar erkennen

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread