Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1564to1568
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Datum in neue Spalte kopieren

Datum in neue Spalte kopieren
21.06.2017 16:57:54
Horst
Hallo,
ich bräuchte bitte eine Hilfe bei einem Makroproblem.
Ich habe in einer Spalte B einmal ein Datum, dann darunter Mitarbeiter. Dann eine Leerzeile. Dann kommt das nächste Dat um und wieder die Mitarbeiter.
Ich hätte nun gerne per Makro folgendes gelöst:
Schreibe das Datum in die noch leere Spalte A vom ersten Mitarbeiter bis zum letzten Mitarbeiter in diesem Bereich, dann wiederhole diese Schritte solange, bis in Spalte B kein Mitarbeiter mehr steht.
Beispiel
Spalte B
1.3.2017
Mitarbeiter A
Mitarbeiter B
Mitarbeiter C
1.2.2017
Mitarbeiter A
Mitarbeiter B
Mitarbeiter C
1.1.2017
Mitarbeiter A
Mitarbeiter B
Mitarbeiter C
Aussehen sollte es dann so:
Spalte A Spalte B
1.3.2017 Mitarbeiter A
1.3.2017 Mitarbeiter B
1.3.2017 Mitarbeiter C
1.2.2017 Mitarbeiter A
1.2.2017 Mitarbeiter B
1.2.2017 Mitarbeiter C
1.1.2017 Mitarbeiter A
1.1.2017 Mitarbeiter B
1.1.2017 Mitarbeiter C
Bitte um eure Unterstützung!
Vielen Dank!

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Datum in neue Spalte kopieren
21.06.2017 17:30:56
UweD
Hallo
so?
Sub MA()
On Error GoTo Fehler
Dim Datum As Date, i As Double
Dim LR As Double
With Sheets("Tabelle1")
LR = .Cells(.Rows.Count, "B").End(xlUp).Row 'letzte Zeile der Spalte
For i = 1 To LR
If IsDate(.Cells(i, 2)) Then
Datum = .Cells(i, 2)
.Cells(i, 2).ClearContents
ElseIf .Cells(i, 2)  "" Then
.Cells(i, 1) = Datum
End If
Next
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
.SetRange Range("A1:B" & LR)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'*** Fehlerbehandlung
Err.Clear
On Error GoTo Fehler
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige