Macro's uitschakelen van extern geopend excel document.

[Luna08]

Goedemorgen,

Ik heb een excel document welke data kopieert uit een ander document.
Het andere document wordt op de achtergrond uitgevoerd en met de volgende functie opgeroepen:

app.Workbooks.Add(Application.GetOpenFilename)

Echter duurt het kopiëren van de data zeer lang, dit komt o.a. doordat er 3000+ regels vergeleken worden maar ik vrees ook doordat het document welke op de achtergrond geopend wordt eerst een grote macro uitvoert. Deze wordt namelijk automatisch gestart bij het openen.

Is er een mogelijkheid het 2e document te open met de macro functie uitgeschakeld?

Alvast bedankt.

 

[wampier]

Dat is afhankelijk of "auto_run" wordt gebruikt of "workbook_open", volgens mij. Auto_run wordt niet uitgevoerd wanneer de file wordt geopend via een macro, workbook_open wel.

Je kunt:

Application.EnableEvents = False
app.Workbooks.Add(Application.GetOpenFilename)
Application.EnableEvents = true

proberen

 

[Luna08]

Bedankt voor je reactie, echter nog weinig resultaat.

Er wordt gebruik gemaakt van workbook_open.
Ik heb alle data van de sheet gekopieerd naar een ander excel document zonder macro's, dan verwerkt hij alles in ongeveer 30-60sec.
In het bestand met de macro's heb ik geen idee, na een half uur heb ik het maar afgebroken.

Volgens mij ligt het dus niet aan inefficiëntie van mijn code?

 

[wampier]

Mogelijk zitten er nog andere macro's in je doelbestand? de workbook_open wordt als het goed is gestopt door de : "Application.EnableEvents = False". Indien er nog andere macro's worden gebruikt, EnableEvents op false houden totdat je klaar bent.

er zijn nog wat andere settings die het kopieeren kunnen versnellen:

application.ScreenUpdating = false
application.Calculation =xlCalculationManual

terugzetten met

application.ScreenUpdating = true
application.Calculation = xlCalculationAutomatic
application.calculate

 

[Luna08]

Helaas weer geen verbetering, in het doel bestand zitten inderdaad ook andere macro's, op deze macro's heb ik geen invloed, bestand wordt aangeleverd.

 

[wampier]

"enableevents" zou een deel van die macro's uit moeten zetten. Zitten er mogelijk beveiligde cellen in die je probeert te overschrijven? Ik kan anders eigenlijk anders niets meer bedenken waarom het wel zou werken op een leeg document en niet op het andere.

 

[Luna08]

Hoi Wampier,

In het extra geopende bestand wordt niets geschreven, enkel gezocht en gekopieerd.
Met de volgende code zoek ik naar een waarde welke voorkomt in beide bestanden:

If Sheets("naam blad").Cells(i, 1) = "" Then
            Set rFound = lijst_oud.Sheets("naam blad").Cells.Find(What:=Sheets("naam blad").Cells(i, 2), After:=lijst_oud.Sheets("naam blad").Range("B1"), LookIn:=xlValues, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _

Als er dan een overeenkomst gevonden wordt controleert hij of de cel ernaast een waarde bevat. Is dit het geval dan wordt deze gekopieerd.

Sheets("naam blad").Cells(i, 1).Value = lijst_oud.Sheets("naam blad").Cells(RijNR, 1).Value

en dit dus tussen de 2000 en 4000 keer ofzo

 

[wampier]

Een aantal opmerkingen:

1) Als je weet in welke kolommen gezocht moet worden is dat beter die te specificeren in plaats van de hele sheet doorzoeken
2) rFound is all een range. dus als je de cel (rechts-)ernaast wil hebben kun je rFound.offset(0,1) gebruiken.

 

[Luna08]

Hoi Wampier,

Bedankt voor de tips, dat zal het zeker beter maken.

Ik heb nog het volgende geprobeerd:

Boven in de code gebruik ik de volgende regel om het bereik van kolom B te bepalen:

einde = Range("B65536").End(xlUp).Row

