I wrote this code to speed up my daily work. I want to ask for help on how to further accelerate this code.
Operation of the code
It copies 1-1 worksheets from 3 different workbooks to 3 worksheets of the new workbook. Inserts, copies, and formats different columns. Then, by examining different criteria on a worksheet called "lista", type red 1s in specific cells or copy text.
What I've done so far for speed up
-Switching application functions on and off (like Application.ScreenUpdating)
-where it is possible using With - end with
-Delimitation of operation area with "lastrow".
-Usage vbNullString instead of ""
Get running the macro with a list of 180,000 lines takes 3-3.5 hours for done.
Environmental parameters
- Windows 10 Home
- Intel Core i7-930 2.8Ghz
- 16GB RAM
- 516GB SSD
- Excel 2013
Do you see any opportunity to accelerate?
The entire code:
Option Explicit
Sub Gyogyit()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim egyedilap, gyogylap, segedlap, listlap As Worksheet
Dim closedBook As Workbook
Dim listlastrow, gyogylastrow, listlastrow2, egyedilastrow As Long
Dim aoszl, Prob, kitolt, a, x, y, Z, v, w, af, dd, coutaj, egmunk, egmunk2, kozfog, kozfog2, j, nm, eufogl, eufogl2, vangyogy, vanegyedi, alap As Integer
Dim n As Date
Dim p, q, ag, ah, ak, an, ao, ap, aq, megbkim, apolh, korhdat, korhnev, imporsz, jarvaz, nevkod, jarvnev, betmk, betfog, kozfogl, kozfogl2, muhnev, munkhelygyogy, betmunkgyogy, betfoglszovgyogy, korhegyedi, megbkimegyed, korfelvegyed, kormegngyogy, korfeldatgyogy, apolhelygyogy, megbkimgyogy, apolhelyegyed As String
Dim StartTime As Double
Dim MinutesElapsed As String
Dim gyogyult, otthon As Boolean
StartTime = Timer
Set listlap = ThisWorkbook.Worksheets("lista")
Set gyogylap = ThisWorkbook.Worksheets("BE_gyogy")
Set segedlap = ThisWorkbook.Worksheets("segedlap")
Set egyedilap = ThisWorkbook.Worksheets("egyedi")
Application.DisplayAlerts = False
listlap.Range("I:K").Delete
Set closedBook = Workbooks.Open("C:\Users\tulaj\Documents\makróhozalap másolata\lista_okt-26.xlsx")
closedBook.Sheets(1).Range("A:AM").Copy listlap.Range("I:AU")
closedBook.Close SaveChanges:=False
Set closedBook = Workbooks.Open("C:\Users\tulaj\Documents\makróhozalap másolata\BE_gyogy.xlsx")
closedBook.Sheets(1).Range("A:DD").Copy gyogylap.Range("B:DF")
closedBook.Close SaveChanges:=False
Set closedBook = Workbooks.Open("C:\Users\tulaj\Documents\makróhozalap másolata\egyedi.xlsx")
closedBook.Sheets(1).Range("A:DY").Copy egyedilap.Range("B:DZ")
closedBook.Close SaveChanges:=False
Application.DisplayAlerts = True
With egyedilap
.Activate
.Range("E:E").Copy Range("A:A")
.Columns("A:A").NumberFormat = "0"
End With
With gyogylap
.Activate
.Range("I:I").Copy Range("A:A")
.Columns("A:A").NumberFormat = "0"
End With
gyogylastrow = gyogylap.Cells(Rows.Count, 1).End(xlUp).Row
egyedilastrow = egyedilap.Cells(Rows.Count, 1).End(xlUp).Row
With listlap
.Activate
.Columns("AG").Insert Shift:=xlToRight
.Range("AG1").Value = "Eü. fogl."
.Columns("AK").Insert Shift:=xlToRight
.Range("AK1").Value = "Import orsz."
.Columns("AO").Insert Shift:=xlToRight
.Range("AO1").Value = "Járvány neve"
.Range("AT:AT").Copy Range("A:A")
.Columns("A:A").NumberFormat = "0"
.Range("A1").Value = "TAJ"
.Columns("AS:AS").NumberFormat = "yyyy/mm/dd"
listlastrow = listlap.Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To listlastrow
If .Range("A" & x).Value = vbNullString Then
.Range("A" & x).Value = "nincs"
End If
Next x
For kitolt = 2 To listlastrow
On Error Resume Next
a = .Range("A" & kitolt)
n = .Range("N" & kitolt)
p = .Range("P" & kitolt)
q = .Range("Q" & kitolt)
x = .Range("X" & kitolt)
y = .Range("Y" & kitolt)
Z = .Range("Z" & kitolt)
v = .Range("V" & kitolt)
w = .Range("W" & kitolt)
j = .Range("J" & kitolt)
ag = .Range("AG" & kitolt)
ak = .Range("AK" & kitolt)
an = .Range("AN" & kitolt)
ao = .Range("AO" & kitolt)
With Application.WorksheetFunction
vangyogy = .CountIf(gyogylap.Range("A:A"), a)
vanegyedi = .CountIf(egyedilap.Range("A:A"), a)
korfeldatgyogy = .VLookup(a, gyogylap.Range("A2:CM" & gyogylastrow), 46, False)
kormegngyogy = .VLookup(a, gyogylap.Range("A2:CM" & gyogylastrow), 47, False)
korhegyedi = .VLookup(a, egyedilap.Range("A2:DZ" & egyedilastrow), 32, False)
korfelvegyed = .VLookup(a, egyedilap.Range("A2:DZ" & egyedilastrow), 33, False)
If vangyogy = 1 Then
megbkimgyogy = .VLookup(a, gyogylap.Range("A2:CM" & gyogylastrow), 49, False)
apolhelygyogy = .VLookup(a, gyogylap.Range("A2:CM" & gyogylastrow), 33, False)
Else
megbkimgyogy = vbNullString
apolhelygyogy = vbNullString
End If
If vanegyedi <> vbNullString Then
megbkimegyed = .VLookup(a, egyedilap.Range("A2:DZ" & egyedilastrow), 35, False)
apolhelyegyed = .VLookup(a, egyedilap.Range("A2:DZ" & egyedilastrow), 12, False)
Else
megbkimegyed = vbNullString
apolhelyegyed = vbNullString
End If
betfoglszovgyogy = .VLookup(a, gyogylap.Range("A2:CM" & gyogylastrow), 19, False)
eufogl = .CountIf(segedlap.Range("M:M"), betfoglszovgyogy)
betmunkgyogy = .VLookup(a, gyogylap.Range("A2:CM" & gyogylastrow), 20, False)
eufogl2 = .CountIf(segedlap.Range("M:M"), betmunkgyogy)
munkhelygyogy = .VLookup(a, gyogylap.Range("A2:CM" & gyogylastrow), 21, False)
kozfogl = .CountIf(segedlap.Range("K:K"), betmunkgyogy)
kozfogl2 = .CountIf(segedlap.Range("K:K"), betfoglszovgyogy)
nevkod = .VLookup(a, gyogylap.Range("A2:CM" & gyogylastrow), 11, False)
otthon = ((apolhelygyogy = "Otthon" And vanegyedi <> 1) Or _
(apolhelygyogy = vbNullString And vanegyedi = 1 And apolhelyegyed = "Otthon") Or _
(apolhelygyogy = "Otthon" And vanegyedi = 1 And apolhelyegyed = "Otthon"))
gyogyult = ((megbkimgyogy = "Gyógyult" And vanegyedi <> 1) Or _
(megbkimegyed = "gyógyult" And vanegyedi = 1 And megbkimgyogy = vbNullString) Or _
(megbkimegyed = "gyógyult" And vanegyedi = 1 And megbkimgyogy = "Gyógyult"))
End With
If a <> vbNullString And a <> 0 And a <> "nincs" Then
If q = vbNullString And _
v = vbNullString And _
w = vbNullString And _
x = vbNullString And _
Z = vbNullString And _
korfeldatgyogy = vbNullString And _
kormegngyogy = vbNullString And _
korhegyedi = vbNullString And _
korfelvegyed = vbNullString And _
nevkod <> "comtu001" And _
nevkod <> "voviv001" And _
nevkod <> "rocal006" Then
alap = 1
'Debug.Print alap
If p = vbNullString And _
(vangyogy = 1 Or vanegyedi = 1) = True And _
alap = 1 And _
otthon = True Then
.Range("P" & kitolt).Value = 1
.Range("P" & kitolt).Font.Color = RGB(210, 65, 65)
End If
If y = vbNullString And _
(vangyogy = 1 Or vanegyedi = 1) = True And _
j < 64 And _
Date - n > 13 And _
p = 1 And _
gyogyult = True Then
.Range("Y" & kitolt).Value = 1
.Range("Y" & kitolt).Font.Color = RGB(210, 65, 65)
End If
alap = 0
End If
'Debug.Print kitolt '& " " & alap & " " & vangyogy & " " & vanegyedi & " " & otthon & " " & gyogyult & " " & megbkimgyogy & " " & megbkimegyed
End If
If ak = vbNullString Then
.Range("AK" & kitolt).Value = Application.WorksheetFunction.VLookup(a, gyogylap.Range("A2:CM" & gyogylastrow), 54, False)
.Range("AK" & kitolt).Font.Color = RGB(210, 65, 65)
End If
If an = vbNullString Then
.Range("AN" & kitolt).Value = Application.WorksheetFunction.VLookup(a, gyogylap.Range("A2:CM" & gyogylastrow), 87, False)
.Range("AN" & kitolt).Font.Color = RGB(210, 65, 65)
End If
If ao = vbNullString Then
.Range("AO" & kitolt).Value = Application.WorksheetFunction.VLookup(a, gyogylap.Range("A2:CM" & gyogylastrow), 88, False)
.Range("AO" & kitolt).Font.Color = RGB(210, 65, 65)
End If
If ag = vbNullString Then
If eufogl = 1 Then
.Range("AG" & kitolt).Value = betmunkgyogy
.Range("AH" & kitolt).Value = munkhelygyogy
.Range("AF" & kitolt).Value = 1
.Range("AG" & kitolt).Font.Color = RGB(210, 65, 65)
.Range("AH" & kitolt).Font.Color = RGB(210, 65, 65)
.Range("AF" & kitolt).Font.Color = RGB(210, 65, 65)
ElseIf eufogl2 = 1 And a <> vbNullString And a <> "0" And a <> "nincs" Then
.Range("AG" & kitolt).Value = betfoglszovgyogy
.Range("AH" & kitolt).Value = munkhelygyogy
.Range("AF" & kitolt).Value = 1
.Range("AG" & kitolt).Font.Color = RGB(210, 65, 65)
.Range("AH" & kitolt).Font.Color = RGB(210, 65, 65)
.Range("AF" & kitolt).Font.Color = RGB(210, 65, 65)
End If
End If
If aq = vbNullString Then
If kozfogl = 1 Then
.Range("AQ" & kitolt).Value = betmunkgyogy
.Range("AP" & kitolt).Value = munkhelygyogy
.Range("AQ" & kitolt).Font.Color = RGB(210, 65, 65)
.Range("AP" & kitolt).Font.Color = RGB(210, 65, 65)
ElseIf kozfogl2 = 1 And a <> vbNullString And a <> "0" And a <> "nincs" Then
.Range("AQ" & kitolt).Value = betfoglszovgyogy
.Range("AP" & kitolt).Value = munkhelygyogy
.Range("AQ" & kitolt).Font.Color = RGB(210, 65, 65)
.Range("AP" & kitolt).Font.Color = RGB(210, 65, 65)
End If
End If
Next kitolt
Range("H2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[+7],RC[+7])"
Range("E2").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[39],RC[40])"
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
MinutesElapsed = format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
End Sub
