Solved: My code start to be slow.

[danovkos]

Hi,
pls. can somebody helm me.
I have this macro for actualize my table. In past it takes about 2-3 minutes till this macro done. Now it takes about 15-20 or more minutes.

I can not post sample of my file, only my code.

On beginning of code i turn off all other events, updates of screen and set to manual calculation so i thought, that my other tables, data in this file can not have any impact to this code. Or?

I use Office 2010 on Win XP.

Any suggestions?
thx a lot
[vba]
Sub AKTUALIZACIA_PHdata()

Dim strNewName As String
Dim LastRow As Long
Dim BunkaRiadok As Variant
Dim BunkaStlpec As Variant
Dim chyba As Variant
Dim i As Long

Dim Igor_RangeCIF As Range
Dim PH_RangeUcet As Range

Dim BunkaCIF As Variant
Dim BunkaUcet As Variant

Dim CIFexist As Variant
Dim UcetExist As Variant
Dim RiadokSumOP As Long
Dim SumPrehlAng As Long
Dim SumPrehlOP As Long
Dim Angazovanost As String
Dim OP As String

Dim v_kriz As Variant
Dim v_SankUrok As Variant
Dim v_UrokSadz As Variant
Dim v_Rating As Variant
Dim v_PopisUctu As Variant
Dim v_DruhOP As Variant
Dim v_Matka As Variant
Dim v_Loan As Variant
Dim v_rc As Variant
Dim v_ICO As Variant
Dim v_RevDate As Variant


Dim v_Seg As Variant
Dim v_SegC As Variant

Dim v_PSC As Variant
Dim v_RiskCode As Variant
Dim stlpecAng As Variant
Dim stlpecOP As Variant
Dim v_OPU As String
Dim v_Ang As Variant
Dim v_OP As Variant
Dim sumaOWO As Range
Dim SUMang As Long
Dim SUMop As Long
Dim Hladaj As Range
Dim CisloRiadkuKonca As Long
Dim ang1 As Long
Dim ang2 As Long
Dim OP1 As Long
Dim OP2 As Long

'Call ZrkadloDOprehladov

' If MsgBox("Nastav sa aktívne do PH dát", 292, "") = vbNo Then Exit Sub 'načítaj názov súboru PH dát do premennej
If MsgBox("Nastav sa aktívne do PH dát", vbYesNo + vbDefaultButton1, "NASTAV SA") = vbNo Then Exit Sub 'načítaj názov súboru PH dát do premennej

strNewName = ActiveWindow.Caption
Windows(strNewName).Activate

Range("h1").Select 'začiatok zisťovania ang. a op sumy v PH
Selection.End(xlDown).Select
ActiveCell.Offset(1, -2).Select
SUMop = ActiveCell.Value
ActiveCell.Offset(0, -1).Select
SUMang = ActiveCell.Value 'KONIEC zisťovania ang. a op sumy v PH

' Overovanie posunu stĺpcov v PH súbore
With Workbooks(strNewName).Worksheets("1")
If .Cells(1, "a").Value <> "CIF" Or .Cells(1, "b").Value <> "ACC_NUMB" _
Or .Cells(1, "y").Value <> "Risk_code" Then 'ček hlavičky či sú kde majú byť V PH
MsgBox "CIF nie je A, č. účtu nie je B alebo Risk_code nie je Y. Exit sub"
Exit Sub
End If
End With

Set Igor_RangeCIF = Workbooks(strNewName).Sheets("1").Columns("a:aa")
Set PH_RangeUcet = Workbooks(strNewName).Sheets("1").Columns("b:aa")

Windows(PrehladyNAMEVp).Activate
Sheets("vývoj").Select
Range("bb3").Select

stlpecAng = Workbooks(PrehladyNAMEVp).Worksheets("aktual").Range("af3").Value 'hľadá podľa tabuľky za prehľadmi aký je aktuálny mesiac
stlpecOP = Workbooks(PrehladyNAMEVp).Worksheets("aktual").Range("ag3").Value

Application.Calculation = xlManual
Application.MaxChange = 0.001
Application.EnableEvents = False
Application.ScreenUpdating = False

