Datum kopieren und modifizieren (Ahnenforscher Datum)

[snb]

Code:

Sub M_snb()
  For j = 0 To 2
    Tabelle1.Columns(30).Replace Array("vor", "nach", "um")(j), Array("BEF", "AFT", "ABT")(j)
  Next
  sn = Cells(7, 30).CurrentRegion

  For j = 2 To UBound(sn)
    If InStr(sn(j, 1), ".") Then sn(j, 1) = Mid(Format(Format(Replace(sn(j, 1), ".", "/"), "d MMM yyyy"), ">"), 1 - 2 * (Len(sn(j, 1)) = 7))
  Next
  
  Tabelle1.Cells(6, 78).Resize(UBound(sn)) = sn
End Sub

[luna101]

Hallo Uwe
- lichen das Makro ist
Werde das Makro in die Original Datei einzufügen.
Hoffe ich schaff das.

Eine kleine Bitte hätte ich noch. Könnte man die Anweisung
        If Left(Range("BT" & i), 1) = "0" Then Range("BT" & i) = Mid(Range("BT" & i), 2, 20)
auch noch ändern zu
        If Left(.Cells(i, k) .........

Vorerst nochmal herzlichen Dank
Gruss Martin

---

Guten Abend Helmut
Auch dir lichen  werde es mal
und testen. Sieht sehr übersichtlich aus.
Nochmals Danke und Gruss
Martin

---

Guten Abend snb
Auch Dir herzlichen Dank für Das Makro.
Werde es studieren und testen.
Wünsche noch ein schönes Wocheende.
Gruss Martin

[Egon12]

Hallo Martin,

diese Befehlszeile hat dir jemand anderes hinterlassen und dabei vergessen das dazueghörige Tabellenblatt dem Range zuzuweisen.
Wenn es funktioniert dann eigentlich nur zufällig, wenn das dazugehörige Tabellenblatt aktiv ist.
Ich vermute mal, dass es so sein sollte:

Code:

If Left(.Range("BT" & i), 1) = "0" Then .Range("BT" & i) = Mid(.Range("BT" & i), 2, 20)

das Ganze mit .Cells() ungetestet:

Code:

If Left(.Cells(i, 72), 1) = "0" Then .Cells(i, 72) = Mid(.Cells(i, 72), 2, 20)

Ich hoffe es ist kein Tippfehler drin.

Gruß Uwe

[snb]

Vermeide womöglich in VBA jede Interaktion mit dem Arbeitsblatt.

Lese Daten in Arrays.
Bearbeite diese Array
Schrerbe mal das Ergebnis ins Arbeitsblatt.

Normalerweise braucht du nur 2 Interaktionen:
- einmal lesen
- einmal schreiben

Alles andere geschieht im Arbeitsspeicher.

[luna101]

Guten Abend snb,
danke für die Info. Bin immer noch am Testen. Wenn dann alles funktioniert,
werde ich das ganze Überarbeiten und da sind Deine Vorschläge sicher hilfreich.
Wünsche noch ein guter Start in die neue Woche.
Gruss Martin

---

Guten abend Uwe,
danke für die Bereinigng der Schleife "If Left(.Cells(i, 72), 1) = "0" Then .Cells(i, 72) = Mid(.Cells(i, 72), 2, 20)"
Habe die Spalten "72" durch "j" ersetzt und bin nun nicht mehr Spaltennummer abhängig.

Folgendes  ist mir beim Testen aufgefallen:

Wenn ich bei einer Datumeingabe in eine Zelle die Spalte nicht auf der gleiche Zeile verlasse, wird kein Eintrag kopiert.
Wenn ich als Datum 12.12.1212 eingebe wird der Eintrag nicht kopiert.

Wenn das noch bereingt werden könnte, wäre es supper.
Wünsche noch ein guter Start in die neue Woche.
Gruss Martin

[Egon12]

Hallo Martin,

das liegt daran, dass aus der selektierten Zelle die Zeilennummer ausgewertet wird. Im Klartext:
Worksheet_Change feuert bei jeder Änderung im Tabellenblatt unter der Voraussetzung, dass in einer Zelle etwas stattfand (Änderung/Selektierung).

Man könnte in einer Schleife nach jedem Eintrag alles abklappern und die Änderungen zurückschreiben. Dann wäre es sinnvoll dies via Array zu erledigen. Recourcenfreundlich ist das aber nicht (deshalb mit Array), da mit jeder Änderung die Schleife durchlaufen wird.
dann in etwa so:

Code:

Sub Datum1()
    Dim i&, j&, k&, lz&, Spalte1 As Range, Spalte2 As Range, arrDatum()
    'Geburts Datum
    With Tabelle1
        Set Spalte1 = .Rows(6).Find("Geburt-Datum")
        If Not Spalte1 Is Nothing Then k = Spalte1.Column
        Set Spalte2 = .Rows(6).Find("Geburt.-.Datum")
        If Not Spalte2 Is Nothing Then j = Spalte2.Column
        lz = .Cells(Rows.Count, k).End(xlUp).Row
        ReDim arrDatum(1 To lz - 6)
        For i = 1 To lz - 6
            If Len(.Cells(i + 6, k)) = 4 Then arrDatum(i) = .Cells(i + 6, k)
            If Len(.Cells(i + 6, k)) = 7 Then
                If Left(.Cells(i + 6, k), 2) = "01" Then
                    arrDatum(i) = "JAN " & Right(.Cells(i + 6, k), 4)
                End If
                If Left(.Cells(i + 6 + 6, k), 2) = "02" Then
                    arrDatum(i) = "FEB " & Right(.Cells(i + 6, k), 4)
                End If
                If Left(.Cells(i + 6, k), 2) = "03" Then
                    arrDatum(i) = "MRZ " & Right(.Cells(i + 6, k), 4)
                End If
                If Left(.Cells(i + 6, k), 2) = "04" Then
                    arrDatum(i) = "APR " & Right(.Cells(i + 6, k), 4)
                End If
                If Left(.Cells(i + 6, k), 2) = "05" Then
                    arrDatum(i) = "MAI " & Right(.Cells(i + 6, k), 4)
                End If
                If Left(.Cells(i + 6, k), 2) = "06" Then
                    arrDatum(i) = "JUN " & Right(.Cells(i + 6, k), 4)
                End If
                If Left(.Cells(i + 6, k), 2) = "07" Then
                    arrDatum(i) = "JUL " & Right(.Cells(i + 6, k), 4)
                End If
                If Left(.Cells(i + 6, k), 2) = "08" Then
                    arrDatum(i) = "AUG " & Right(.Cells(i + 6, k), 4)
                End If
                If Left(.Cells(i + 6, k), 2) = "09" Then
                    arrDatum(i) = "SEPT " & Right(.Cells(i + 6, k), 4)
                End If
                If Left(.Cells(i + 6, k), 2) = "10" Then
                    arrDatum(i) = "OKT " & Right(.Cells(i + 6, k), 4)
                End If
                If Left(.Cells(i + 6, k), 2) = "11" Then
                    arrDatum(i) = "NOV " & Right(.Cells(i + 6, k), 4)
                End If
                If Left(.Cells(i + 6, k), 2) = "12" Then
                    arrDatum(i) = "DEZ " & Right(.Cells(i + 6, k), 4)
                End If
            Else
                If Mid(.Cells(i + 6, k), 4, 2) = "01" Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " JAN " & Right(.Cells(i + 6, k), 4)
                End If
                If Mid(.Cells(i + 6, k), 4, 2) = "02" Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " FEB " & Right(.Cells(i + 6, k), 4)
                End If
                If Mid(.Cells(i + 6, k), 4, 2) = "03" Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " MRZ " & Right(.Cells(i + 6, k), 4)
                End If
                If Mid(.Cells(i + 6, k), 4, 2) = "04" Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " APR " & Right(.Cells(i + 6, k), 4)
                End If
                If Mid(.Cells(i + 6, k), 4, 2) = "05" Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " MAI " & Right(.Cells(i + 6, k), 4)
                End If
                If Mid(.Cells(i + 6, k), 4, 2) = "06" Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " JUN " & Right(.Cells(i + 6, k), 4)
                End If
                If Mid(.Cells(i + 6, k), 4, 2) = "07" Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " JUL " & Right(.Cells(i + 6, k), 4)
                End If
                If Mid(.Cells(i + 6, k), 4, 2) = "08" Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " AUG " & Right(.Cells(i + 6, k), 4)
                End If
                If Mid(.Cells(i + 6, k), 4, 2) = "09" Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " SEPT " & Right(.Cells(i + 6, k), 4)
                End If
                If Mid(.Cells(i + 6, k), 4, 2) = "10" Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " OKT " & Right(.Cells(i + 6, k), 4)
                End If
                If Mid(.Cells(i + 6, k), 4, 2) = "11" Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " NOV " & Right(.Cells(i + 6, k), 4)
                End If
                If Mid(.Cells(i + 6, k), 4, 2) = "12 " Then
                    arrDatum(i) = Left(.Cells(i + 6, k), 2) & " DEZ " & Right(.Cells(i + 6, k), 4)
                End If
            End If
' .............Der folgende Eintrag ändert die Tage 01  bis 09 nach 1 bis 9 .........
            If Left(.Cells(i + 6, j), 1) = "0" Then arrDatum(i) = Mid(.Cells(i + 6, j), 2, 20)
            If Left(.Cells(i + 6, k), 4) = "vor " Then
                arrDatum(i) = "BEF " & Right(.Cells(i + 6, k), 4)
            End If
            If Left(.Cells(i + 6, k), 5) = "nach " Then
                arrDatum(i) = "AFT " & Right(.Cells(i + 6, k), 4)
            End If
            If Left(.Cells(i + 6, k), 3) = "um " Then
                arrDatum(i) = "ABT " & Right(.Cells(i + 6, k), 4)
            End If
            .Cells(i + 6, j) = arrDatum(i)
        Next i
    End With
End Sub

Ps.: das Ganze geht natürlich auch mit Select Case zu lösen. Ist eh dann nur noch eine Fleißaufgabe - dazu hatte ich keine Lust mehr, denn jetzt gibts ein wohlverdientes Adventsbier.

Gruß Uwe

[HKindler]

Hi,

das Ganze geht natürlich auch komplett ohne If-Orgie oder Select - siehe meinen letzten Beitrag oder auch den von snb.

Wozu belegts du eine Variable j nur um sie dann niemals zu verwenden?

Was passiert wohl, wenn k nicht gesetzt wird (weil die Spalte "Geburt-Datum" nicht gefunden wurde) und damit 0 ist?

[Egon12]

@ Helmut
 
vielen Dank für die Hinweise. Hab grad noch mal in den Code geschaut - j wird aber verwendet. Ja wenn die Spalte nicht vorhanden ist braucht es noch eine Fehlerbhandlung. Naja was snb hinterlassen hat ist zwar kurz aber es fußt auf Spaltennummern, was vom TO später überhaupt nicht mehr gewollt war. Er wollte sich damit das Einfügen weiterer Spalten in seinem Projekt offenhalten. Die Ausgabe in die gleiche Zelle war auch nicht gefragt. Versteht das bitte nicht als Kritik, sondern ebenfalls nur als Hinweis.
 
Allen ein paar besinnliche Stunden in der Adventszeit und Frohe Weihnachten.
 
Gruß Uwe

[HKindler]

Hi Uwe,

sorry das j in den letzten Zeilen hatte ich übersehen. Allerdings gilt da dann dasselbe wie bei k.

Und beim Code von snb gilt wie immer bei ihm: es wird das Prinzip verdeutlicht. Seine Codes sind eigentlich nie darfür geeignet unverändert eingesetzt zu werden.

Statt If oder Select ist es halt eleganter die Monatsnamen direkt zu berechnen. Und snb hat gezeigt, wie man die Zeiträume ersetzen kann.

Übrigens: die If-Orgie wäre schneller, wenn man mit Else arbeiten würde. Würde im Mittel 50% Zeit sparen, da das If beendet wird, sobald ein Treffer gefunden wurde (also ähnlch Select).

Code:

If Left(.Cells(i + 6, k), 2) = "01" Then
                    arrDatum(i) = "JAN " & Right(.Cells(i + 6, k), 4)
                ElseIf Left(.Cells(i + 6 + 6, k), 2) = "02" Then
                    arrDatum(i) = "FEB " & Right(.Cells(i + 6, k), 4)
                ElseIf ...
                    ...
                End If

Wenn man dann noch den Inhalt der Zelle zuerst einer Variablen zuweist und diese dann prüft, dann ist man im Grunde bei der Geschwindigkeit von Select (ca. 92% schneller bzw. man braucht nur 1/12 der Zeit)

Code:

Dim s As Variant
...
                s = Left(.Cells(i + 6, k), 2)
                If s = "01" Then
                    arrDatum(i) = "JAN " & Right(.Cells(i + 6, k), 4)
                ElseIf s = "02" Then
                    arrDatum(i) = "FEB " & Right(.Cells(i + 6, k), 4)
                ElseIf ...
                    ...
                End If

[snb]

@Egon

Verzichte auf:
- Objectvariabelen, wenn das Object unmittelbar in VBA ermittelbar ist.
- überflüssige Variabelen.

Die Struktur deines Codes könnte so aussehen:
nur 2 Variabelen: ein Array  sn , 1 counter j

Code:

Sub M_Struktur()
  sn = Tabelle1.Rows(6).Find("Geburt-Datum").Offset(1).Resize(Rows.Count - 7).SpecialCells(2)
   
  For j = 1 To UBound(sn)
      ----
  Next

  Tabelle1.Rows(6).Find("Geburt.-.Datum").Offset(1).Resize(UBound(sn)) = sn
End Sub