Conditional Copy Macro

[WBTKbeezy]

Hello:

I have a column of data that is a list of dates and times as a schedule.
Each date listed may have several times underneath it (i.e., 4/16/08 could
have 9:00AM, 10AM, 11AM underneath it). I would like to be able to
automatically erase the times and replace them with the date they fall under.
Each date may have anywhere from 0-5 times listed underneath them, but each
date is ALWAYS separated by one blank cell. Is there anyway to do this via a
macro?

Thanks.

 

[Rick Rothstein \(MVP - VB\)]

You said "I would like to be able to automatically erase the times and
replace them with the date..."; is this really what you want? Won't that
result in the same date listed 1 to 5 times with no time values show at all?

Rick

 

[Joel]

Change StartRow and MyColumn as required.

Sub change_time()

MyColumn = "A"
StartRow = 1

LastRow = Range(MyColumn & Rows.Count).End(xlUp).Row
NewDate = True
For RowCount = StartRow To LastRow
If Range(MyColumn & RowCount) = "" Then
NewDate = True
Else
If NewDate = True Then
MyDate = Range(MyColumn & RowCount)
NewDate = False
Else
Range(MyColumn & RowCount) = MyDate
End If
End If

Next RowCount

End Sub

 

[Dan R.]

Sub test()
lrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lrow
If InStr(1, Cells(i, 1), "/") > 0 Then
dn = Cells(i, 1).End(xlDown).Row
Cells(i, 1).AutoFill _
Destination:=Range("A" & i, "A" & dn), _
Type:=xlFillCopy
i = dn
End If
Next i
End Sub

 

[Per Jessen]

Hi

This will do what you need. Just change FirstCell to point at the cell in
the TargetArea and LastCell to point to the very last cell in Target column.

Sub ReplaceTime()
Dim TargetRange As Range
Dim StartDate As Date
Dim StartCell As String
Dim LastCell As String

Application.ScreenUpdating = False
StartCell = "A2"
LastCell = "A65536"

Set TargetRange = Range(StartCell, Range(LastCell).End(xlUp))

StartDate = Range(StartCell).Value
For Each r In TargetRange
If IsDate(r.Value) Then
tDate = r.Value
Else
If r.Value <> "" Then r.Value = tDate
End If
Next
Application.ScreenUpdating = True
End Sub

Regards,
Per

 

[WBTKbeezy]

Thanks everyone, these are perfect! (And yes, rick - that is exactly what I
needed, i don't care about the times!)