'spočítaj koľko je CIFov
With Workbooks(PrehladyNAMEVp).Worksheets("vývoj")
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
If .Cells(2, "bb").Value <> "kód RIZIKA" Or .Cells(2, "c").Value <> "CIF" _
Or .Cells(2, "D").Value <> "čísloúčtu" Or .Cells(2, "bq").Value <> "PSC" Then 'Or .Cells(2, "bk").Value <> "DE" Then 'ček hlavičky či sú kde majú byť
MsgBox "Stlpce posun, KRIZ - BB, cif - C, č.účt.-D, PSC - BQ. Exit sub"
Exit Sub
End If
End With
' If MsgBox("Nastav sa aktívne do PH dát", vbYesNo + vbDefaultButton1, "NASTAV SA") = vbNo Then Exit Sub 'načítaj názov súboru PH dát do premennej
If MsgBox("Angažovanosť bude podla C3 z PIV ALL:" & Range(stlpecAng & "2").Value & "(" & stlpecAng & ")" & " OP budu:" & _
Range(stlpecOP & "2").Value & "(" & stlpecOP & ")" & "OK?", vbYesNo + vbDefaultButton1, "NASTAV SA") = vbNo Then GoTo Exits

On Error Resume Next

BunkaRiadok = ActiveCell.Row
BunkaStlpec = ActiveCell.Column

'ček či ide aktualizovať správnu ang. a op -----------------------

' ------------------------------- ***************************** 'začiatok aktualizácie

For i = 4 To LastRow
On Error GoTo dalsi
ActiveCell.Offset(1, 0).Select
BunkaCIF = Cells(ActiveCell.Row, "C").Value
BunkaUcet = Cells(ActiveCell.Row, "D").Value

On Error GoTo dalsi

CIFexist = Application.VLookup(BunkaCIF, Igor_RangeCIF, 1, 0)
UcetExist = Application.VLookup(BunkaUcet, PH_RangeUcet, 1, 0)

If IsError(CIFexist) Then GoTo dalsi

If BunkaCIF = 0 Then GoTo dalsi

'na cif
v_kriz = Application.VLookup(BunkaCIF, Igor_RangeCIF, 7, 0)
v_Rating = Trim(Application.VLookup(BunkaCIF, Igor_RangeCIF, 16, 0))
v_DruhOP = Trim(Application.VLookup(BunkaCIF, Igor_RangeCIF, 10, 0))
v_PSC = Application.VLookup(BunkaCIF, Igor_RangeCIF, 23, 0)
v_RiskCode = Application.VLookup(BunkaCIF, Igor_RangeCIF, 25, 0)
v_OPU = Application.VLookup(BunkaCIF, Igor_RangeCIF, 12, 0)
v_Seg = Application.VLookup(BunkaCIF, Igor_RangeCIF, 13, 0)
v_SegC = Application.VLookup(BunkaCIF, Igor_RangeCIF, 8, 0)
v_RevDate = Application.VLookup(BunkaCIF, Igor_RangeCIF, 26, 0)



v_rc = Application.VLookup(BunkaCIF, Igor_RangeCIF, 15, 0)
v_ICO = Application.VLookup(BunkaCIF, Igor_RangeCIF, 14, 0)

'Cells(ActiveCell.Row, "BB").Value = CDec(v_kriz) 'prepíš existujúci STAV novým stavom
Cells(ActiveCell.Row, "BB").Value = v_kriz 'prepíš existujúci STAV novým stavom
Cells(ActiveCell.Row, "AX").Value = v_Rating
Cells(ActiveCell.Row, "BL").Value = v_DruhOP
Cells(ActiveCell.Row, "BQ").Value = v_PSC

Cells(ActiveCell.Row, "BC").Value = v_OPU

' If v_Seg = "P" Then v_Seg = "R"
Cells(ActiveCell.Row, "BD").Value = v_Seg
Cells(ActiveCell.Row, "BE").Value = v_SegC

If v_RevDate <> 0 Then
Cells(ActiveCell.Row, "BS").Value = v_RevDate
End If

BEZrcICO:

If v_RiskCode <> "" Then
Cells(ActiveCell.Row, "j").Value = v_RiskCode
Else
Cells(ActiveCell.Row, "j").ClearContents
End If

'na účet
If IsError(UcetExist) Then GoTo dalsi
v_SankUrok = Application.VLookup(BunkaUcet, PH_RangeUcet, 18, 0)
v_UrokSadz = Application.VLookup(BunkaUcet, PH_RangeUcet, 19, 0)
v_PopisUctu = Trim(Application.VLookup(BunkaUcet, PH_RangeUcet, 8, 0))
v_Matka = Application.VLookup(BunkaUcet, PH_RangeUcet, 23, 0)
v_Loan = Application.VLookup(BunkaUcet, PH_RangeUcet, 17, 0)

