Kopieren mit Spaltenüberschriften

[luna101]

Hallo ihr fleissigen Hellfer
Ich stehe wieder mal vor einem für mich unlösbaren Problem.
Ich kopiere in meiner Tabelle Daten von Spalte "AD7:AD" nach Spalte "BU7:BU".
Das funktioniert, wenn die Daten immer in der gleichen Spalte stehen.
Leider ist dies nicht immer der Fall. Darum möchte ich über die Spaltenüberschriften kopieren.
Wie muss ich das Makro ändern, dass anstelle der Spalte "BU7:BU" die Überschrift "Geburtsdatum"
verwendet wird?

Sub Daten_Ersetzen()
' Geburts Datum
Dim Monate, i&
Dim cell As Range
Dim rng As Range
Dim lastRow As Long
lastRow = Cells(Rows.Count, "BU").End(xlUp).Row
Monate = Application.GetCustomListContents(3)
Set rng = Sheets("Tabelle1").Range("BU7:BU" & lastRow)  ' "BU7:BU" ändern auf Spaltenüberschrift "Geburtsdatum"
Set rng = Sheets("Tabelle1").Range("AD7:AD" & lastRow)  '  "AD7:AD" nicht ändern da sich die Spalte nie ändert.
Sheets("Tabelle1").Range("BU7:BU" & lastRow).Copy rng  ' "BU7:BU"ändern auf Spaltenüberschrift "Geburtsdatum"
With rng.SpecialCells(xlCellTypeConstants)

  .Replace " ", ".", xlPart

  For i = 1 To 12
    .Replace Monate(i), Format(i, "00")
  Next
End With
For Each cell In rng
cell = Replace(cell, "BEF.", "vor ")
cell = Replace(cell, "BEF..", "vor ")
cell = Replace(cell, "AFT.", "nach ")
cell = Replace(cell, "AFT..", "nach ")
cell = Replace(cell, "ABT.", "um ")
cell = Replace(cell, "ABT..", "um ")
If Mid(cell, 2, 1) = "." Then cell = "0" & cell
Next
End Sub


PS: ich weis zuerst: Formel, Zeilen markieren, Auswahl erstellen, Oberste Zeile usw.
Hoffe auf eure Hilfe.
Gruss Martin

[ralf_b]

Set rng = Sheets("Tabelle1").Range("BU7:BU" & lastRow)  ' "BU7:BU" ändern auf Spaltenüberschrift "Geburtsdatum"
Set rng = Sheets("Tabelle1").Range("AD7:AD" & lastRow)  '  "AD7:AD" nicht ändern da sich die Spalte nie ändert.
Sheets("Tabelle1").Range("BU7:BU" & lastRow).Copy rng  ' "BU7:BU"ändern auf Spaltenüberschrift "Geburtsdatum"
....

Warum überschreibst du rng? Damit wird die erste Zeile überflüssig.

versuchs mal damit.
Dim lsecondGeb
lsecondGeb = Application.Match("Geburtsdatum", Sheets("Tabelle1").Rows(6), 1)
Sheets("Tabelle1").Cells(lsecondGeb, 7).Resize(lastRow - 7).Copy Rng

[luna101]

Guten Tag ralf_b,
danke für deine Hilfe. Leider bringt es einen Laufzeisfehler:1004
Habe mal die Mappe beigelegt. Bitte um nochmalige Hilfe.
Gruss Martin

PS: werde dann versuchen Hochzeits- und Todesdatum selber zu bereinigen

[ralf_b]

Ich kopiere in meiner Tabelle Daten von Spalte "AD7:AD" nach Spalte "BU7:BU".

Aber 

Set rng = Sheets("Tabelle1").Range("AD7:AD" & lastRow)  '  "AD7:AD" nicht ändern da sich die Spalte nie ändert.
Sheets("Tabelle1").Range("BU7:BU" & lastRow).Copy rng  ' "BU7:BU"ändern auf Spaltenüberschrift "Geburtsdatum"

macht genau das Gegenteil

Würdest du dich da bitte festlegen?
Und die Spalte "Geburts Datum" ist nicht das Gleiche wie die Spalte "Geburtsdatum".  
Ich habe aber auch einen Patzer drin gehabt. deshalb hier mal ein aktualisierter Vorschlag. kopiert wird von BU nach AD

Code:

