Faster Code?

Nichole09

Board Regular
Joined
Aug 27, 2016
Messages
132
Hello,

I struggled with the below code for a bit, but finally got it to work. It works just as expected! However, its a bit slower then I was hoping for. It takes about a full 60 seconds to execute. Any suggestions to make this run faster? I appreciate any help!

VBA Code:
Sub compare()
Dim last As Long
Dim filename As String, myfile As String
Dim strfile As String, dtfile As Date
Dim current As Integer, getweeknumber As Integer
Dim dic As Object, ar As Variant, arr As Variant, var As Variant
Dim v()
Dim i As Long, n As Long, j As Long, x As Long, k As Long, l As Long, t As Long, w As Long
Dim str As String
Dim ws As Worksheet, wbk1 As Workbook, ws3 As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws4 As Worksheet
Dim wb, wb1 As Workbook
Dim var1array, var2array
Dim blnmatch As Boolean
Dim lrow As Long
Dim shp As Shape
Dim pt As PivotTable
 Dim Source, Target, Row As Range, LastRow, InsertRowAddress As Long, IDList, IDColumn As String
 Dim rng As Range



Dim wbk As Variant, filename1 As String


Application.ScreenUpdating = False
Application.EnableEvents = False



Set ws2 = ThisWorkbook.Sheets("Prequalification Pipeline")
  Set Source = ThisWorkbook.Sheets("Prequalification Pipeline").UsedRange

ws2.Activate

current = DatePart("q", Date, 2)
getweeknumber = Int((13 + Day(Date) - Weekday((Date), vbMonday) - 5) / 7)

If current = 1 And getweeknumber = 2 Then
    myfile = "MT.WesternMontana_"
ElseIf current = 1 And getweeknumber > 3 Then
myfile = "WY.GreaterWyoming_"
ElseIf current = 2 And getweeknumber = 2 Then
myfile = "WY.CheyenneWyoming_"
ElseIf current = 2 And getweeknumber > 3 Then
myfile = "SD.SouthDakota-MT.Montana_"
ElseIf current = 3 And getweeknumber = 2 Then
myfile = "OR.Oregon-WA.Washington_"
ElseIf current = 3 And getweeknumber > 3 Then
myfile = "ID.Idaho-WA.Washington_"
Else
End If


dtfile = Date
'dtfile = dateadd("m" -1, now())
' use the above comment if need to look back a month

filename1 = Dir("\Preqaul Review\")

filename = "\Preqaul Review\" & myfile

If Len(filename1) = 0 Then
MsgBox "No Files were found.", vbExclamation
Exit Sub
End If

Do While filename <> ""
On Error Resume Next
wbk = (filename & Format(dtfile, "mmddyyyy") & ".xlsx")
On Error GoTo 0
If Dir(wbk, vbDirectory) = vbNullString Then
dtfile = dtfile - 1
Else
Workbooks.Open (wbk)
Exit Do
End If
Loop

Set ws3 = Workbooks(myfile & Format(dtfile, "mmddyyyy")).Worksheets("Prequalification Pipeline")


Workbooks(myfile & Format(dtfile, "mmddyyyy")).Sheets.Add(after:=Sheets("Prequalification Pipeline")).Name = Format(Date, "mmddyyyy")
Set ws4 = Workbooks(myfile & Format(dtfile, "mmddyyyy")).Sheets(Format(Date, "mmddyyyy"))

With ws3
.Shapes("TextBox 4").TextFrame.Characters.Text = "Duplicate Loans"
.TextBoxes("TextBox 4").Copy
ws4.PasteSpecial
.Shapes("TextBox 4").TextFrame.Characters.Text = "Prequalification Pipeline"
End With


ws4.Rows("1:1").RowHeight = 27
ws4.Rows("2:2").RowHeight = 7.5
ws3.Cells(3, 6).Copy
ws4.Cells(3, 1).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 1).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 1).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Cells(3, 8).Copy
ws4.Cells(3, 2).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 2).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 2).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Cells(3, 9).Copy
ws4.Cells(3, 3).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 3).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 3).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Cells(3, 10).Copy
ws4.Cells(3, 4).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 4).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 4).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Cells(3, 11).Copy
ws4.Cells(3, 5).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 5).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 5).PasteSpecial Paste:=xlPasteColumnWidths

ws3.Cells(3, 22).Copy
ws4.Cells(3, 6).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(3, 6).PasteSpecial Paste:=xlPasteValues
ws4.Cells(3, 6).PasteSpecial Paste:=xlPasteColumnWidths

ws4.Columns("F").ColumnWidth = 19.14

 
With ws2
lrow = .Cells(Rows.Count, "F").End(xlUp).Row
var1array = .Range(.Cells(4, "F"), .Cells(lrow, "F")).Value
End With

With ws3
lrow = .Cells(Rows.Count, "F").End(xlUp).Row
var2array = .Range(.Cells(4, "F"), .Cells(lrow, "F")).Value
End With

t = 1

For i = 1 To UBound(var1array, 1)
j = 1
l = 1
blnmatch = False
Do While j <= UBound(var2array, 1) And blnmatch = False
If var2array(j, 1) = var1array(i, 1) Then
blnmatch = True
Exit Do
End If
j = j + 1
Loop




'copy dupes
If blnmatch = True Then
i = i + 3
k = 6

For k = 6 To 22
t = 1
    If x = 0 Then
x = 4
Else
x = x + 1
End If

For l = t To 6
If k = 12 Then
   k = 22
   ElseIf k = 7 Then
   k = 8
   Else
    End If


ws2.Cells(i, k).Copy
ws4.Cells(x, l).PasteSpecial Paste:=xlPasteValues
ws4.Cells(x, l).PasteSpecial Paste:=xlPasteFormats
ws4.Cells(x, l).PasteSpecial Paste:=xlPasteColumnWidths
   k = k + 1
t = t + 1
 
   Next l
   Next k
  
i = i - 3

End If
Next i

With ws4
.Columns("F").ColumnWidth = 20.86
.Cells(3, 6).Copy
.Cells(3, 7).PasteSpecial Paste:=xlPasteValues
.Cells(3, 7).PasteSpecial Paste:=xlPasteFormats
.Cells(3, 7).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(3, 7).Value = "Archived?"
lrow = .Cells(Rows.Count, "A").End(xlUp).Row
Set rng = .Range("G4:G" & lrow)
With rng.Validation
 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Yes,No"
End With
End With

ws4.Activate

Application.ScreenUpdating = True
Application.EnableEvents = True


ActiveWorkbook.Save

End Sub
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Hello. You could turn off calculation. Add
VBA Code:
Application.Calculation = xlCalculationManual
where your other application settings are at the top, and
VBA Code:
Application.Calculation = xlCalculationAutomatic
with the settings at the end. I'm sure the code itself can be optimised, but hope this speeds it up a bit for you.
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,329
Members
452,635
Latest member
laura12345

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
Back
Top