Macro- Excel to copy cell content highlighted

Hello Everyone,

I'm unable to write any thing on a macro assigned button. I'm trying to copy the content from a highlighted cell but i'm unable to do so. Does any one have any idea about it? Kindly help me out.

Thanks a lot.

Users of Excel 2000 can take advantage of the new Conditional Formatting option. Let's cover how to do this manually without a macro first.

• Move to cell C1.
• From the menu, choose Format, Conditional Format
• In the left side of the dialog, change the drop down to read "Formula is"
• In the right side of the dialog box, enter: =INT(C1)=TODAY(=INT(C1)=TODAY)

• Click format, Click Patterns, pick Red. Click OK
• Click Add
• In the left side of the dialog, change the drop down to read "Formula is"
• In the right side of the dialog box, enter:=AND(INT(C1)>TODAY(),(INT(C1)-TODAY())<16)
• Click Format, Click Patterns, Pick Yellow. Click OK.
• Click OK to finish assigning this conditional format to cell C1.

If the format is entered correctly, cell C1 will change to red if it contains today's date and to yellow if the date is in the next 15 weeks. The TODAY() function in the format will insure that if we open the workbook on another day, it will highlight in red the cells for that particular day.

You can now copy cell C1, highlight all of the data in column C and do Edit--> Paste Special--> Formats--> OK to apply that format to each cell in column C.

Just try to follow the below steps.

Sub CopyData()
Dim cell As Range, rng As Range
Dim sh As Worksheet
With Worksheets("Data")
Set rng = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
End With
For Each cell In rng
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
' assume the name for the row/sheet is in column 1 (col A)
ActiveSheet.Name = cell.Value
Set sh = ActiveSheet
' modified since it appears you are copying to row 2
cell.EntireRow.Copy sh.Rows(2)
For Each cell1 In sh.Range("B2:H2")
cell1.EntireColumn.Hidden = (cell1.Value = 0)
Next
Next
End Sub

It worked for me.:thumbup1:

You can also try out the following steps.

Sub HighlightServers()
Dim wb As Workbook, ws As Worksheet, sh As Worksheet, sd As Date, i As Long
Dim rng As Range, cel As Range, cel_f As Range, ws1 As Worksheet, ws2 As Worksheet
Dim Message As String, Response As Long
Const Title = "Backup Server Report Error"
Const sDateFormat = "mm-dd-yy" ' < Change this to fit sheet name format...
Const lColumnCheck = 1 ' < Change this for a different column check...

Set wb = ActiveWorkbook
Set ws = ActiveSheet

On Error Resume Next
sd = CDate(ws.Name)
If Err.Number <> 0 Then
Message = "Active sheet name is not in a date format. Exiting routine..."
Response = MsgBox(Message, vbOKOnly + vbCritical, Title)
Exit Sub
End If
On Error GoTo 0

For i = 1 To 2
If Not (SheetExists(Format(sd - i, sDateFormat))) Then
Message = "Sheet: " & Format(sd - i, sDateFormat) & " does not exist. Exiting routine..."
Response = MsgBox(Message, vbOKOnly + vbCritical, Title)
Exit Sub
End If
Next i

Set ws1 = wb.Sheets(Format(sd - 1, sDateFormat))
Set ws2 = wb.Sheets(Format(sd - 2, sDateFormat))

Set rng = Intersect(ws.UsedRange, ws.Columns(lColumnCheck))

For Each cel In rng

Set cel_f = Intersect(ws1.UsedRange, ws1.Columns(lColumnCheck)) _
.Find(What:=cel.Value, lookat:=xlWhole)
If Not cel_f Is Nothing Then
cel.Interior.Color = vbYellow
End If

Set cel_f = Intersect(ws2.UsedRange, ws2.Columns(lColumnCheck)) _
.Find(What:=cel.Value, lookat:=xlWhole)
If Not cel_f Is Nothing Then
cel.Interior.Color = vbRed
End If

Next cel

End Sub