2
\$\begingroup\$

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
\$\endgroup\$
3
  • 1
    \$\begingroup\$ The current question title, which states your concerns about the code, applies to too many questions on this site to be useful. The site standard is for the title to simply state the task accomplished by the code. Please see How to Ask for examples, and revise the title accordingly. \$\endgroup\$
    – Mast
    Nov 25 '20 at 13:34
  • 1
    \$\begingroup\$ Thank you Mast! I revised the title. \$\endgroup\$
    – vega69
    Nov 25 '20 at 13:58
  • \$\begingroup\$ @BCdotWEB thank you! Title revised. \$\endgroup\$
    – vega69
    Nov 25 '20 at 22:49
1
\$\begingroup\$

One improvement to consider is reducing the number of VLookup calls and the multiple creations of identical Ranges. Create the evaluation Ranges outside of the loop (they do not change per loop) and then find the row of interest only once per loop using Match. Assign all of your variables based on the row value. This substantially reduces the number of Ranges created and VLookup/Match calls. I've added new code and commented out the lines that they replace inside the With Application.WorksheetFunction block.

       'Create the evaluation ranges once - outside of the loop
        Dim gyogylapRange As Range
        Set gyogylapRange = gyogylap.Range("A1:CM" & gyogylastrow)

        Dim egyedilapRange As Range
        Set egyedilapRange = egyedilap.Range("A1:DZ" & egyedilastrow)
        
        'Create the ranges for detecting the two rows of interest per loop
        Dim gyogylapRowDetectionRange As Range
        Set gyogylapRowDetectionRange = gyogylap.Range("A:A")

        Dim egyedilapRowDetectionRange As Range
        Set egyedilapRowDetectionRange = egyedilap.Range("A:A")
        
        For kitolt = 2 To listlastrow
        On Error Resume Next

        ...

        With Application.WorksheetFunction
            Dim rowFoundIn As Long
            
            vangyogy = .CountIf(gyogylapRowDetectionRange, a)
            rowFoundIn = .Match(a, gyogylapRowDetectionRange , 0)

            korfeldatgyogy = gyogylap.Cells(rowFoundIn, 46)
            kormegngyogy = gyogylap.Cells(rowFoundIn, 47)
            betfoglszovgyogy = gyogylap.Cells(rowFoundIn, 19)
            betmunkgyogy = gyogylap.Cells(rowFoundIn, 20)
            munkhelygyogy = gyogylap.Cells(rowFoundIn, 21)
            nevkod = gyogylap.Cells(rowFoundIn, 11)
            If vangyogy = 1 Then
                megbkimgyogy = gyogylap.Cells(rowFoundIn, 49)
                apolhelygyogy = gyogylap.Cells(rowFoundIn, 33)
            Else
                megbkimgyogy = vbNullString
                apolhelygyogy = vbNullString
            End If
            
            vanegyedi = .CountIf(egyedilapRowDetectionRange , a)

            rowFoundIn = .Match(a, egyedilapRowDetectionRange , 0)
            korhegyedi = egyedilap.Cells(rowFoundIn, 32)
            korfelvegyed = egyedilap.Cells(rowFoundIn, 33)
            If vanegyedi <> vbNullString Then
                megbkimegyed = egyedilap.Cells(rowFoundIn, 35)
                apolhelyegyed = egyedilap.Cells(rowFoundIn, 12)
            Else
                megbkimegyed = vbNullString
                apolhelyegyed = vbNullString
            End If
            
 '                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

        ...

        Next kitolt

Some other comments for you to consider. Most of these comments/changes are not focused on efficiency as much as maintainability and readability.

There are a a number of coding practices that will make your code easier to read, understand, and maintain. In this case, the two most important would be the Single Responsibility Principle (SRP) and Don't Repeat Yourself (DRY). SRP is the 'S' in SOLID coding practices and will improve the structure and reliability of your code dramatically. SRP encourages the use of small modules and methods focused on a single purpose.

