Conditional Copy Macro

  • Thread starter Thread starter WBTKbeezy
  • Start date Start date
W

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.
 
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
 
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
 
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
 
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
 
Thanks everyone, these are perfect! (And yes, rick - that is exactly what I
needed, i don't care about the times!)
 
Back
Top