Vervolgens:

For i = 6 To einde

Als ik einde aanpas voor bijv. 200 dan werkt het prima, maak ik er 500 van dan gaat het weer fout.
Als ik via taskmanager kijk dan zie ik opvallend weinig cpu gebruik bij het 1ste bestand, bij het op de achtergrond geopende bestand is het cpu gebruik 50%.

Kan dat nog iets betekenen?

 

[wampier]

Dat betekend mogelijk dat je een dual-core processor hebt waarbij 1 core helemaal vast loopt

Dat lijkt te duiden op een "loop" of iets dergelijks. Zonder de bestanden of een voorbeeld waarbij het probleem zich voordoet is dat echter moeilijk te bepalen. Wat als je "i" van 300-500 laat lopen? gaat het dan fout of ook weer goed?

De code die je tot nu toe liet zien zou geen aanleiding moeten geven tot vastlopen (normaal gesproken)

 

[Warme bakkertje]

Bij zulke zoekacties(2000 tot 4000 keer) zou ik toch eens bekijken of deze actie in het werkgeheugen kan uitgevoerd worden ipv het schijfgeheugen. Nu ga je bij elke zoekactie telkens een variabele instellen, wat mi de boel enorm vertraagd. Kan je beide bereiken niet in arrays gieten en deze dan met elkaar vergelijken en uitwerken en het resultaat in 1 keer wegschrijven naar je doelbestand ipv voor elke regel apart ?

 

[Luna08]

Hoi Warme bakkertje,

Helaas heb ik geen enkele ervaring met arrays, maar duurt het kopiëren van deze data in de array ook niet heel lang?
Als je een simpel voorbeeld voor me hebt, zou ik het dolgraag eens bekijken.

Edit: google doet uiteraard weer wonderen, het vullen van één of meerdere arrays dat lukt.
echter zou ik niet weten hoe ik het nu moet aan pakken:

In kolom B van werkmap_oud zoek ik waardes welke in werkmap_nieuw staat (ook kolom B).
Als er een overeenkomst wordt gevonden wordt in kolom A van werkmap_nieuw gekeken of er al een waarde staat. Als dit niet zo is wordt de waarde van de cel in kolom A (naast de overeenkomst) werkmap_oud gekopieerd naar kolom a werkmap_nieuw.

Hoe zorg ik nu (in een efficiënte) code dat er gezocht wordt naar een overeenkomst en dat de waarde uit kolom a wordt gekopieerd.

Alvast bedankt voor alle hulp

 

[Warme bakkertje]

Om te testen zet je beide bereiken in een nieuw bestand kolomA en B van werkmap oud in kolom A en B v/h testbestand kolom A en b van werkmap nieuw in kolom C en D v/h testbestand.
Pas dan eventueel de bereiken aan in onderstaande macro en laat 'm eens lopen, in een msgbox krijg je dan de verstreken tijd.
Dit alles is nu rechttoe rechtaan maar als het werkt kunnen we het aanpassen aan de werkelijke situatie

Sub tst()
t = Timer
sq = Range("A2:B4001") 'Range werkmap oud
sq2 = Range("C2:D4001") 'Range werkmap nieuw
On Error Resume Next
For i = 1 To UBound(sq2)
    For j = 1 To UBound(sq)
        If sq2(i, 2) = sq(j, 2) Then
            If sq2(i, 1) = "" Then sq2(i, 1) = sq(j, 1)
        End If
    Next
Next
Range("C2").Resize(UBound(sq2), 2) = sq2
MsgBox Timer - t
End Sub

 

[Luna08]

Hoi Rudi,

Bedankt, wat een geweldige code en ik lijk het nog enigszins te begrijpen ook
Let wel, enigszins... Zodra ik dit weer met het externe document wil doen gaat het fout...
Dit heb ik nu:

Dim app As New Excel.Application
Dim lijst_oud As Excel.Workbook
app.Visible = False

Set lijst_oud = app.Workbooks.Add(Application.GetOpenFilename)
Set lijst_new = ThisWorkbook

