Copy\Paste multiple criteria based rows to new sheet

Originally Posted by rylo

Hi

See how this goes. There is some formatting that hasn't been done, but I'm after the data extract and formula correctness.

Sub aaa()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("BigPond")
  OutSH.Cells.ClearContents
  
  'So from attached screenshot , say for an example macro shud filter rows that have
  '"BigPond" in coloum B ,"RG2" in column M & "INT" in column W and
  'i only want copy cells under column C,AK,AL,AM (in this order)
  'to my other excel sheet that is named "BigPond" and it should paste it starting from Row5. ??
  Sheets("Sites Data").Activate
  Range("A1").Select
  
  OutSH.Range("A1:C1").Value = Array("BU", "RG2", "Ext / Int")
  OutSH.Range("A2:C2").Value = Array("BigPond", ">0", "INT")
  
  OutSH.Range("A4:E4").Value = Array("Prefered Name", "RG2 Apps Shakeout - Verify App Deployment is complete", "RG2 Apps Shakeout - Verify users can login successfully", "RG2 Apps Shakeout - Verify users have correct roles", "Ext / Int")
  Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, criteriarange:=OutSH.Range("A1:B2"), copytorange:=OutSH.Range("A4:E4")
  
  With OutSH
    .Range("A4:E" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort order1:=xlDescending, key1:=.Range("E4"), header:=xlYes
    i = 5
    While .Cells(i, "E").Value = "INT"
      i = i + 1
    Wend
    breakrow = i
    .Cells(breakrow, "A").Resize(5, 1).EntireRow.Insert shift:=xlDown
    .Cells(breakrow, "A").Value = "INT Ttoal"
    .Cells(breakrow, "B").Formula = "=SUM(B5:B" & breakrow - 1 & ")/COUNTA($A5:$A" & breakrow - 1 & ")"
    .Cells(breakrow, "B").AutoFill Destination:=.Range(.Cells(breakrow, "B"), .Cells(breakrow, "E"))
    .Range("E4").Value = "Overall"
    .Range("E5").Formula = "=SUM(B5:D5)/3"
    .Range("D5").Copy
    .Range("E5").PasteSpecial (xlPasteFormats)
    .Range("E5").AutoFill Destination:=.Range("E5:E" & breakrow - 1)
    
    'formulas for EXT
    breakrow = breakrow + 5
    lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
    .Cells(lastrow + 1, "A").Value = "EXT Total"
    .Cells(lastrow + 1, "B").Formula = "=sum(B" & breakrow & ":B" & lastrow & ")/counta($A" & breakrow & ":$A" & lastrow & ")"
    .Range("B" & lastrow + 1).Copy Destination:=.Range("B" & lastrow + 1 & ":E" & lastrow + 1)
    .Range("E5").Copy Destination:=.Range("E" & breakrow)
    .Range("E" & breakrow).AutoFill Destination:=.Range("E" & breakrow & ":E" & lastrow)
    lastrow = lastrow + 2
    .Range("A" & lastrow).Value = "Grand Total"
    
    intlastrow = .Range("A4").End(xlDown).Row - 1
    .Range("B" & lastrow).Formula = "=sum(B5:B" & intlastrow & ",B" & breakrow & ":B" & lastrow - 2 & ")/counta($A5:$A" & intlastrow & ",$A" & breakrow & ":$A" & lastrow - 2 & ")"
    .Range("B" & lastrow).AutoFill Destination:=.Range("B" & lastrow & ":E" & lastrow)
    
    .Range("B4:D4").Replace what:="RG2 Apps Shakeout - ", replacement:=""
  End With
End Sub

rylo

Hey mate , u r genius.....may b small adjustment should fix this...this is what i got..(see attached screenshot)....last 2 colums are meant to appear under "Externals"...i m sure this shud be a small correction of code...can u have a quick look & let me know..plzzz...

thnkz a ton..