SRP

In the code above, Sub Gyogyit() contains every responsibility for the tasks that it performs. To be fair, getting code organized in groups of single responsibilities is difficut to achieve. Especially in early versions. So, starting from the current implementation, it is easier to think of SRP as simply meaning divide and conquer. So, evaluate what are the biggest chunks of code that can be removed from Gyogyit and placed in their own dedicated subroutine or function.

The first thing done by Gyogyit is to turn off a number of flags to improve speed. And, these flags always need to be turned back 'on' before the the subroutine exits. Managing these flags is one of the responsibilities of Gyogyit. I would recommend making this the only responsibility of Gyogyit so that it is clear that the flags are toggled before and after the operations.

    Sub Gyogit()

    On Error GoTo ErrorExit

        Application.Calculation = xlCalculationManual
        Application.ScreenUpdating = False
        Application.DisplayStatusBar = False
        Application.EnableEvents = False
        ActiveSheet.DisplayPageBreaks = False

    Gyogyit2 'the remainder of the code

    ErrorExit:
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        Application.DisplayStatusBar = True
        Application.EnableEvents = True
        ActiveSheet.DisplayPageBreaks = True

    End Sub

Now the reader doesn't have to scroll the entire length of the module to know that the flags are all reset. If you ever add or remove another flag, it is obvious where to introduce it.

You mention using With statements to speed up the process. As far as I know, With statements will not change the execution speed of the code. They assist in avoiding repetitous qualifying expressions. They certainly have a place in the DRY coding practice. Because Gyogyit2 is such a long subroutine, the With statements reduce clarity because they span so many lines. With listalap and its associated End With are 177 lines apart. From a purely readability perspective, it is best to use a With statement in such a way that is easy to see the start and finish without scrolling so many lines. So, to keep the With listalap statement it is possible to refactor the 177 to procedure calls in order to significantly reduce the length.

First: the content of the loop is 130 lines. Moving the content of the loop to its own subroutine will be a big improvement. This yields:

     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
        Dim x As Long
        For x = 2 To listlastrow
            If .Range("A" & x).Value = vbNullString Then
                .Range("A" & x).Value = "nincs"
            End If
        Next x
    End With
    
    Dim kitolt As Long
    For kitolt = 2 To listlastrow
        KitoltLoop listlap, kitolt, gyogylap.Range("A2:CM" & gyogylastrow), egyedilap.Range("A2:DZ" & egyedilastrow)
    Next kitolt

The With statement is now only 22 lines and it can be 'seen' without scrolling. Also, note that the loop no longer needs to be within the With statement. And, the purpose of the With statement becomes very clear - it is used to simplify the expressions that initialize/prepare the listlap worksheet.

This now leaves the 130 line KitlotLoop subroutine: Nesting: Nested If and With statements make readability more difficult. In general, I might suggest that as soon as you have to nest beyond the second level, it is time to consider a different organization of logic. So, first step within the loop is to reduce nesting. Second, I would attempt to make the VERY long Boolean expressions into functions that return a Boolean - and give those functions a name that represents what it 'is' that you are evaluating. There are also numerous expressions that are different only by one 'thing'. These are candidates for simplifying by replacing them with a procedure and is consistent with the DRY coding practice.

In situations where there are numerous related variables there is a better way to organize them. By defining UserDefinedTypes, the variables can be organized and moved as a group rather than individually. Organizing the variable this way helps to make procedure parameter lists more manageable.