sq = lijst_oud.Sheets("blad1").Range("A6:A4001;B6:B4001") 'Range werkmap oud
sq2 = lijst_new.Sheets("blad1").Range("A6:A4001;B6:B4001") 'Range werkmap nieuw
On Error Resume Next
For i = 1 To UBound(sq2)
    For j = 1 To UBound(sq)
        If sq2(i, 2) = sq(j, 2) Then
            If sq2(i, 1) = "" Then sq2(i, 1) = sq(j, 1)
        End If
    Next
Next
Range("C2").Resize(UBound(sq2), 2) = sq2
MsgBox Timer - t

lijst_oud.Close SaveChanges:=False
app.Quit
Set app = Nothing

Echter gaat hij op de regel van sq2= fout.
Het maakt niet uit of ik lijst_new er voor zet of niet.

Enig idee hoe dit veroorzaakt wordt?

 

[Mark xl]

Ik denk dat het nog "iets" makkelijker kan...

namelijk met gewone formules. (het is nog sneller ook.)

Sub Beat_this()
'waarom moeilijk doen als het makkelijk kan.
'vul een formule in en vervang deze door waarden

Const OUD_BLAD As String = "Blad1"  'de naam van het blad in de werkmap lijst_oud
Const LAATSTE_RIJ As Long = 4001    'de laatste rij op het werkblad waar je wilt zoeken

Dim einde As Long       'de laatste rij
Dim part1 As String     'deel 1 van formule
Dim part2 As String     'deel 2 van formule
Dim formule As String   'de volledige formule

