Michael,

The code below will work on subsequent trials. It will color any data
that was tranfered as green - my way, though not the only way - to
keep from double transferring data when you run it a second time. You
can change the colorindex = 4 lines (two places) to another color
that better pleases you. Note that you need to copy the function below
as well into your code module.

HTH,
Bernie
MS Excel MVP


Sub TryNow2()
Dim myCell As Range
Dim myRange As Range
Dim mySht As Worksheet
Dim mySrc As Worksheet
Dim myOrig As Worksheet
Dim myVal As String

Application.ScreenUpdating = False
Set myOrig = ActiveSheet
ActiveSheet.Copy Sheets(1)
Set mySrc = ActiveSheet
Set myRange = mySrc.Range("B2",
Range("B2").CurrentRegion.SpecialCells(xlCellTypeL astCell))
While Application.CountBlank(myRange) < myRange.Cells.Count
Set myRange = myRange.SpecialCells(xlCellTypeConstants, 2)
myVal = myRange(1).Value
If Not WorksheetExists(myVal) Then
Set mySht = Worksheets.Add
mySht.Name = myVal
Else
Set mySht = Worksheets(myVal)
End If
mySrc.Activate
mySht.Range("A:A").NumberFormat = "mm/dd/yyyy"
For Each myCell In myRange
If myCell.Value = myVal Then
If myCell.Interior.ColorIndex < 4 Then
With mySht.Range("A65536").End(xlUp)(2)
.Value = Cells(myCell.Row, 1).Value
.Offset(0, 1).Value = myCell.Value
myOrig.Range(myCell.Address).Interior.ColorIndex = 4
End With
End If
myCell.ClearContents
End If
Next myCell
mySht.Range("A:B").EntireColumn.AutoFit
Set myRange = mySrc.Range("B2:J3788")
Wend
Application.DisplayAlerts = False
mySrc.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Function WorksheetExists(wksName As String) As Boolean
Dim dummy_wks As Worksheet
On Error Resume Next
Set dummy_wks = Worksheets(wksName)
If Err = 0 Then
WorksheetExists = True
Else
WorksheetExists = False
End If
Set dummy_wks = Nothing
End Function



"Michael168" wrote in message
...
Hi! Bernie Deitrick,

Thanks for your fast help. A little problem exists. That is when I
run
the macro the second time, it gives me "run-time error 1004" stating
that "cannot rename a sheet to the same name as another sheet".
How to overcome this problem? I think all the newly created sheet
need
to be deleted before running. I need to run the macro at least on
daily
basic because the master record keep on updating daily.
Your modification help needed and appreciated.

Thank you.



------------------------------------------------
~~ Message posted from http://www.ExcelTip.com/
~~ View and post usenet messages directly from
http://www.ExcelForum.com/