So, applying all the above suggestion, the following is an alternative implementation of the code. Just by making all procedures 'smaller', there is progress to the goal of SRP. Also note that the wall of variables has disappeared as they are declared within the UserDefinedTypes or within supporting procedures. There is certainly more that can be done.

    Option Explicit

    Private Type ImportantCells
        a As String
        p As String
        q As String
        v As String
        w As String
        x As String
        y As String
        z As String
        ag As String
        ak As String
        an As String
        ao As String
        aq As String
    End Type

    Private Type ImportantRowData
        korfeldatgyogy As String
        kormegngyogy As String
        korhegyedi As String
        korfelvegyed As String
        megbkimegyed As String
        apolhelyegyed As String
        apolhelygyogy As String
        megbkimgyogy As String
        betfoglszovgyogy As String
        eufogl As String
        betmunkgyogy As String
        eufogl2 As String
        munkhelygyogy As String
        kozfogl As String
        kozfogl2 As String
        nevkod As String
        otthon As Boolean
        gyogyult As Boolean
    End Type

    Private Type WorksheetAttributes
        wksht As Worksheet
        evalRange As Range
        rowDetectRange As Range
        lastRow As Long
    End Type

    Private ColoredCellColor As Long

    Sub Gyogit()

        Dim StartTime As Double
        Dim MinutesElapsed As String

        StartTime = Timer
        ColoredCellColor = RGB(210, 65, 65)

    On Error GoTo ErrorExit

        Application.Calculation = xlCalculationManual
        Application.ScreenUpdating = False
        Application.DisplayStatusBar = False
        Application.EnableEvents = False
        ActiveSheet.DisplayPageBreaks = False

        Gyogyit2

    ErrorExit:

        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

    Private Sub Gyogyit2()

        Dim listlastrow As Long
        Dim listlap As Worksheet
        Dim segedlap As Worksheet
        Dim gyogylastrow, listlastrow2, egyedilastrow As Long
        
        Set listlap = ThisWorkbook.Worksheets("lista")
        Set segedlap = ThisWorkbook.Worksheets("segedlap")
        
        Dim gyogylapAttributes As WorksheetAttributes
        gyogylapAttributes.wksht = ThisWorkbook.Worksheets("BE_gyogy")
        
        Dim egyedilapAttributes As WorksheetAttributes
        egyedilapAttributes.wksht = ThisWorkbook.Worksheets("egyedi")
        
        CopyWorkbooks listlap, gyogylapAttributes, egyedilapAttributes
        
        With egyedilapAttributes.wksht
            .Activate
            .Range("E:E").Copy Range("A:A")
            .Columns("A:A").NumberFormat = "0"
        End With
        
        With gyogylapAttributes.wksht
            .Activate
            .Range("I:I").Copy Range("A:A")
            .Columns("A:A").NumberFormat = "0"
        End With
        
        gyogylapAttributes.lastRow = gyogylapAttributes.wksht.Cells(Rows.Count, 1).End(xlUp).row
        egyedilapAttributes.lastRow = egyedilapAttributes.wksht.Cells(Rows.Count, 1).End(xlUp).row
        
        listlastrow = listlap.Cells(Rows.Count, 1).End(xlUp).row
        
        InitializeListlap listlap, listlastrow

        Set gyogylapAttributes.evalRange = gyogylapAttributes.wksht.Range("A1:CM" & gyogylastrow)

        Set egyedilapAttributes.evalRange = egyedilapAttributes.wksht.Range("A1:DZ" & egyedilastrow)
        
        Set gyogylapAttributes.rowDetectRange = gyogylapAttributes.wksht.Range("A:A")

        Set egyedilapAttributes.rowDetectRange = egyedilapAttributes.wksht.Range("A:A")
        
        Dim kitolt As Long
        For kitolt = 2 To listlastrow
            KitoltEvaluation listlap, segedlap, kitolt, gyogylapAttributes, egyedilapAttributes 'gyogylapRange, egyedilapRange, gyogylapRowDetectionRange, egyedilapRowDetectionRange
        Next kitolt
        
        Range("H2").Select
        ActiveCell.FormulaR1C1 = "=COUNTIF(C[+7],RC[+7])"
        Range("E2").Select
        ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[39],RC[40])"
    End Sub

    Private Sub KitoltEvaluation(ByRef listlap As Worksheet, ByRef segedlap As Worksheet, ByVal kitolt As Long, _
                            gyogylapAttributes As WorksheetAttributes, egyedilapAttributes As WorksheetAttributes)

        Dim vangyogy As Long
        Dim vanegyedi As Long
        
    On Error Resume Next

        Dim keyCell As ImportantCells
        keyCell = SetKeyCellValues(listlap, kitolt)
                    
        Dim keyData As ImportantRowData
        
        Dim gyogylapRow As Long
        Dim egyedilapRow As Long
        
        With Application.WorksheetFunction
            vangyogy = .CountIf(gyogylapAttributes.rowDetectRange, keyCell.a)
            gyogylapRow = .Match(keyCell.a, gyogylapAttributes.rowDetectRange, 0)
            vanegyedi = .CountIf(egyedilapAttributes.rowDetectRange, keyCell.a)
            egyedilapRow = .Match(keyCell.a, egyedilapAttributes.rowDetectRange, 0)
        End With
        
        SetKeyDataValues listlap, segedlap, keyData, gyogylapAttributes.wksht, gyogylapRow, vangyogy, egyedilapAttributes.wksht, egyedilapRow, vanegyedi
        
        FormatAndAssignCells listlap, gyogylapAttributes, keyData, keyCell, gyogylapRow, kitolt, vangyogy, vanegyedi
            
    End Sub

    Private Function SetKeyDataValues(ByRef listlap As Worksheet, ByRef segedlap As Worksheet, keyData As ImportantRowData, _
        gyogylap As Range, gyoglapRow As Long, vangyogy As Long, _
        egyedilap As Range, egyedilapRow As Long, vanegyedi As Long) As ImportantRowData
        
        keyData.korfeldatgyogy = gyogylap.Cells(gyoglapRow, 46)
        keyData.kormegngyogy = gyogylap.Cells(gyoglapRow, 47)
        keyData.betfoglszovgyogy = gyogylap.Cells(gyoglapRow, 19)
        keyData.betmunkgyogy = gyogylap.Cells(gyoglapRow, 20)
        keyData.munkhelygyogy = gyogylap.Cells(gyoglapRow, 21)
        keyData.nevkod = gyogylap.Cells(gyoglapRow, 11)
        If vangyogy = 1 Then
            keyData.megbkimgyogy = gyogylap.Cells(gyoglapRow, 49)
            keyData.apolhelygyogy = gyogylap.Cells(gyoglapRow, 33)
        Else
            keyData.megbkimgyogy = vbNullString
            keyData.apolhelygyogy = vbNullString
        End If
        
        keyData.korhegyedi = egyedilap.Cells(egyedilapRow, 32)
        keyData.korfelvegyed = egyedilap.Cells(egyedilapRow, 33)
        If vanegyedi <> vbNullString Then
            keyData.megbkimegyed = egyedilap.Cells(egyedilapRow, 35)
            keyData.apolhelyegyed = egyedilap.Cells(egyedilapRow, 12)
        Else
            keyData.megbkimegyed = vbNullString
            keyData.apolhelyegyed = vbNullString
        End If
        
        With Application.WorksheetFunction
            keyData.eufogl = .CountIf(segedlap.Range("M:M"), keyData.betfoglszovgyogy)
            keyData.eufogl2 = .CountIf(segedlap.Range("M:M"), keyData.betmunkgyogy)
            keyData.kozfogl = .CountIf(segedlap.Range("K:K"), keyData.betmunkgyogy)
            keyData.kozfogl2 = .CountIf(segedlap.Range("K:K"), keyData.betfoglszovgyogy)
        End With
        
        keyData.otthon = Evaluation3(keyData.apolhelygyogy, vanegyedi, "Otthon")
        
        keyData.gyogyult = Evaluation3(keyData.megbkimgyogy, vanegyedi, "Gyógyult")
    End Function

    Private Sub FormatAndAssignCells(ByRef listlap As Worksheet, ByRef gyogylapAttributes As WorksheetAttributes, keyData As ImportantRowData, keyCell As ImportantCells, gyogylapRow As Long, ByVal kitolt As Long, _
        vangyogy As Long, vanegyedi As Long)
        
        Dim alap As Long
        If Evaluation2(keyCell.a) Then
            If AllVbNullString(keyCell.q, keyCell.v, keyCell.w, keyCell.x, keyCell.z, _
                                keyData.korfeldatgyogy, keyData.kormegngyogy, keyData.korhegyedi) And _
                keyData.nevkod <> "comtu001" And _
                keyData.nevkod <> "comtu001" And _
                keyData.nevkod <> "voviv001" And _
                keyData.nevkod <> "rocal006" Then
                
                FormatP listlap, kitolt, keyCell, vangyogy = 1 Or vanegyedi = 1, keyData, alap
                
                FormatY listlap, kitolt, keyCell, vangyogy = 1 Or vanegyedi = 1, keyData
                
            End If
        End If
            
        With listlap
            If keyCell.ak = vbNullString Then
                SetValueAndColor .Range("AK" & kitolt), gyogylapAttributes.evalRange.Cells(gyogylapRow, 54)
            End If
            
            If keyCell.an = vbNullString Then
                SetValueAndColor .Range("AN" & kitolt), gyogylapAttributes.evalRange.Cells(gyogylapRow, 87)
            End If
            
            If keyCell.ao = vbNullString Then
                SetValueAndColor .Range("AO" & kitolt), gyogylapAttributes.evalRange.Cells(gyogylapRow, 88)
            End If
            
            If keyCell.ag = vbNullString Then
                If keyData.eufogl = 1 Then
                    SetValueAndColor .Range("AG" & kitolt), keyData.betmunkgyogy
                    SetValueAndColor .Range("AH" & kitolt), keyData.munkhelygyogy
                    SetValueAndColor .Range("AF" & kitolt), 1
                ElseIf keyData.eufogl2 = 1 And Evaluation2(keyCell.a) Then
                    SetValueAndColor .Range("AG" & kitolt), keyData.betfoglszovgyogy
                    SetValueAndColor .Range("AH" & kitolt), keyData.munkhelygyogy
                    SetValueAndColor .Range("AF" & kitolt), 1
                End If
            End If
            
            If keyCell.aq = vbNullString Then  'Note: aq was never assigned in the original code so thi always evaluated as True
                If keyData.kozfogl = 1 Then
                    SetValueAndColor .Range("AQ" & kitolt), keyData.betmunkgyogy
                    SetValueAndColor .Range("AP" & kitolt), keyData.munkhelygyogy
                ElseIf keyData.kozfogl2 = 1 And Evaluation2(keyCell.a) Then
                    SetValueAndColor .Range("AQ" & kitolt), keyData.betfoglszovgyogy
                    SetValueAndColor .Range("AP" & kitolt), keyData.munkhelygyogy
                End If
            End If
        End With
    End Sub

    Private Function SetKeyCellValues(ByRef listlap As Worksheet, ByVal kitolt As Long) As ImportantCells
        Dim keyCell As ImportantCells
        With listlap
            keyCell.a = .Range("A" & kitolt)
            keyCell.p = .Range("P" & kitolt)
            keyCell.q = .Range("Q" & kitolt)
            keyCell.x = .Range("X" & kitolt)
            keyCell.y = .Range("Y" & kitolt)
            keyCell.z = .Range("Z" & kitolt)
            keyCell.v = .Range("V" & kitolt)
            keyCell.w = .Range("W" & kitolt)
            keyCell.ag = .Range("AG" & kitolt)
            keyCell.ak = .Range("AK" & kitolt)
            keyCell.an = .Range("AN" & kitolt)
            keyCell.ao = .Range("AO" & kitolt)
            keyCell.aq = .Range("AQ" & kitolt)  'Note: aq was never assigned in the original code
        End With
        
        SetKeyCellValues = keyCell
    End Function
        
    Private Sub SetValueAndColor(rangeOfInterest As Range, theValue As Variant)
        rangeOfInterest.Value = theValue
        rangeOfInterest.Font.Color = ColoredCellColor
    End Sub
        
    Private Function AllVbNullString(ParamArray candidates() As Variant) As Boolean
        
        Dim allAreNull As Boolean
        allAreNull = True
        
        Dim candidate As Variant
        For Each candidate In candidates
            If Not candidate = vbNullString Then
                allAreNull = False
            End If
        Next candidate
        
        AllVbNullString = allAreNull

    End Function

    Private Sub InitializeListlap(ByRef listlap As Worksheet, listlastrow As Long)

        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"
            
            Dim x As Long
            For x = 2 To listlastrow
                If .Range("A" & x).Value = vbNullString Then
                    .Range("A" & x).Value = "nincs"
                End If
            Next x
        End With

    End Sub

    Private Sub FormatP(ByRef listlap As Worksheet, ByVal kitolt As Long, ByRef kCell As ImportantCells, _
                ByVal eval4Result As Boolean, ByRef kData As ImportantRowData, ByRef alap As Long)
                
        alap = 1
        If kCell.p = vbNullString And _
                eval4Result And _
                alap = 1 And _
                kData.otthon = True Then
                
            SetValueAndColor listlap.Range("P" & kitolt), 1
        End If
        alap = 0
            
    End Sub

    Private Sub FormatY(ByRef listlap As Worksheet, ByVal kitolt As Long, ByRef kCell As ImportantCells, _
                ByVal eval4Result As Boolean, ByRef kData As ImportantRowData)
                
        With listlap
            If kCell.y = vbNullString And _
                    eval4Result And _
                    .Range("J" & kitolt) < 64 And _
                    Date - .Range("N" & kitolt) > 13 And _
                    kCell.p = 1 And _
                    kData.gyogyult = True Then
                    
                SetValueAndColor .Range("Y" & kitolt), 1
            End If
        End With
            
    End Sub

    Private Function Evaluation2(a As String) As Boolean
        Evaluation2 = a <> vbNullString And a <> "0" And a <> "nincs"
    End Function

    Private Function Evaluation3(toCompare As String, countFound As Long, target As String) As Boolean
        Evaluation3 = ((toCompare = target And countFound <> 1) Or _
            (toCompare = vbNullString And countFound = 1 And toCompare = target) Or _
            (toCompare = target And countFound = 1 And toCompare = target))
    End Function

    Private Sub CopyWorkbooks(ByRef listlap As Worksheet, gyogylapAttributes As WorksheetAttributes, egyedilapAttributes As WorksheetAttributes)
        
        Dim closedBook As Workbook
        
        Application.DisplayAlerts = False
    On Error GoTo ErrorExit
        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 gyogylapAttributes.wksht.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 egyedilapAttributes.wksht.Range("B:DZ")
            closedBook.Close SaveChanges:=False
            
    ErrorExit:
        Application.DisplayAlerts = True

    End Sub

The above code compiles, but only serves as an example of how the program data organization and functions could be done. The code would likely fail if ran against 'real' data as I have no way of replicating your actual data environment to test it. Hope you found this helpful and useful.

\$\endgroup\$
1
  • \$\begingroup\$ A With clause can contribute to (minor) performance improvements because the properties of the object are only "read" once. As an example, using Sheets(1).Range("A1") = "xx"; Sheets(1).Range("A2") = "yy" forces VBA to re-read the Sheets(1) object twice. Refactoring to use With Sheets(1); .Range("A1") = "xx"; .Range("A2") = "yy"; End With will only access the Sheets(1) object once. See this reference (#5) for more information. \$\endgroup\$
    – PeterT
    Dec 2 '20 at 4:07

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.