Macro to do three things

QuestionEdit

I need help with this. I am not an expert on macros. I have to do this twice everyweek. If you could help I really appreciate. I have a spread sheet that has data like the following. 50(for ex.) different employees each one has 3 rows(no of rows can change but always same for each employee). some of these rows are in red. for example in this one emp 2222 has a row in red color. so the employee 2222 group should go to the top next to heading. sometimes 2 rows or 3 can be in red color for one employee. In any case I want all the 3 rows that belong to the employee have to go to the top.

2nd condition If all of them are 'n' in the y/n column for an employee then I need to completely delete all 3 rows for that employee.

3rd condition I need to color band first set is white second set is green thrid set is white forth set is green so it is like white and green just to make it presentable. I need a macro for all these. even if you help me to do one condition I would really appreciate it. empid name address phno. y/n 1111 alex 123 phoenix n 1111 alex 123 phoenix y 1111 alex 123 phoenix n 2222 peter 234 sfdfld n 2222 peter 243 sfdfsa n 2222 peter 243 sfdffs n(this row in red 3333 hello 12th agd y 3333 ldskj 16yh sgl n 3333 fgjls sgflksjlk y 4444 addfk 234 sfgj y 4444 ddgd 234 sfgi y(this row in red 4444 sfgfd 234 sgfg n(this row in red

AnswerEdit

Kumar,

this worked for me - but recognize I have never seen you data. I assumed "empid" was in A1 of the sheet with the data. I have the macro make a copy of your sheet and then process the copy so none of your original data should be destroyed.

I created 6000 lines of data for testing. The macro took about 2 Minutes to run on my machine. So it may take a while.

I start the banding after the red rows - I assume you didn't want to change their color.

Sub ProcessData() Dim lastrow As Long, r As Range Dim sh As Worksheet Dim bRed As Boolean, cnt As Long, cnt1 As Long Dim r1 As Range, cell As Range, i As Long Dim bGreen As Boolean ActiveSheet.Copy After:=Worksheets(Worksheets.Count) Set sh = Worksheets(Worksheets.Count) sh.Activate sh.Cells.Copy sh.Cells.PasteSpecial xlValues sh.Columns(1).Resize(, 2).EntireColumn.Insert lastrow = sh.Cells(sh.Rows.Count, 3).End(xlUp).Row Set r = sh.Range("A2:A" & lastrow) Range("A1") = 10000 r.Formula = "=if(C2<>C1,A1+1,A1)" r.Offset(0, 1).Formula = "=if(Sumproduct(--($A$1:$A" & _

  lastrow & "=$A2),--($G$1:$G" & lastrow _
  & "=""n""))=countif($A:$A,$A2),na(),"""")"

r.Resize(, 2).Formula = r.Resize(, 2).Value On Error Resume Next Set r1 = r.Offset(0, 1).SpecialCells(xlConstants, xlErrors) On Error GoTo 0 If Not r1 Is Nothing Then

  r1.EntireRow.Delete

End If lastrow = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row Set r = sh.Range("A2:A" & lastrow) cnt = Application.CountIf(Range("A:A"), Range("A2")) cnt1 = 1 For i = 2 To lastrow Step cnt

 Set r1 = sh.Cells(i, 3).Resize(cnt, 1)
 bRed = False
 For Each cell In r1
   If cell.Interior.ColorIndex = 3 Then
      bRed = True
      Exit For
   End If
 Next
 If bRed Then
   r1.Offset(0, -2).Value = cnt1
   cnt1 = cnt1 + 1
 End If

Next sh.Range("A1:B1").Value = Array("Header1", "Header2") sh.Range("A1").CurrentRegion.Sort Key1:=sh.Range("A1"), _

 order1:=xlAscending, _
 Header:=xlYes, MatchCase:=False

i = 2 Do While Cells(i, 1) < 10001

 i = i + 1

Loop cnt1 = i bGreen = False For i = cnt1 To lastrow Step cnt

 Set r1 = sh.Cells(i, 3).Resize(cnt, 1)
 If bGreen Then
   r1.EntireRow.Interior.ColorIndex = 43
   bGreen = False
 Else
   bGreen = True
 End If

Next sh.Columns(1).Resize(, 2).EntireColumn.Delete End Sub