Bez přílohy?
P.citovat
P.citovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: Pád Excelu po zaplnění paměti
Tak tohle je nejhodnotnější příspěvek vůbec! Ne fakt, hrozně mi to pomohlo a život je hned lepší!
Tyhle kecy si nechte příště od cesty a věnujte čas něčemu užitečnějšímu, když už kritice, tak věcné a konkrétní, to co jste napsal ničemu/nikomu nepomůže...citovat
MS Excel
Téma: Pád Excelu po zaplnění paměti 
Zaslal/a vencaxxx 6.3.2017 13:35
Dokázal by někdo poradit jak upravit makro tak aby využívalo méně systémových prostředků? Mám 64bit Win7 ale 32bit Excel. Makro jsou 2 cykly, jeden prochází cca 9000 řádků a na každém spustí cyklus který prochází dalších cca 2500 řádků v jiném listu. Porovnávají se záznamy a vkládají se odkazy na jiné soubory pomocí vzorců. Makro běží několik hodin ale nikdy nedoběhne protože se zaplní paměť (cca 1,6GB) a Excel zkolabuje, výsledek nelze uložit, nic.
Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim sPath As String
sPath = "\\cesta\"
Dim lastrow As Long
On Error Resume Next
lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row - 1
y = 0
yy = 0
'ulozeno = 0
y = Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
End If
Dim i As Long
Dim test_cesta As String
For x = 2 To lastrow
For i = 1 To y
If Mid(Worksheets(jmeno2).Cells(x, 3), InStr(1, Worksheets(jmeno2).Cells(x, 3), "+") + 1, 1) = "H" Then
test_str = Left(Worksheets(jmeno2).Cells(x, 3), InStr(1, Worksheets(jmeno2).Cells(x, 3), "+") - 1)
Else
test_str = Worksheets(jmeno2).Cells(x, 3)
End If
If InStr(1, Worksheets("Data").Cells(i, 1), test_str) <> 0 Then
' test_cesta = Worksheets("Data").Cells(i, 2).Text
test_cesta = Worksheets("Data").Cells(i, 2).Text
test1 = GetInfoFromClosedFile(Replace(Worksheets("Data").Cells(i, 2), Worksheets("Data").Cells(i, 1), ""), Worksheets("Data").Cells(i, 1), "Summary", "A1")
If IsError(test1) Then
test3 = GetInfoFromClosedFile(Replace(Worksheets("Data").Cells(i, 2), Worksheets("Data").Cells(i, 1), ""), Worksheets("Data").Cells(i, 1), "List1", "A1")
If IsError(test3) Then
Worksheets(jmeno2).Cells(x, 15) = "xxx"
Else
jmeno_listu = "List1'!$Z$7"
Worksheets(jmeno2).Cells(x, 16).FormulaLocal = "=" & "'" & _
Left(test_cesta, InStrRev(test_cesta, "\")) & "[" & _
Right(test_cesta, Len(test_cesta) - InStrRev(test_cesta, "\")) _
& "]" & jmeno_listu
Worksheets(jmeno2).Cells(x, 16).Value = Worksheets(jmeno2).Cells(x, 16).Value * 3600
If Round(Val(Worksheets(jmeno2).Cells(x, 16)), 2) <> Round(Val(Worksheets(jmeno2).Cells(x, 13)), 2) Then
Worksheets(jmeno2).Cells(x, 16).Font.Color = RGB(255, 0, 0)
Else
Worksheets(jmeno2).Cells(x, 16).Font.Color = RGB(0, 255, 0)
End If
End If
Else
jmeno_listu = "Summary'!$J$13"
jmeno_listu2 = "Summary'!$O$12"
Worksheets(jmeno2).Cells(x, 15).FormulaLocal = "=" & "'" & _
Left(test_cesta, InStrRev(test_cesta, "\")) & "[" & _
Right(test_cesta, Len(test_cesta) - InStrRev(test_cesta, "\")) _
& "]" & jmeno_listu
Worksheets(jmeno2).Cells(x, 15).Value = Worksheets(jmeno2).Cells(x, 15).Value
Worksheets(jmeno2).Cells(x, 16).FormulaLocal = "=" & "'" & _
Left(test_cesta, InStrRev(test_cesta, "\")) & "[" & _
Right(test_cesta, Len(test_cesta) - InStrRev(test_cesta, "\")) _
& "]" & jmeno_listu2
Worksheets(jmeno2).Cells(x, 16).Value = Worksheets(jmeno2).Cells(x, 16).Value
' If Worksheets(jmeno2).Cells(x, 15).Value = "" Then
' Worksheets(jmeno2).Cells(x, 15).Value = 1
' Else
' Worksheets(jmeno2).Cells(x, 15).Value = Worksheets(jmeno2).Cells(x, 15).Value
' End If
If Round(Val(Worksheets(jmeno2).Cells(x, 16)) * Val(Worksheets(jmeno2).Cells(x, 15)), 2) <> Round(Val(Worksheets(jmeno2).Cells(x, 13)), 2) Then
Worksheets(jmeno2).Cells(x, 16).Font.Color = RGB(255, 0, 0)
Else
Worksheets(jmeno2).Cells(x, 16).Font.Color = RGB(0, 255, 0)
End If
End If
DoEvents
Exit For
End If
Application.StatusBar = "3. (Checking of data) Progress: " & x - 1 & " of " & lastrow - 1 & ": " & Format((x - 1) / (lastrow - 1), "0%") & " | "
' Application.StatusBar = "Progress: " & Format((x - 1) / (lastrow - 1), "0%")
DoEvents
test_str = Nothing
test1 = Nothing
test3 = Nothing
Next i
' End If
DoEvents
Application.CutCopyMode = False
ThisWorkbook.Save
Next x
x = Empty
y = Empty
yy = Empty
lastrow = Empty
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ThisWorkbook.Save
End Sub
soubor dát nemůžu, obsahuje firemní data a linky na externí soubory, tzn. stejně by to nefungovalo.citovat
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim sPath As String
sPath = "\\cesta\"
Dim lastrow As Long
On Error Resume Next
lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row - 1
y = 0
yy = 0
'ulozeno = 0
y = Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
End If
Dim i As Long
Dim test_cesta As String
For x = 2 To lastrow
For i = 1 To y
If Mid(Worksheets(jmeno2).Cells(x, 3), InStr(1, Worksheets(jmeno2).Cells(x, 3), "+") + 1, 1) = "H" Then
test_str = Left(Worksheets(jmeno2).Cells(x, 3), InStr(1, Worksheets(jmeno2).Cells(x, 3), "+") - 1)
Else
test_str = Worksheets(jmeno2).Cells(x, 3)
End If
If InStr(1, Worksheets("Data").Cells(i, 1), test_str) <> 0 Then
' test_cesta = Worksheets("Data").Cells(i, 2).Text
test_cesta = Worksheets("Data").Cells(i, 2).Text
test1 = GetInfoFromClosedFile(Replace(Worksheets("Data").Cells(i, 2), Worksheets("Data").Cells(i, 1), ""), Worksheets("Data").Cells(i, 1), "Summary", "A1")
If IsError(test1) Then
test3 = GetInfoFromClosedFile(Replace(Worksheets("Data").Cells(i, 2), Worksheets("Data").Cells(i, 1), ""), Worksheets("Data").Cells(i, 1), "List1", "A1")
If IsError(test3) Then
Worksheets(jmeno2).Cells(x, 15) = "xxx"
Else
jmeno_listu = "List1'!$Z$7"
Worksheets(jmeno2).Cells(x, 16).FormulaLocal = "=" & "'" & _
Left(test_cesta, InStrRev(test_cesta, "\")) & "[" & _
Right(test_cesta, Len(test_cesta) - InStrRev(test_cesta, "\")) _
& "]" & jmeno_listu
Worksheets(jmeno2).Cells(x, 16).Value = Worksheets(jmeno2).Cells(x, 16).Value * 3600
If Round(Val(Worksheets(jmeno2).Cells(x, 16)), 2) <> Round(Val(Worksheets(jmeno2).Cells(x, 13)), 2) Then
Worksheets(jmeno2).Cells(x, 16).Font.Color = RGB(255, 0, 0)
Else
Worksheets(jmeno2).Cells(x, 16).Font.Color = RGB(0, 255, 0)
End If
End If
Else
jmeno_listu = "Summary'!$J$13"
jmeno_listu2 = "Summary'!$O$12"
Worksheets(jmeno2).Cells(x, 15).FormulaLocal = "=" & "'" & _
Left(test_cesta, InStrRev(test_cesta, "\")) & "[" & _
Right(test_cesta, Len(test_cesta) - InStrRev(test_cesta, "\")) _
& "]" & jmeno_listu
Worksheets(jmeno2).Cells(x, 15).Value = Worksheets(jmeno2).Cells(x, 15).Value
Worksheets(jmeno2).Cells(x, 16).FormulaLocal = "=" & "'" & _
Left(test_cesta, InStrRev(test_cesta, "\")) & "[" & _
Right(test_cesta, Len(test_cesta) - InStrRev(test_cesta, "\")) _
& "]" & jmeno_listu2
Worksheets(jmeno2).Cells(x, 16).Value = Worksheets(jmeno2).Cells(x, 16).Value
' If Worksheets(jmeno2).Cells(x, 15).Value = "" Then
' Worksheets(jmeno2).Cells(x, 15).Value = 1
' Else
' Worksheets(jmeno2).Cells(x, 15).Value = Worksheets(jmeno2).Cells(x, 15).Value
' End If
If Round(Val(Worksheets(jmeno2).Cells(x, 16)) * Val(Worksheets(jmeno2).Cells(x, 15)), 2) <> Round(Val(Worksheets(jmeno2).Cells(x, 13)), 2) Then
Worksheets(jmeno2).Cells(x, 16).Font.Color = RGB(255, 0, 0)
Else
Worksheets(jmeno2).Cells(x, 16).Font.Color = RGB(0, 255, 0)
End If
End If
DoEvents
Exit For
End If
Application.StatusBar = "3. (Checking of data) Progress: " & x - 1 & " of " & lastrow - 1 & ": " & Format((x - 1) / (lastrow - 1), "0%") & " | "
' Application.StatusBar = "Progress: " & Format((x - 1) / (lastrow - 1), "0%")
DoEvents
test_str = Nothing
test1 = Nothing
test3 = Nothing
Next i
' End If
DoEvents
Application.CutCopyMode = False
ThisWorkbook.Save
Next x
x = Empty
y = Empty
yy = Empty
lastrow = Empty
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ThisWorkbook.Save
End Sub
soubor dát nemůžu, obsahuje firemní data a linky na externí soubory, tzn. stejně by to nefungovalo.citovat
Nevím, jak se mi to stalo,ale i přes toto
soubor dát nemůžu, obsahuje firemní data a linky na externí soubory, tzn. stejně by to nefungovalo.
a přes to, že jste to ani nevložil do code
i přes to jsem se kouknul.
A řeknu vám, že tenhle kód nemůže jet několik hodin, ba dokonce ani minut a ani vteřin.
Takže tak nějak.citovat
soubor dát nemůžu, obsahuje firemní data a linky na externí soubory, tzn. stejně by to nefungovalo.
a přes to, že jste to ani nevložil do code
i přes to jsem se kouknul.
A řeknu vám, že tenhle kód nemůže jet několik hodin, ba dokonce ani minut a ani vteřin.
Takže tak nějak.citovat
To makro funguje jak jsem popsal, akorát jsem ho upravil abych ho sem mohl vložit.citovat
(7.3.2017 17:26)#035327
No pokud tady předhodíš vykuchaný kód, nemůžeš očekávat, že si někdo bude chybějíci řádky domýšlet.
Problém může být zrovna v nich.
A jen má doměnka:
GetInfoFromClosedFile() předpokládám, že ExecuteExcel4Macro()
No 9000 * 2500 * 2 ???
Do toho bych nešel.citovat
Problém může být zrovna v nich.
A jen má doměnka:
GetInfoFromClosedFile() předpokládám, že ExecuteExcel4Macro()
No 9000 * 2500 * 2 ???
Do toho bych nešel.citovat
Ani som sa nesnažil ten kód čítať.
Ale keď píšeš,že to funguje, tak v čom je potom problém?citovat
Ale keď píšeš,že to funguje, tak v čom je potom problém?citovat
(8.3.2017 1:08)#035351
Koule moje křišťálová, zjev mi to zlo v kódu VBA...
No prej v tom kódu hrajete něco jako slovní fotbal. Přehazujete si texty, názvy a kdo ví, co ještě jako horký brambor. Asi dobrej koncept. Jo a nakonec se mi zjevila kapitola, jak Pejsek s kočičkou vařili dort. Pak koule potemněla a víc jsem z ní nedostal. Teda než zhasla, tak byla sprostá a viděl jsem sám sebe, jak si ťukám na čelo.
Ale je podstatné vědět, že paměť se zaplnila z 1,6 GB. Víte co, dejte ruce od Excelu a běžte pryč. Nejde o to, jak zčuněný je kód, ale že nepřemýšlíte hlavou, a jste schopen sem předhodit tenhle chuchvalec kódu a čekat zázrak. Padá hvězda, něco si přejte.citovat
No prej v tom kódu hrajete něco jako slovní fotbal. Přehazujete si texty, názvy a kdo ví, co ještě jako horký brambor. Asi dobrej koncept. Jo a nakonec se mi zjevila kapitola, jak Pejsek s kočičkou vařili dort. Pak koule potemněla a víc jsem z ní nedostal. Teda než zhasla, tak byla sprostá a viděl jsem sám sebe, jak si ťukám na čelo.
Ale je podstatné vědět, že paměť se zaplnila z 1,6 GB. Víte co, dejte ruce od Excelu a běžte pryč. Nejde o to, jak zčuněný je kód, ale že nepřemýšlíte hlavou, a jste schopen sem předhodit tenhle chuchvalec kódu a čekat zázrak. Padá hvězda, něco si přejte.citovat
xlnc napsal/a:
Koule moje křišťálová, zjev mi to zlo v kódu VBA...
No prej v tom kódu hrajete něco jako slovní fotbal. Přehazujete si texty, názvy a kdo ví, co ještě jako horký brambor. Asi dobrej koncept. Jo a nakonec se mi zjevila kapitola, jak Pejsek s kočičkou vařili dort. Pak koule potemněla a víc jsem z ní nedostal. Teda než zhasla, tak byla sprostá a viděl jsem sám sebe, jak si ťukám na čelo.
Ale je podstatné vědět, že paměť se zaplnila z 1,6 GB. Víte co, dejte ruce od Excelu a běžte pryč. Nejde o to, jak zčuněný je kód, ale že nepřemýšlíte hlavou, a jste schopen sem předhodit tenhle chuchvalec kódu a čekat zázrak. Padá hvězda, něco si přejte.
Tak tohle je nejhodnotnější příspěvek vůbec! Ne fakt, hrozně mi to pomohlo a život je hned lepší!
Tyhle kecy si nechte příště od cesty a věnujte čas něčemu užitečnějšímu, když už kritice, tak věcné a konkrétní, to co jste napsal ničemu/nikomu nepomůže...citovat
Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články