Dim lijst_oud As Excel.Workbook     'de werkmap met de oude data
Dim Openfile As Variant            'de naam van het blad met de te kopieeren data

    Openfile = Application.GetOpenFilename
    'annuleren = stille aftocht

    If Openfile <> False Then

        Set lijst_oud = Workbooks.Open(Openfile)

        einde = LAATSTE_RIJ     'stel het einde in op de laatste rij

        'index-match formule om waarden op te zoeken
        part1 = "INDEX('[" & lijst_oud.Name & "]" & OUD_BLAD & "'!C1:C2," & _
                                "MATCH(RC[1],'[" & lijst_oud.Name & "]" & OUD_BLAD & "'!C2,0),1)"

        'deel van formule om niets te tonen als er niets is gevonden
        part2 = "IF(ISNA(MATCH(RC[1],'[" & lijst_oud.Name & "]" & OUD_BLAD & "'!C2,0)),"""","

        formule = "=" & part2 & part1 & ")"

        'formule invullen en vervangen door waarden.
        With ThisWorkbook.Sheets("Blad1").Range("A1:A" & einde)

            .Formula = formule
            .Value = .Value

        End With
    
    End If

    Set lijst_oud = Nothing

End Sub

desgewenst nog even "Application.enableevents" e.d. uit en inschakelen naar behoefte

 

[Warme bakkertje]

Dan kan je hem nog sneller maken door dit

.Value = .Value

te vervangen door

.Copy
.PasteSpecial xlPasteValues
Application.CutCopyMode = False

 

[Luna08]

Heren, wederom bedankt voor jullie hulp.

Beide codes zijn super, echter 1 opmerking aan de code van Mark:
Als in het nieuwe document al een waarde in kolom A staat dan wordt deze overschreven.
In de code van Mark (deze snap ik namelijk niet helemaal qua werking) weet ik niet waar ik de if then? code neer moet zetten.

Tevens wordt het oude bestand niet afgesloten, dit kan ik neem ik aan nog altijd het beste oplossen met app.quit en savechanges = False?

 

[Mark xl]

Wat ik doe met die part1, part2, formule variabelen
Ik bouw een Excel formule op, die de gegevens ophaalt uit de geopende werkmap.Als je goed kijkt herken je allemaal engels vertaalde worksheet formules (want in vba werk je alleen met engelse formulenamen)

Excel formules zijn namelijk supersnel in vergelijking met VBA code met een vergelijkbare aanpak

vervolgens vervang ik de formules met waarden met een trucje, zodat je niet copy, pastespecial hoeft te gebruiken, dat scheelt ook weer tijd / scherm activiteit.

1. Als in het nieuwe document al een waarde in kolom A staat dan wordt deze overschreven.

2 .Tevens wordt het oude bestand niet afgesloten, dit kan ik neem ik aan nog altijd het beste oplossen met app.quit en savechanges = False?

1. dat is opgelost. nu wordt de oude waarde ingevuld als deze al bestaat, en anders de nieuwe waarde uit het zoekdocument.

2. Ik was dat inderdaad vergeten! nu wordt de werkmap afgesloten!
Je hoeft geen application te sluiten want ik heb een nieuwe werkmap in de bestaande applicatie geopend. Alleen de werkmap behoeft te worden afgesloten.

succes.

Sub Beat_this()
'waarom moeilijk doen als het makkelijk kan.
'vul een formule in en vervang deze door waarden

Const OUD_BLAD As String = "Blad1"  'de naam van het blad in de werkmap lijst_oud
Const LAATSTE_RIJ As Long = 4001    'de laatste rij op het werkblad waar je wilt zoeken

Dim einde As Long       'de laatste rij
Dim part1 As String     'deel 1 van formule
Dim part2 As String     'deel 2 van formule
Dim formule As String   'de volledige formule

Dim lijst_oud As Excel.Workbook     'de werkmap met de oude data
Dim Openfile As Variant            'de naam van het blad met de te kopieeren data

    Application.EnableEvents = False

    Openfile = Application.GetOpenFilename
    'annuleren = stille aftocht

    If Openfile <> False Then

        Set lijst_oud = Workbooks.Open(Openfile)

        einde = LAATSTE_RIJ     'stel het einde in op de laatste rij

        'index-match formule om waarden op te zoeken
        part1 = "INDEX('[" & lijst_oud.Name & "]" & OUD_BLAD & "'!C1:C2," & _
                                "MATCH(RC[2],'[" & lijst_oud.Name & "]" & OUD_BLAD & "'!C2,0),1)"

        'deel van formule om niets te tonen als er niets is gevonden
        part2 = "IF(OR(NOT(ISBLANK(RC[1])),ISNA(MATCH(RC[2],'[" & lijst_oud.Name & "]" & OUD_BLAD & "'!C2,0))),RC[1],"

        formule = "=" & part2 & part1 & ")"

        'formule invullen en vervangen door waarden.
        
        ThisWorkbook.Sheets("Blad1").Columns("A").Insert
        
        With ThisWorkbook.Sheets("Blad1").Range("A2:A" & einde)
            
            .Formula = formule
            .Value = .Value

        End With
        
        ThisWorkbook.Sheets("Blad1").Columns("B").Delete
        
        lijst_oud.Close False       'het document afsluiten
    
    End If

    Application.EnableEvents = True
    Set lijst_oud = Nothing

End Sub

 

[Luna08]

Hoi Mark,

Bedankt voor je input. Nu krijg ik alleen bij cellen die niet gebruikt worden (hij begint bij rij 6, dus 2 t/m 5, en eindigt nu bij rij 2337, dus 2338 t/m 4001) een "0" ingevuld.

Volgens mij komt dit door de regel:

ThisWorkbook.Sheets("Blad1").Columns("A").Insert

Klopt dat?

Kan ik het start bereik op cel 6 zetten door deze aan te passen:

With ThisWorkbook.Sheets("AMS cable overview1").Range("A2:A" & einde)

in

With ThisWorkbook.Sheets("AMS cable overview1").Range("A6:A" & einde)

 

[Mark xl]

yep dat klopt

je kunt ook

einde = LAATSTE_RIJ     'stel het einde in op de laatste rij

vervangen door

einde = ThisWorkbook.Sheets("AMS cable overview1").Range("B9999").end(xlUp).row    'stel het einde in op de laatste gevonden rij

dan wordt het formulebereik dynamisch en heb je ook geen last meer van die nullen