v_Ang = Application.VLookup(BunkaUcet, PH_RangeUcet, 4, 0)
v_OP = Application.VLookup(BunkaUcet, PH_RangeUcet, 5, 0)
v_OPU = Trim(Application.VLookup(BunkaUcet, PH_RangeUcet, 10, 0))

' Cells(ActiveCell.Row, "BB").Value = CDec(v_SankUrok) 'prepíš existujúci STAV novým stavom
Cells(ActiveCell.Row, "av").Value = v_SankUrok 'prepíš existujúci STAV novým stavom
Cells(ActiveCell.Row, "aw").Value = v_UrokSadz
Cells(ActiveCell.Row, "bj").Value = v_PopisUctu
Cells(ActiveCell.Row, "bp").Value = v_Matka
Cells(ActiveCell.Row, "f").Value = v_Loan

If (Cells(ActiveCell.Row, "e").Value <> "SHADOW" And v_OPU = "OWO") Or _
Cells(ActiveCell.Row, "e").Value = "SHADOW" Then
Cells(ActiveCell.Row, stlpecAng).Value = v_Ang '
Cells(ActiveCell.Row, stlpecOP).Value = v_OP
End If

dalsi:
If BunkaCIF = "koniec" Then GoTo koniec
Next

koniec:
Set Hladaj = Columns(3).Find("koniec")
If Not Hladaj Is Nothing Then CisloRiadkuKonca = Hladaj.Row
SumPrehlAng = Range(stlpecAng & CisloRiadkuKonca).Value
SumPrehlOP = Range(stlpecOP & CisloRiadkuKonca).Value

Exits:

Application.Calculation = xlAutomatic
Application.MaxChange = 0.001
Application.ScreenUpdating = True
Application.EnableEvents = True

If SumPrehlAng = SUMang Then
Angazovanost = "OK"
Else
Angazovanost = "zle"
End If

If SumPrehlOP = SUMop Then
OP = "OK"
Else
OP = "zle"
End If


MsgBox "Suma ang. Prehlady:" & Format(SumPrehlAng, "##,##0.00") & " Suma OP Prehlady:" _
& Format(SumPrehlOP, "##,##0.00") & vbNewLine & "Suma ang. PH: " & Format(SUMang, "##,##0.00") _
& " Suma OP PH: " & Format(SUMop, "##,##0.00") & vbNewLine & vbNewLine & "Takže je to " & vbNewLine _
& "Ang=" & Angazovanost & " OP=" & OP

' MsgBox "Aktualizácia PH databázy - done."
' -----------koniec aktualizácie 555555555555555555555555555555555555555555555555


strNewName = ""
LastRow = 0
BunkaRiadok = ""
BunkaStlpec = ""
chyba = ""
i = 0

BunkaCIF = ""
BunkaUcet = ""

CIFexist = ""
UcetExist = ""
RiadokSumOP = 0
SumPrehlAng = 0
SumPrehlOP = 0
Angazovanost = ""
OP = ""

v_kriz = ""
v_SankUrok = ""
v_UrokSadz = ""
v_Rating = ""
v_PopisUctu = ""
v_DruhOP = ""
v_Matka = ""
v_PSC = ""
stlpecAng = ""
stlpecOP = ""
v_OPU = ""
v_Ang = ""
v_OP = ""

SUMang = 0
SUMop = 0
CisloRiadkuKonca = 0
ang1 = 0
ang2 = 0
OP1 = 0
OP2 = 0

End Sub
[/vba]

[danovkos]

i figured out, that it is becasue i started use dynamic range for picture. It is smal functionality in my workbook. It looks to name in cell and show picture of people. When i deleted sheet with pictures, it is again very quick. Its shame, that i can not use this picture future for my wb. Or is here any suggestions how to make workaround that it will works? thx

i have those 2 ranges for looking for pics of people.

DynamicAlbum
[vba]=OFFSET(kontakt!$A$2;;;COUNTA(kontakt!$A$1:$A$508);1)[/vba]
Picture
[vba]=IF(ISERROR(OFFSET(kontakt!$B$2;MATCH(DropDown;DynamicAlbum;0)-1;0));"";OFFSET(kontakt!$B$2;MATCH(DropDown;DynamicAlbum;0)-1;0))[/vba]

[Bob Phillips]

Without an example workbook, I don't think it is reasonable to ask us to work through all of that code for you.

As for that second formula, in 2010 you can use

=IFERROR(OFFSET(kontakt!$B$2;MATCH(DropDown;DynamicAlbum;0)-1;0));"")

[danovkos]

ok, thx.