Help speeding/cleaning my lengthy macro

[taylorsm]

I am very new to the InStr and this was what I was able to create, but it is slow. Is there something else I should have used? How do I speed it up?

Sub TopErrorLocationTotals()
  Dim i As Long, d As Range, d2 As Range, d3 As Range

    Dim rng As Range

    Set rng = Worksheets("PasteValues").Range("M:N")

'''CISA
    For Each d In rng
        If InStr(d, "CISA Total") > 0 Then
            d.Offset(0, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B7")
        End If
    Next d

        For Each d2 In rng
        If InStr(d2, "GRA Total") > 0 Then
            d2.Offset(0, 1).Copy
            d2.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F7")
        End If
    Next d2

'''IRC
        For Each d3 In rng
        If InStr(d3, "IRC Total") > 0 Then
            d3.Offset(0, 1).Copy
            d3.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J7")
        End If
    Next d3
    
    Range("A7:B7,E7:F7,I7:J7").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
 
End Sub

Sub TopErrorDeleteTotals()
    Dim foundCell As Range
    Dim itemArray
    Dim item
    Application.ScreenUpdating = False
    Application.ThisWorkbook.RefreshAll
    itemArray = Array("Total", "total")
    For Each item In itemArray
        Set foundCell = Worksheets("PasteValues").UsedRange.Find(what:=item, LookIn:=xlValues, lookat:=xlPart)
        Do While Not foundCell Is Nothing
            foundCell.Resize(, 2).Delete shift:=xlUp
            Set foundCell = Worksheets("PasteValues").UsedRange.FindNext
        Loop
    Next item

End Sub

Sub TopErrorGRA()
  Dim i As Long, c As Range
    Dim rng As Range

    Set rng = Worksheets("PasteValues").Range("E:E")
    
    For Each c In rng
        If InStr(c, "GRA") > 0 Then
            c.Offset(1, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F8")
            c.Offset(2, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F9")
            c.Offset(3, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F10")

            c.Offset.Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E7")
            c.Offset(1, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E8")
            c.Offset(2, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E9")
            c.Offset(3, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E10")

            
        End If
    Next c


End Sub

Sub TopErrorCISA()
  Dim i As Long, c As Range
    Dim rng As Range

    Set rng = Worksheets("PasteValues").Range("E:E")
    
    For Each c In rng
        If InStr(c, "CISA") > 0 Then
            c.Offset(1, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B8")
            c.Offset(3, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B9")
            c.Offset(4, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B10")

            c.Offset.Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A7")
            c.Offset(1, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A8")
            c.Offset(2, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A9")
            c.Offset(3, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A10")

            
        End If
    Next c
End Sub

Sub TopErrorIRC()
  Dim i As Long, c As Range
    Dim rng As Range

    Set rng = Worksheets("PasteValues").Range("E:E")
    
    For Each c In rng
        If InStr(c, "IRC") > 0 Then
            c.Offset.Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I7")
            c.Offset(1, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I8")
            c.Offset(2, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I9")
            c.Offset(3, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I10")
            
            c.Offset(1, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J8")
            c.Offset(2, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J9")
            c.Offset(3, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J10")

 

            
        End If
    Next c
End Sub
Sub TopErrorCISAManager()
  Dim i As Long, c As Range, d As Range
    Dim rng As Range

    Set rng = Worksheets("PasteValues").Range("A:A")

'Jen

    For Each c In rng
        If InStr(c, "Jen") > 0 Then
            c.Offset.Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A12")
            c.Offset(1, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A13")
            c.Offset(2, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A14")
            c.Offset(3, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A15")
            
            c.Offset(0, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B12")
            c.Offset(1, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B13")
            c.Offset(2, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B14")
            c.Offset(3, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B15")
        End If
        Next c
        
'Marry

    For Each d In rng
        If InStr(d, "Marry") > 0 Then
            d.Offset.Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A17")
            d.Offset(1, 0).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A18")
            d.Offset(2, 0).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A19")
            d.Offset(3, 0).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("A20")
            
            d.Offset(0, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B17")
            d.Offset(1, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B18")
            d.Offset(2, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B19")
            d.Offset(3, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B20")
        End If
    Next d
End Sub

[taylorsm]

Part two

Sub TopErrorManagerGRA()
    Dim i As Long, c As Range, d As Range, e As Range, f As Range
    Dim rng As Range

    Set rng = Worksheets("PasteValues").Range("A:A")

'Cinda
   
    For Each c In rng
        If InStr(c, "Cinda") > 0 Then
            c.Offset.Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E12")
            c.Offset(1, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E13")
            c.Offset(2, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E14")
            c.Offset(3, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E15")
            
            c.Offset(0, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F12")
            c.Offset(1, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F13")
            c.Offset(2, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F14")
            c.Offset(3, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F15")
        End If
        Next c
        
'Nathan
  
    For Each d In rng
        If InStr(d, "Nathan") > 0 Then
            d.Offset.Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E17")
            d.Offset(1, 0).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E18")
            d.Offset(2, 0).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E19")
            d.Offset(3, 0).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E20")
            
            d.Offset(0, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F17")
            d.Offset(1, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F18")
            d.Offset(2, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F19")
            d.Offset(3, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F20")
        End If
    
    Next d
    
'Randy
  
        For Each e In rng
        If InStr(e, "Randy") > 0 Then
            e.Offset.Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E22")
            e.Offset(1, 0).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E23")
            e.Offset(2, 0).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E24")
            e.Offset(3, 0).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E25")
            
            e.Offset(0, 1).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F22")
            e.Offset(1, 1).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F23")
            e.Offset(2, 1).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F24")
            e.Offset(3, 1).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F25")
        End If
    Next e
    
'Todd
    
        For Each f In rng
        If InStr(f, "Todd") > 0 Then
            f.Offset.Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E27")
            f.Offset(1, 0).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E28")
            f.Offset(2, 0).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E29")
            f.Offset(3, 0).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("E30")
            
            f.Offset(0, 1).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F27")
            f.Offset(1, 1).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F28")
            f.Offset(2, 1).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F29")
            f.Offset(3, 1).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F30")
        End If
    Next f
End Sub

Sub TopErrorManagerIRC()
    Dim i As Long, c As Range, d As Range, e As Range, f As Range
    Dim rng As Range

    Set rng = Worksheets("PasteValues").Range("A:A")

'Adam
   
    For Each c In rng
        If InStr(c, "Adam") > 0 Then
            c.Offset.Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I12")
            c.Offset(1, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I13")
            c.Offset(2, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I14")
            c.Offset(3, 0).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I15")
            
            c.Offset(0, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J12")
            c.Offset(1, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J13")
            c.Offset(2, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J14")
            c.Offset(3, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J15")
        End If
        Next c
        
'Becky
  
    For Each d In rng
        If InStr(d, "Becky") > 0 Then
            d.Offset.Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I17")
            d.Offset(1, 0).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I18")
            d.Offset(2, 0).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I19")
            d.Offset(3, 0).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I20")
            
            d.Offset(0, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J17")
            d.Offset(1, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J18")
            d.Offset(2, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J19")
            d.Offset(3, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J20")
        End If
    
    Next d
    
'Dave
  
        For Each e In rng
        If InStr(e, "Dave") > 0 Then
            e.Offset.Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I22")
            e.Offset(1, 0).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I23")
            e.Offset(2, 0).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I24")
            e.Offset(3, 0).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I25")
            
            e.Offset(0, 1).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J22")
            e.Offset(1, 1).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J23")
            e.Offset(2, 1).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J24")
            e.Offset(3, 1).Copy
            e.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J25")
        End If
    Next e
    
    
    
'Doug
    
        For Each f In rng
        If InStr(f, "Doug") > 0 Then
            f.Offset.Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I27")
            f.Offset(1, 0).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I28")
            f.Offset(2, 0).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I29")
            f.Offset(3, 0).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("I30")
            
            f.Offset(0, 1).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J27")
            f.Offset(1, 1).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J28")
            f.Offset(2, 1).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J29")
            f.Offset(3, 1).Copy
            f.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J30")
        End If
    Next f
    

End Sub

Sub TopErrorAuditCount()
  Dim i As Long, c As Range, c2 As Range, c3 As Range, c4 As Range, c5 As Range, c6 As Range, c7 As Range, c8 As Range, c9 As Range, c10 As Range, d As Range, d2 As Range, d3 As Range

    Dim rng As Range

    Set rng = Worksheets("PasteValues").Range("M:N")

'''CISA
    For Each d In rng
        If InStr(d, "CISA Total") > 0 Then
            d.Offset(0, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B8")
        End If
    Next d


'Jen
    For Each c In rng
        If InStr(c, "Jen") > 0 Then
            c.Offset(0, 1).Copy
            c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B12")
        End If
    Next c
    
'Marry
        For Each c2 In rng
        If InStr(c2, "Marry") > 0 Then
            c2.Offset(0, 1).Copy
            c2.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B17")
        End If
    Next c2
'''GRA
        For Each d2 In rng
        If InStr(d2, "GRA Total") > 0 Then
            d2.Offset(0, 1).Copy
            d2.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F7")
        End If
    Next d2

'Cinda
        For Each c3 In rng
        If InStr(c3, "Cinda") > 0 Then
            c3.Offset(0, 1).Copy
            c3.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F12")
        End If
    Next c3
'Nathan
        For Each c4 In rng
        If InStr(c4, "Nathan") > 0 Then
            c4.Offset(0, 1).Copy
            c4.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F17")
        End If
    Next c4
'Randy
        For Each c5 In rng
        If InStr(c5, "Randy") > 0 Then
            c5.Offset(0, 1).Copy
            c5.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F22")
        End If
    Next c5
'Todd
        For Each c6 In rng
        If InStr(c6, "Todd") > 0 Then
            c6.Offset(0, 1).Copy
            c6.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F27")
        End If
    Next c6
'''IRC
        For Each d3 In rng
        If InStr(d3, "IRC Total") > 0 Then
            d3.Offset(0, 1).Copy
            d3.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J7")
        End If
    Next d3
    
'Adam
        For Each c7 In rng
        If InStr(c7, "Adam") > 0 Then
            c7.Offset(0, 1).Copy
            c7.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J12")
        End If
    Next c7
'Becky
        For Each c8 In rng
        If InStr(c8, "Becky") > 0 Then
            c8.Offset(0, 1).Copy
            c8.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J17")
        End If
    Next c8
'Dave
        For Each c9 In rng
        If InStr(c9, "Dave") > 0 Then
            c9.Offset(0, 1).Copy
            c9.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J22")
        End If
    Next c9
   
 'Doug
        For Each c10 In rng
        If InStr(c10, "Doug") > 0 Then
            c10.Offset(0, 1).Copy
            c10.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("J27")
        End If
    Next c10
    
    Worksheets("Top Errors").Columns.AutoFit
    Worksheets("Top Errors").Range("A:N").HorizontalAlignment = xlCenter

    End Sub
 
Sub TopErrorClean()

Dim rng As Range
Dim cell As Range
Dim ContainWord As String

'What range do you want to search?
 'CISA
    Set rng = Range("A8:A11")
    Set rng2 = Range("A13:A15")
 'GRA
    Set rng3 = Range("E8:E10")
    Set rng4 = Range("E13:E15")
    Set rng5 = Range("E18:E20")
    Set rng6 = Range("E23:E25")
 'IRC
    Set rng7 = Range("I8:I10")
    Set rng8 = Range("I13:I15")
    Set rng9 = Range("I18:I20")
    Set rng10 = Range("I23:I25")

  
  

'What phrase do you want to test for?
 'CISA
    ContainWord = "Jen"
    ContainWord2 = "Marry"
 'GRA
    ContainWord3 = "Cinda"
    ContainWord4 = "Nathan"
    ContainWord5 = "Randy"
    ContainWord6 = "Todd"
'IRC
    ContainWord7 = "Adam"
    ContainWord8 = "Becky"
    ContainWord9 = "Dave"
    ContainWord10 = "Doug"
    
    

'Loop through each cell in range and test cell contents
'CISA
  For Each cell In rng.Cells
    If cell.Value = ContainWord Then cell.Clear
  Next cell
  
  For Each cell In rng2.Cells
    If cell.Value = ContainWord2 Then cell.Clear
  Next cell

  For Each cell In rng.Cells
    If cell.Value = ContainWord Then cell.Clear
  Next cell

'GRA
  For Each cell In rng3.Cells
    If cell.Value = ContainWord3 Then cell.Clear
  Next cell
  
  For Each cell In rng4.Cells
    If cell.Value = ContainWord4 Then cell.Clear
  Next cell
  
  For Each cell In rng5.Cells
    If cell.Value = ContainWord5 Then cell.Clear
  Next cell
  
  For Each cell In rng6.Cells
    If cell.Value = ContainWord6 Then cell.Clear
  Next cell
  
'IRC
    
  For Each cell In rng7.Cells
    If cell.Value = ContainWord7 Then cell.Clear
  Next cell

  For Each cell In rng8.Cells
    If cell.Value = ContainWord8 Then cell.Clear
  Next cell
  
  For Each cell In rng9.Cells
    If cell.Value = ContainWord9 Then cell.Clear
  Next cell
  
  For Each cell In rng10.Cells
    If cell.Value = ContainWord10 Then cell.Clear
  Next cell


    Range("A7:B7,A12:B12,A17:B17").Select
    Range("A17").Activate
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent4
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Range("E7:F7,E12:F12,E17:F17,E22:F22,E27:F27").Select
    Range("E27").Activate
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Range("I7:J7,I12:J12,I17:J17,I22:J22,I27:J27").Select
    Range("I27").Activate
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Range("E1:F1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With

Application.DisplayAlerts = False

Worksheets("PasteValues").Delete

Application.DisplayAlerts = True

End Sub

[alansidman]

I wonder if it would speed up if you made the items you are searching an array and place the array in the Instr function. It would definitely shorten the codes(s).

[taylorsm]

I wondered about that, but since each search goes has a different destination, i didn't know where to begin.

[alansidman]

Use the If-Then-Else aspect of VBA. Create a different Range to search for each array and location to place results. It won't be short code and will probably still take a while as you are running several searches. Add

Application.ScreenUpdating = False at the start

and

Application.ScreenUpdating = true at the end

Turn off any auto calc at the beginning and reactivate at the end of your code. These will speed things up a bit.

[scottiex]

1) do all the work inside an array
2) find the lastrow so you don't accidentally get 1 million rows

lastrowx = Cells(Rows.Count, "M").End(xlUp).Row
 rng = Worksheets("PasteValues").Range("M1:N" & lastrowx)

(obviously "set rng" like you had - if you stay with using the sheet range)

[taylorsm]

1) do all the work inside an array
2) find the lastrow so you don't accidentally get 1 million rows

lastrowx = Cells(Rows.Count, "M").End(xlUp).Row
 rng = Worksheets("PasteValues").Range("M1:N" & lastrowx)

Hey Scottie, where would that go?

[taylorsm]

OK, if then Else is new to me, so I'll explore that, but can I put the False at the start at the beginning of my very first macro and then at the end of the very last, or do I need to do it in each macro.

[scottiex]

To get it all in an array we have quite a bit more work to do so keeping it simple just put this form

lastrowx = Cells(Rows.Count, "M").End(xlUp).Row
 Set rng = Worksheets("PasteValues").Range("M1:N" & lastrowx)

wherever you have this form

Set rng = Worksheets("PasteValues").Range("M:N")

and see if that helps.

[bakerman2]

It seems to me that you are doing a lot of recursive stuff just for nothing.

Do all the values you are looking up occur once or multiple times in the searchrange ?

If they occur only once it's better to use something like Application.Match or Find to lookup your value and copy the corresponding value.

If they occur multiple times it's better to lookup the last occurence because it's corresponding value will be the one that finally will be in your destination range.

[taylorsm]

Bakerman2,

i attached a workbook that shows what I start with and then what I end up with. The number of items listed under each person in the pivot table may change so an exact position isn't possible.

[mikerickson]

This is slow

c.Offset(0, 1).Copy
c.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("F12")

This is fast, but moves only values not formatting.

Worksheets("Top Errors").Range("F12").Value = c.Offset(0, 1).Value

[xlnitwit]

Given the loops in the code, at the very least it looks as though you should probably be using Exit For after finding the values you are looking for- otherwise you carry on looping through the ranges for nothing. I suspect also that you could simply use GETPIVOTDATA formulas and not loop at all.

[Zer0Cool]

For Each d In rng
        If InStr(d, "CISA Total") > 0 Then
            d.Offset(0, 1).Copy
            d.Worksheet.Paste Destination:=Worksheets("Top Errors").Range("B7")
        End If
    Next d

Looping cells in a range is the absolute slowest way to evaluate contents. Sometimes its the best way regardless, because its easy to implement and isnt prone to issues.

You could speed things up by using range.find instead, and if need be in a loop range.findnext. Basically find returns a range object, you set that to a variable and then do a range.value = range.value to transfer its value to another cell. Ironically I see now you use this in the next sub.

Depending on your data set you may also benefit from filter instead (either auto or advanced). You can filter on partial strings and then take the results and move them together (assuming you need more than 1 match for each term you seek).

Also, For loops are good for when you need to do something x number of times regardless of the result in each iteration. If you need to loop until something is found or while something is true/false, instead of using exit for to leave the loop, just use a Do while or Do until loop. This will allow the loop to only iterate as many times as required.

Changing references for ranges to be only the required range instead of full columns will help too, especially when using a for loop. In multiple places I see H:H instead of H2:H100 for example. If your looping every cell in H:H thats a million cells to check instead of 100, 1000, etc. Do this 20 times and its 20 millions cells to loop instead of 20,000. Also using constants can speed up code. Set a constant string for your range and then use the constant instead of quoted text strings manually entered multiple times. Use constants for text strings you repeat elsewhere in the code too.

copy/paste is slow and sometimes buggy. Instead do range.value = range.value. You can combine that with copy formatting or just code to format the destination.

Use variables for objects like sheets and workbook instead of repeatedly doing worksheets("")... do a worksheet object and assign it to a variable.

Turning off screenupdating will improve speed and so will turning off automatic calculation until your macros complete.

Overall, my guess is the biggest issue is the combination of whole column references combined with for loops checking each cell in those columns. Fix that and your code should run much faster.