Dim lsecondGeb
lastRow = Cells(Rows.Count, "BU").End(xlUp).Row
Monate = Application.GetCustomListContents(3)
Set rng = Sheets("Tabelle1").Range("AD7:AD" & lastRow)
lsecondGeb = Application.Match("Geburtsdatum", Sheets("Tabelle1").Rows(6), 0)
Sheets("Tabelle1").Cells(7, lsecondGeb).Resize(lastRow - 7).Copy rng

[luna101]

Guten morgen ralf_b
Danke für deine Makroanpassung.
Ja es wird von "BU" nach "AD" kopiert. Entschuldigung.
Dein Makro funktioniert, was das kopieren betrifft.
Es sollte aber anschliessend noch die (exotischen) Datum
in Spalte "AD" umwandeln. (zB. 4 JAN 1600 nach 4.01.1600)
Besser wäre noch es könnte nach 04.01.1600 umwandeln.
Gruss Martin

[ralf_b]

probier mal das aus. Solle alle drei Datenspalten übernehmen und umwandeln. ungetestet

Code:

Sub Daten_Ersetzen()

    Dim lsecondGeb
    Dim sSuche(3)
    Dim sWort
    Dim Monate
   
    lastRow = Cells(Rows.Count, "BU").End(xlUp).Row
    Monate = Application.GetCustomListContents(3)


    sSuche(0) = Array("Geburtsdatum", "AD")
    sSuche(1) = Array("Hochzeitsdatum", "AF")
    sSuche(2) = Array("Todesdatum", "AH")
   
    lastrow = lastRow - 7 + 1
    With Worksheets("Tabelle1")
        For Each sWort In sSuche
            lsecondGeb = Application.Match(sWort(0), .Rows(6), 0)
            .Range(sWort(1) & "7").Resize(lastRow ) = .Cells(7, lsecondGeb).Resize(lastRow )
           
            Set rng = .Range(sWort(1) & "7").Resize(lastRow ).SpecialCells(xlCellTypeConstants)
            rng.Replace " ", ".", xlPart
            For i = 1 To 12
                rng.Replace Monate(i), Format(i, "00")
            Next
           For Each cell In rng
            cell = Replace(cell, "BEF.", "vor ")
            cell = Replace(cell, "BEF..", "vor ")
            cell = Replace(cell, "AFT.", "nach ")
            cell = Replace(cell, "AFT..", "nach ")
            cell = Replace(cell, "ABT.", "um ")
            cell = Replace(cell, "ABT..", "um ")
            If Mid(cell, 2, 1) = "." Then cell = "0" & cell
          Next
        Next
    End With

End Sub

[luna101]

Hallo ralf_b
leider bringt es bei

Set rng = .Range(sWort(1) & "7").Resize(lastRow).SpecialCells(xlCellTypeConstants)

ein Debugg Fehler.
Gruss Martin

[ralf_b]

neuer versuch

Code:

Sub Daten_Ersetzen()

    Dim lsecondGeb
    Dim sSuche(2)
    Dim sWort
    Dim Monate
  
   
    Monate = Application.GetCustomListContents(3)


    sSuche(0) = Array("Geburtsdatum", "AD")
    sSuche(1) = Array("Heiratsdatum", "AF")
    sSuche(2) = Array("Todesdatum", "AH")
  
   
    With Worksheets("Tabelle1")
        lastRow = .Cells(.Rows.Count, "BU").End(xlUp).Row
        lastRow = lastRow - 7
        For Each sWort In sSuche
            lsecondGeb = Application.Match(sWort(0), .Rows(6), 0)
            .Range(sWort(1) & 7).Resize(lastRow).Value = .Cells(7, lsecondGeb).Resize(lastRow).Value
          
            Set rng = .Range(sWort(1) & "7").Resize(lastRow)
            rng.Replace " ", ".", xlPart
            For i = 1 To 12
                rng.Replace Monate(i), Format(i, "00")
            Next
           For Each cell In rng
            cell = Replace(cell, "BEF.", "vor ")
            cell = Replace(cell, "BEF..", "vor ")
            cell = Replace(cell, "AFT.", "nach ")
            cell = Replace(cell, "AFT..", "nach ")
            cell = Replace(cell, "ABT.", "um ")
            cell = Replace(cell, "ABT..", "um ")
            If Mid(cell, 2, 1) = "." Then cell = "0" & cell
          Next
        Next
    End With

End Sub

[luna101]

Hallo ralf_b
Danke fur deine Mühe mir zu helfen.
Es fehlt nur noch das Umwandeln von
"BEF", "AFT" usw. nach "vor ", "nach ", usw.
Gruss Martin

[ralf_b]

das steht doch im code drin. hat das vorher nicht funktioniert?