Copy matching data between workbooks

[Snypa]

Hello,

I have written a function that finds data in one sheet and moves it to a new workbook. Typically, I google stuff like this but I've picked up enough now that I wrote this one myself (except the formatting at the end, I recorded a macro and stole the code for that part).

The issue is it can be fairly slow, so is there a better way to do this?

Private Sub cmdGenerate_Click()
frmRunList.Hide
    
'---------------------------------------------------------------------------------
' This function opens a source workbook, copies some matching data to an array
' and then copies that array to a new workbook and applies some basic formating
'
'


Dim StoreSearch As Workbook


' - Get row numbers that containt data in source workbook
Dim intSpeedDial As Integer
Dim intIP As Integer
intSpeedDial = Sheets("Settings").Range("F4").Value - 2
intIP = Sheets("Settings").Range("F3").Value - 2


' - Open source workbook
Set StoreSearch = Workbooks.Open(fileName:="O:\Stores List.xlsx", ReadOnly:=True)

' - Loop through all rows in the source and copy matching data to an array
Dim rng As Range
Dim strGroup As String
Dim aryResults As Variant
Dim lngFirstRow As Long
Dim lngCol As Long

' -- Defines which data we are searching for
If frmRunList.optGEM = True Then
    strGroup = "GEM*"
ElseIf frmRunList.optHUNT = True Then
    strGroup = "Hunt*"
End If

' -- Find all matching cells
With StoreSearch.Sheets("Stores List").Range("B2:B2000")
    Set rng = .Find(What:=strGroup, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
       
    'set first row (so we dont loop twice)
    lngFirstRow = rng.Row
    ReDim aryResults(1 To 4, 0 To 0) ' initialise array
    
    Do
        lngCol = lngCol + 1
        ReDim Preserve aryResults(1 To 4, 1 To lngCol) ' grow array
        aryResults(1, lngCol) = rng.Offset(, -1).Value ' Store code
        aryResults(2, lngCol) = rng.Value              ' store name
        aryResults(3, lngCol) = rng.Offset(, intSpeedDial).Value  ' store speed dial
        aryResults(4, lngCol) = rng.Offset(, intIP).Value  ' store ip address
        
        Set rng = .FindNext(After:=rng)
    Loop Until rng.Row = lngFirstRow

End With
StoreSearch.Close

' - Open a new excel document

Dim wbResult As Workbook
Set wbResult = Workbooks.Add

' - Copy data from array to it

Dim i As Long

' -- Populate headers
wbResult.Sheets("Sheet1").Cells(1, 1).Value = "Store code"
wbResult.Sheets("Sheet1").Cells(1, 2).Value = "Store name"
wbResult.Sheets("Sheet1").Cells(1, 3).Value = "Speed dial"
wbResult.Sheets("Sheet1").Cells(1, 4).Value = "IP Address"

' -- Populate rows
For i = LBound(aryResults, 2) To UBound(aryResults, 2)
    wbResult.Sheets("Sheet1").Cells(i + 1, 1).Select ' Keeps the current row on screen for user to see progress
    wbResult.Sheets("Sheet1").Cells(i + 1, 1).Value = aryResults(1, i)
    wbResult.Sheets("Sheet1").Cells(i + 1, 2).Value = aryResults(2, i)
    wbResult.Sheets("Sheet1").Cells(i + 1, 3).Value = aryResults(3, i)
    wbResult.Sheets("Sheet1").Cells(i + 1, 4).Value = aryResults(4, i)
Next i

' -- Apply formatting
wbResult.Sheets("Sheet1").Columns("A:I").AutoFit
wbResult.Sheets("Sheet1").Range("1:1").Font.Bold = True

' -- Format as table (with filters etc)
Dim r As Range
Set r = wbResult.Sheets("Sheet1").UsedRange
    ActiveSheet.ListObjects.Add(xlSrcRange, r, , xlYes).Name = "Table1"
    wbResult.Sheets("Sheet1").Range("Table1[#All]").Select
    ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleMedium1"
    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
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlDot
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

wbResult.Sheets("Sheet1").Range("A2").Select
End Sub

 

[Snypa]

To elaborate, I'm not after a line by line analysis of my code rarther general feedback on my approach and if this is what you guys would do to acheive this task.

I.e: the task is to search a list of retail stores and pull out the rows where the store's name meet a set criteria (i.e. their names start with XYZ ("XYZ*"). Then, populate a new spreadsheet with some cells from that row.

Greatful for any advice.