Performance verbeteren

Status
Niet open voor verdere reacties.
A

Arno1969

Gebruiker
Lid geworden
24 apr 2017
Berichten
15
Beste forumleden

Leren en verbeteren is mijn credo.

Op dit moment wordt er geautomatiseerd een nieuwe map aangemaakt aan de hand van een standaard map. Met andere woorden als er een nieuwe map gemaakt dient te worden dan vult men een unieke code in (kolom D) en de standaard map wordt gekopieerd naar een bepaalde directory met dat unieke nummer. Dit unieke nummer wordt ook opgeslagen in een verzamelblad (bijgevoegd bestand) met een hyperlink (kolom L) naar de directory waar het dossier te vinden is onder het unieke nummer. Het verzamelblad wordt gebruikt om info te delen (kolommen M en verder). Dit werkt perfect. De performance wordt echter (logischerwijs) steeds trager van het verzamelblad omdat elke wijziging / aanvulling zorgt voor het bekende draaiende rondje. Nu denk ik dat eea komt door onderstaande code. De wens is nu dat alleen wanneer in kolom D een nieuw nummer wordt ingevoerd er een enter wordt gegeven er nieuwe map wordt gegenereerd en dat niet bij elke wijziging het rondje begint te draaien.

het probleem zit waarschijnlijk in onderstaand stukje code.

For Row = 2 To 1000
If Cells(Row, 4).Value = "" Then
Exit For
End If


Dank alvast.


PS alvorens ik een vraag stel probeer ik altijd e.e.a. zelf uit te vogelen (o.a. door het forum uit te pluizen)
 

Bijlagen

  • -lijst - kopie.xlsm
    904,8 KB · Weergaven: 48
Bijv.

Code: 
    SaveCopyAs ThisWorkbook.Path & "\Backup\lijst" & Format(date, " yyyymmdd") & ".xlsb"
in plaats van

Code: 
    SaveCopyAs ThisWorkbook.Path & "\" & "Back-up" & "\" & "-lijst" & Format(Now, " yymmdd") & ".xlsm"

en verwijder in ieder geval:

Code: 
Private Sub Workbook_Open()
    
    Columns("B:B").Select
    Selection.Style = "Currency"
    
    Cells.Select
    With Selection.Font
        .Name = "Arial"
        .Size = 14
    End With
    
End Sub

Vermijd altijd 'Select' en 'Activate' in VBA.
En formatteer nooit een heel werkblad.

Waarom wordt een hele directory gekopieerd ? Wat bevindt zich in die directory ?
 
Laatst bewerkt:
Beste Snb

Allereerst dank voor de aanpassing aan de code en ik zal deze verwerken.

? Waarom wordt een hele directory gekopieerd ? Wat bevindt zich in die directory ? De directory bestaat uit 3 mappen die gevuld moeten worden met documenten ter controle.
? En formatteer nooit een heel werkblad. Is in de haast gedaan, normaal is dit ook niet nodig
? Vermijd altijd 'Select' en 'Activate' in VBA Duidelijk, de code zorgt ervoor dat bij het opstarten oa het lettertype genormaliseerd wordt

blijft : is het mogelijk dat pas na een enter gegeven in kolom D de VBA-code gaat lopen. Mijn collega en ik vinden dit een leuke uitdaging.

Groet
 
Laatst bewerkt:
Maak gebruik van de variabele Target
Je krijgt dan zoiets:
Code: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal [COLOR="#FF0000"]Target[/COLOR] As Range)
  If [COLOR="#FF0000"]Target[/COLOR].Column = 4 And [COLOR="#FF0000"]Target[/COLOR].Count = 1 Then
    Application.EnableEvents = False
    Srcfolder = ("\\asp.woonpartners-mh.nl\dfs\Afdelingen\Shared\K&V\0 Verhuur\Verhuurmutaties\Overzicht\Niet gebruiken!\Mutatie dossier\")
    CreateObject("shell.application").Namespace("\\asp.woonpartners-mh.nl\dfs\Afdelingen\Shared\K&V\0 Verhuur\Verhuurmutaties\Overzicht\Woningen\"). _
    newfolder Cells([COLOR="#FF0000"]Target[/COLOR].Row, 31).Value
    
    On Error Resume Next
    
    Targetfolder = ("\\asp.woonpartners-mh.nl\dfs\Afdelingen\Shared\K&V\0 Verhuur\Verhuurmutaties\Overzicht\Woningen\" & Cells([COLOR="#FF0000"]Target[/COLOR].Row, 31).Value & "\")
    CreateObject("Scripting.FileSystemObject").GetFolder(Srcfolder).Copy Targetfolder, False
    Application.EnableEvents = True
  End If
End Sub
 
Beste VenA

Ik ga hem uitproberen en mocht het lukken dan staat er een taart met koffie / thee klaar (mocht je deze willen).

Groeten

Arno1969
 
Zo kopieer je een directory:

Code: 
Sub M_snb()
   CreateObject("scripting.filesystemobject").CopyFolder "G:\adres", "G:\adres_001"
End Sub
 
Beste VenA / SNB

Ik snap de beschreven code, als ik deze echter invoer krijg ik de volgende melding : "Het opgegeven bestand kan niet worden geopend", het lijkt erop dat wanneer ik een nieuwe unieke code invoer in kolom D, er geen nieuw dossier wordt aangemaakt waardoor de hyperlink in kolom L het niet doet. kan dit komen door de volgorde.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Dim Row As Integer
Dim Srcfolder
Dim Targetfolder
Const OverwriteExisting = False ' False >> Niet overschrijven dus

'Srcfolder = ("\\asp.woonpartners-mh.nl\dfs\Afdelingen\Shared\K&V\0 Verhuur\Verhuurmutaties\Overzicht\Niet gebruiken!\Mutatie dossier")
'Srcfolder = "R:\K&V\ enz."

If Target.Column = 4 And Target.Count = 1 Then
Application.EnableEvents = False

Srcfolder = ("\\asp.woonpartners-mh.nl\dfs\Afdelingen\Shared\K&V\0 Verhuur\Verhuurmutaties\Overzicht\Niet gebruiken!\Mutatie dossier")
CreateObject("shell.application").Namespace("\\asp.woonpartners-mh.nl\dfs\Afdelingen\Shared\K&V\0 Verhuur\Verhuurmutaties\Overzicht\Woningen"). _
newfolder Cells(Target.Row, 31).Value

On Error Resume Next

Targetfolder = ("\\asp.woonpartners-mh.nl\dfs\Afdelingen\Shared\K&V\0 Verhuur\Verhuurmutaties\Overzicht\Woningen" & Cells(Target.Row, 31).Value & "")
CreateObject("Scripting.FileSystemObject").GetFolder(Srcfolder).Copy Targetfolder, False
Application.EnableEvents = True
End If

End Sub[/SIZE]



MET UITDAGINGEN WORDEN MENSEN WIJZER (EN SOMS KNAPPER)
 
Mij lijkt het een hele uitdaging om de code tussen codetags te plaatsen. Volgens mij wordt er nergens een hyperlink aangemaakt/aangepast.
 
Kopieer/gebruik geen code die je niet volledig begrijpt.
 
Het leuke is om de door jullie geplaatste codes juist te begrijpen. En ik begrijp ook wat VenA terecht opmerkt. Ik zal deze vraag sluiten. VenA je hebt me wel degelijk op weg geholpen om eea verder uit te zoeken.

Dank hiervoor
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan