Copy matching data between workbooks

Snypa

New Member
Joined
Nov 1, 2013
Messages
45
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?

Code:
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
 
Last edited:

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

Snypa

New Member
Joined
Nov 1, 2013
Messages
45
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,132,982
Messages
5,656,220
Members
418,290
Latest member
ArrArkRE

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top