There are two things you can do to speed up the code significantly:
First: avoid Application.Match inside the loop
I suggest creating a Scripting.Dictionary before the While loop storing Key/Item pairs. Code might look something like this:
'Note: early binding requires that you add `Microsoft Scripting Runtime` reference to your project
Dim Col2Dict as Scripting.Dictionary
Set Col2Dict = New Scripting.Dictionary
For Each cell in rng
' If duplicates exist in rng, this will raise an error, but then again
' I guess it's a key column, so there should be no duplicates
Col2Dict.Add Key:=cell.Value, Item:=cell.row
Next cell
Now you have the dictionary containing all the pairs (Value of sht.Cells(cell.Row, 2) as Keys and cell.row as Items) the lines
If Not IsError(Application.Match(sht.Cells(cell.Row, p), rng1, 0)) Then
fn = Application.Match(sht.Cells(cell.Row, p), rng1, 0)
can become
If Col2Dict.Exists(sht.Cells(cell.Row, p)) Then
fn = Col2Dict(sht.Cells(cell.Row, p))
which will run many orders of magnitude faster, especially for large ranges...
You can find more information on how to use dictionaries here.
Second: Do the editing in arrays stored in memory
The next optimization would be to load the entire range into an array, perform the edits there and then write the entire array back to the worksheet at once. In your case that would be the range sht.Range(Cells(2, h1), Cells(lr, h1+2)). A replacement for your While loop might look like this:
'These two additionay variables need to be declared
Dim wArr As Variant
Dim i As Long
'Putting the content of the range to edit into an array
wArr = rng.Resize(, 3).Value
Do While fname <> ""
a = replace(fname, ".xlsx", "")
Set lwbk = Workbooks.Open(f & fname)
Set lsht = lwbk.ActiveSheet
lr1 = lsht.Cells(lsht.Rows.Count, "A").End(xlUp).row
Set rng1 = lsht.Range(Cells(1, p), Cells(lr1, p))
i = 0
For Each cell In rng
i = i + 1
If IsEmpty(cell) Then
If Col2Dict.Exists(sht.Cells(cell.row, p)) Then
fn = Col2Dict(sht.Cells(cell.row, p))
wArr(i, 1) = lsht.Cells(fn, s)
wArr(i, 2) = lsht.Cells(fn, b)
wArr(i, 3) = lsht.Cells(fn, v)
End If
End If
Next
lwbk.Close
wbk.Save
n = n + 1
fname = Dir
Loop
'Putting the edited array back to the range
rng.Resize(, 3).Value = wArr
You might notice, that I only converted the range that is actually being edited to an array. This is because converting the ranges, from which only read operations are performed, does not provide a performance benefit.
You can find more information on how to use arrays to speed up your code here.
Progress bar
It is relatively easy to implement this using userforms, the general idea is described here.
A finished and in my opinion slightly over-engineered version can be found here.
Personally, I have been using a simplified version of Mathieu Guindon's solution (second link), which I will describe here:
You need a Userform of approximately the following layout:
It needs to contain at least:
- A label called "ProgressLabel"
- A frame
- A label called "ProgressBar" inside the frame. This label should have the "BackColor" property set to a noticeable color, like blue in my example.
The UserForm is called ProgressView, and contains the following code:
Option Explicit
Private Const PROGRESSBAR_MAXWIDTH As Integer = 264
Private Const PROGRESSBAR_DEFAULT_CAPTION As String = "Progress..."
'source for sub SystemButtonSettings: https://exceloffthegrid.com/hide-or-disable-a-vba-userform-x-close-button/
Private Const GWL_STYLE = -16
Private Const WS_CAPTION = &HC00000
Private Const WS_SYSMENU = &H80000
#If VBA7 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
#Else
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
#End If
Public Sub SystemButtonSettings(frm As Object, show As Boolean)
Dim windowStyle As Long
Dim windowHandle As Long
windowHandle = FindWindowA(vbNullString, frm.Caption)
windowStyle = GetWindowLong(windowHandle, GWL_STYLE)
If show = False Then
SetWindowLong windowHandle, GWL_STYLE, (windowStyle And Not WS_SYSMENU)
Else
SetWindowLong windowHandle, GWL_STYLE, (windowStyle + WS_SYSMENU)
End If
DrawMenuBar (windowHandle)
End Sub
Private Sub UserForm_Activate()
ProgressBar.Width = 0 ' it's set to 10 to be visible at design-time
Me.StartupPosition = 0
Me.Width = 288
Me.Height = 112
Me.Caption = PROGRESSBAR_DEFAULT_CAPTION
SystemButtonSettings Me, False
End Sub
Public Sub Update(ByVal percentValue As Single, Optional ByVal labelValue As String, Optional ByVal captionValue As String)
If labelValue <> vbNullString Then
ProgressLabel.Caption = labelValue
End If
If captionValue <> vbNullString Then
Me.Caption = captionValue
End If
ProgressBar.Width = percentValue * PROGRESSBAR_MAXWIDTH
DoEvents
End Sub
Now you are ready to use the progress indicator! Usage works as follows:
Before your While loop, create a new instance of the UserForm:
Dim progress As ProgressView
Set progress = New ProgressView
progress.show vbModeless
Dim fileCount as Long
fileCount = 0
And inside the While loop specify how the progress is updated:
fileCount = fileCount + 1
progress.Update (1. / (totalNumberOfFiles)) * fileCount, "Working on File " & name
After the While loop, make sure you unload the UserForm:
Unload progress
Set progress = Nothing
Everything implemented, your final code might look like this:
Option Explicit
Private Sub dellkp()
Application.ScreenUpdating = False
Dim sht As Worksheet, lsht As Worksheet
Dim wbk As Workbook, lwbk As Workbook
Dim rng As Range, rng1 As Range, cell As Range
Dim h1 As Integer, h2 As Integer, h3 As Integer, p As Integer, s As Integer, b As
Integer, v As Integer, n As Integer
Dim lr As Long, lr1 As Long, fn As Long
Dim f As String, fname As String, a As String
f = Sheet1.Range("B1").Value & "\"
Set wbk = ActiveWorkbook
Set sht = Sheet2
h1 = 106
h2 = 107
h3 = 108
'product id
p = 9
'sku variant
s = 93
'base id
b = 71
'variant id
v = 87
sht.Cells(1, h1) = "Size"
sht.Cells(1, h2) = "Base"
sht.Cells(1, h3) = "Variation"
lr = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
fname = Dir(f & "*.xlsx")
sht.Activate
Set rng = sht.Range(Cells(2, h1), Cells(lr, h1))
' Creating the Dictionary
Dim Col2Dict as Object
'Using late binding so you don't have to worry about the reference
Set Col2Dict = CreateObject("Scripting.Dictionary")
For Each cell in rng
' If duplicates exist in rng, this will raise an error, but then again
' I guess it's a key column, so there should be no duplicates
Col2Dict.Add Key:=cell.Value, Item:=cell.row
Next cell
n = 0
'These two additional variables need to be declared
Dim wArr As Variant
Dim i As Long
'Putting the content of the range to edit into an array
wArr = rng.Resize(, 3).Value
Do While fname <> ""
a = replace(fname, ".xlsx", "")
Set lwbk = Workbooks.Open(f & name)
Set lsht = lwbk.ActiveSheet
lr1 = lsht.Cells(lsht.Rows.Count, "A").End(xlUp).row
Set rng1 = lsht.Range(Cells(1, p), Cells(lr1, p))
i = 0
For Each cell In rng
i = i + 1
If IsEmpty(cell) Then
If Col2Dict.Exists(sht.Cells(cell.row, p)) Then
fn = Col2Dict(sht.Cells(cell.row, p))
wArr(i, 1) = lsht.Cells(fn, s)
wArr(i, 2) = lsht.Cells(fn, b)
wArr(i, 3) = lsht.Cells(fn, v)
End If
End If
Next
lwbk.Close
wbk.Save
n = n + 1
fname = Dir
Loop
'Putting the edited array back to the range
rng.Resize(, 3).Value = wArr
Application.ScreenUpdating = True
MsgBox n & " File(s) are Lookedup!!!", , "Linga"
End Sub
