Macro boucle update data jusque fin tableau

Version imprimable

Bonjour,

J'ai bricolé une macro pour mettre à jour des fichier du personnel. Pour ce faire il copie le matricule dans un tableau pour le coller dans un autre tableau avec formule de vlookup qui va donner les connexions, pauses, et autres de l'employer. Ces informations sont ensuite copiées / collées valeur sur le fichier du personnel correspondant au nom à coté du matricule dans le tableau où il va le chercher.

La macro est assez imparfaite car pour l'instant je dois lui dire à chaque fois où aller copier le matricule suivant (en rouge) au lieu de lui dire de prendre le sivant dans la cellule du dessous et terminer en tapant update sur la même ligne dans une cellule du tableau (en orange). La macro est donc très volumineuse, j'ai du employer un macro d'ensemble qui lance des macros succèssiblement car l'opération doit se répéter pour bien faire +- 300 fois (300 matricules). J'aimerais faire une boucle jusqu'à ce qu'il arrive à une cellule vide (la fin du tableau).

Voici le code :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 Sub UPDATE_Accent_1() Sheets("Payroll UPDATE").Select Range("A4").Select Selection.Copy Sheets("bco UPDATE").Select Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("C9:T372").Select Selection.Copy Range("B1").Select Workbooks.Open Filename:= _ Range("A6") _ , UpdateLinks:=0 ActiveWindow.Visible = False Windows(Range("B3") & "_" & Range("A2") & "_" & Range("A3") & "_Interview.xlsx").Visible = True Sheets("LISTING Aanwezigheid 2018").Select Range("J62").Select ActiveWindow.ScrollRow = 1 Range("C9").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("D11").Select Application.CutCopyMode = False ActiveWorkbook.Save ActiveWindow.Close Sheets("Payroll UPDATE").Select Range("D4").Select ActiveCell.FormulaR1C1 = "UPDATED" Range("A5").Select Selection.Copy Sheets("bco UPDATE").Select Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("C9:T372").Select Selection.Copy Range("B1").Select Workbooks.Open Filename:= _ Range("A6") _ , UpdateLinks:=0 ActiveWindow.Visible = False Windows(Range("B3") & "_" & Range("A2") & "_" & Range("A3") & "_Interview.xlsx").Visible = True Sheets("LISTING Aanwezigheid 2018").Select Range("J62").Select ActiveWindow.ScrollRow = 1 Range("C9").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("D11").Select Application.CutCopyMode = False ActiveWorkbook.Save ActiveWindow.Close Sheets("Payroll UPDATE").Select Range("D5").Select ActiveCell.FormulaR1C1 = "UPDATED"
etc...

D'avance merci beaucoup.

Votre code a besoin d'être amélioré; pour vous permettre de le lancer avec un seul code générique, je l'ai adapté ainsi (à tester):

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Sub UPDATE_Accent_1()
 
Dim j As Integer: j = 0 'new
Application.ScreenUpdating = False
On Error GoTo 150
 
 Do While True
    Sheets("Payroll UPDATE").Select
    Range("A4").Select 'variable
    ActiveCell.Offset(j, 0).Activate 'new
    If ActiveCell.Offset(j, 0) = "" Then Exit Do
    Selection.Copy
    Sheets("bco UPDATE").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
 
    Range("C9:T372").Select
    Selection.Copy
    Range("B1").Select
    Workbooks.Open Filename:=Range("A6"), UpdateLinks:=0
    ActiveWindow.Visible = False
    Windows(Range("B3") & "_" & Range("A2") & "_" & Range("A3") & "_Interview.xlsx").Visible = True
    Sheets("LISTING Aanwezigheid 2018").Select
    Range("J62").Select
    ActiveWindow.ScrollRow = 1
    Range("C9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
 
    Range("D11").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Save
    ActiveWindow.Close
    Sheets("Payroll UPDATE").Select
    Range("D4").Select 'variable
    ActiveCell.Offset(j, 0).Activate 'new
    ActiveCell.FormulaR1C1 = "UPDATED"
    j = j + 1
 Loop
    MsgBox "Traitement terminé !", vbOKOnly, "Update Accent"
150     Application.ScreenUpdating = True
End Sub

23/04/2018, 13h47
dmbenjamin

Un grand merci!

Cela fonctionne patiellement à la perfection.

Il s'arret à A27 sans aucune explication et affiche malgré tout le message "Traitement terminé".
J'ai vérifié le fichier de l'employé en question et aucun soucis qui expliqerait l'arrêt de la macro, même si de toute manière avec la première version sans code générique il parvenait à mettre à jour.
23/04/2018, 15h05
dmbenjamin

J'ai changé le matricule de A28 pour voir si le problème vient de la fiche du personnel mais la macro s'arrête toujours au même endroit.

Bonjour, je me suis permis de rajouter un Message qui peut donner une information sur l'erreur. testez le?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Sub UPDATE_Accent_1() 
Dim j As Integer: j = 0 'new
Application.ScreenUpdating = False
On Error GoTo 150
 
 Do While True
    Sheets("Payroll UPDATE").Select
    Range("A4").Select 'variable
    ActiveCell.Offset(j, 0).Activate 'new
    If ActiveCell.Offset(j, 0) = "" Then 
       MsgBox "A " & j & " est egal nothing"  'Si le message Box s'affiche ca signifie que la cellule est égale à rien, raison de la sortie de la boucle.
       Exit Do
    End If
    Selection.Copy
    Sheets("bco UPDATE").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
 
    Range("C9:T372").Select
    Selection.Copy
    Range("B1").Select
    Workbooks.Open Filename:=Range("A6"), UpdateLinks:=0
    ActiveWindow.Visible = False
    Windows(Range("B3") & "_" & Range("A2") & "_" & Range("A3") & "_Interview.xlsx").Visible = True
    Sheets("LISTING Aanwezigheid 2018").Select
    Range("J62").Select
    ActiveWindow.ScrollRow = 1
    Range("C9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
 
    Range("D11").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Save
    ActiveWindow.Close
    Sheets("Payroll UPDATE").Select
    Range("D4").Select 'variable
    ActiveCell.Offset(j, 0).Activate 'new
    ActiveCell.FormulaR1C1 = "UPDATED"
    j = j + 1
 Loop
    MsgBox "Traitement terminé !", vbOKOnly, "Update Accent"
150     Application.ScreenUpdating = True
End Sub

Cordialement 8-)

24/04/2018, 17h08
dmbenjamin

Un résultat des plus métaphysique! Il annonce "A24 égla nothing" alors qu'il atteint toujours A27 et le valide par "UPDATED"
24/04/2018, 19h00
Transitoire

Bonsoir,
N'y aurait-il pas par hasard, une ou des lignes cachés ou du moins dont la hauteur serait = 0 ou 0,001
et donc une cellule qui serait égale a rien?
Bizarre, bizarre, vous avez dit bizarre! :D
Cordialement 8-)
24/04/2018, 19h47
Transitoire

Re bonsoir,

Citation:

Envoyé par dmbenjamin

Un résultat des plus métaphysique! Il annonce "A24 égal nothing" alors qu'il atteint toujours A27 et le valide par "UPDATED"

Rien d'étonnant en fait ! En effet, A24, le 24 n'est pas le numéro de ligne, mais la valeur de j soit le numéro de boucle. Comme la boucle part de la ligne 4 , 24+ 4 =28 .
Il y a un problème sur la cellule A27 ou A28 elle doit donner une réponse "nothing" ?

Cordialement 8-)