Collecting data from General Ledger accounts lines I have a pair of General Ledger accounts to scan for data. I need to find a keyword or phrase from the descriptions and then collect certain bits of data from those lines. The source tables (there are two) are on separate tabs and the data from that needs to populate 5 other tables of data for analysis.

This is the code I have so far but it is exceedingly slow. I would like suggestions to speed up the process. My thought is to load all the data into an array but I am not sure if that would be faster.

Sub Table9052()
Dim i As Integer
Dim wsA As Worksheet: Set wsA = ThisWorkbook.Sheets("QA Data A")
Dim wsK As Worksheet: Set wsK = ThisWorkbook.Sheets("QA Data K")
Dim wsT As Worksheet: Set wsT = ThisWorkbook.Sheets("Tables")
Dim Locker As String
Dim GC As String
Locker = "9052 Electronic Lockers"
GC = "9042 Dunkin Donuts Gift Card"
MBD = "MERCHANT BANKC"
DDSV = "DD STORED VALU"
SS = "STARBUCKS STOR"
ColARow = 3
ColFRow = 3
ColKRow = 3
ColPRow = 3
ColURow = 3

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For i = 6 To wsA.Range("C65536").End(xlUp).Row
    Eval = wsA.Cells(i, 4)
    If Eval = Locker Then 'If a locker line copy the cells to ELTable
        wsA.Cells(i, 3).Copy wsT.Cells(ColARow, 1) 'Copy Date to column A
        wsA.Cells(i, 4).Copy wsT.Cells(ColARow, 2) 'Copy Desc to column B
        wsA.Cells(i, 5).Copy wsT.Cells(ColARow, 3) 'Copy Ammt to column C
        wsA.Cells(i, 7).Copy wsT.Cells(ColARow, 4) 'Copy Lodge to column D
        ColARow = ColARow + 1
    End If
    If Eval = GC Then 'If a locker line copy the cells to DDCardTable
        wsA.Cells(i, 3).Copy wsT.Cells(ColPRow, 16) 'Copy Date to column A
        wsA.Cells(i, 4).Copy wsT.Cells(ColPRow, 17) 'Copy Desc to column B
        wsA.Cells(i, 5).Copy wsT.Cells(ColPRow, 18) 'Copy Ammt to column C
        wsA.Cells(i, 7).Copy wsT.Cells(ColPRow, 19) 'Copy Lodge to column D
        ColPRow = ColPRow + 1
    End If
Next i
For i = 6 To wsK.Range("C65536").End(xlUp).Row
    Eval = Left(wsK.Cells(i, 4), 14)
    If Eval = MBD Then 'If a locker line copy the cells to ELTable
        wsK.Cells(i, 3).Copy wsT.Cells(ColFRow, 6) 'Copy Date to column F
        wsK.Cells(i, 4).Copy wsT.Cells(ColFRow, 7) 'Copy Desc to column G
        wsK.Cells(i, 5).Copy wsT.Cells(ColFRow, 8) 'Copy Ammt to column H
        wsK.Cells(i, 7).Copy wsT.Cells(ColFRow, 9) 'Copy Lodge to column I
        ColFRow = ColFRow + 1
    End If
    If Eval = DDSV Then 'If a locker line copy the cells to DDCardTable
        wsK.Cells(i, 3).Copy wsT.Cells(ColKRow, 11) 'Copy Date to column K
        wsK.Cells(i, 4).Copy wsT.Cells(ColKRow, 12) 'Copy Desc to column L
        wsK.Cells(i, 5).Copy wsT.Cells(ColKRow, 13) 'Copy Ammt to column M
        wsK.Cells(i, 7).Copy wsT.Cells(ColKRow, 14) 'Copy Lodge to column N
        ColKRow = ColKRow + 1
    End If
    If Eval = SS Then 'If a locker line copy the cells to DDCardTable
        wsK.Cells(i, 3).Copy wsT.Cells(ColURow, 21) 'Copy Date to column U
        wsK.Cells(i, 4).Copy wsT.Cells(ColURow, 22) 'Copy Desc to column V
        wsK.Cells(i, 5).Copy wsT.Cells(ColURow, 23) 'Copy Ammt to column W
        wsK.Cells(i, 7).Copy wsT.Cells(ColURow, 24) 'Copy Lodge to column X
        ColURow = ColURow + 1
    End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Here's a suggestion for simplifying your code by refactoring a bit and copying out the common part to a separate sub.  Also sets values directly in place of copy/paste.

This could be refactored completely to (eg) read the values to be matched from a table on a worksheet, along with the destination for each matched row.

Sub Table9052()

    'use constants for fixed values
    Const Locker As String = "9052 Electronic Lockers"
    Const GC As String = "9042 Dunkin Donuts Gift Card"
    Const MBD As String = "MERCHANT BANKC*"
    Const DDSV As String = "DD STORED VALU*"
    Const SS As String = "STARBUCKS STOR*"

    Dim i As Long '&lt;&lt; use long in place on Integer
    Dim ColA As Range, ColF  As Range, ColK  As Range, ColP As Range, ColU  As Range

    Dim wsA As Worksheet: Set wsA = ThisWorkbook.Sheets("QA Data A")
    Dim wsK As Worksheet: Set wsK = ThisWorkbook.Sheets("QA Data K")
    Dim wsT As Worksheet: Set wsT = ThisWorkbook.Sheets("Tables")

    Dim Eval, rw As Range

    'set the starting points for each of the destination tables
    With wsT
        Set ColA = .Cells(3, "A")
        Set ColF = .Cells(3, "F")
        Set ColK = .Cells(3, "K")
        Set ColP = .Cells(3, "P")
        Set ColU = .Cells(3, "U")
    End With

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    For i = 6 To wsA.Range("C65536").End(xlUp).Row
        Set rw = wsA.Rows(i)
        Select Case rw.Cells(4).Value
            Case Locker: CopyRow rw, ColA
            Case GC: CopyRow rw, ColP
        End Select
    Next i

    For i = 6 To wsK.Range("C65536").End(xlUp).Row
        Set rw = wsK.Rows(i)
        Eval = rw.Cells(4)

        If Eval Like MBD &amp; "*" Then CopyRow rw, ColF
        If Eval Like DDSV &amp; "*" Then CopyRow rw, ColK
        If Eval Like SS &amp; "*" Then CopyRow rw, ColU

    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

'extract out the common code to a separate sub
'   copy values and advance to next row
Sub CopyRow(rw As Range, cDest As Range)
    cDest.Resize(1, 4).Value = _
            Array(rw.Cells(3).Value, rw.Cells(4).Value, _
            rw.Cells(5).Value, rw.Cells(7).Value)
    Set cDest = cDest.Offset(1, 0) 'next row...
End Sub