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
59
60
61
62
63
64
65
66
67
68
69
70
71
| Sub insert_tab()
'Déclaration des variables
Dim Rg As Range
Dim Rg_suiv As Range
Dim Rg_final As Range
Dim nom As String
'Avec la feuille "REPARTITION PART 1"
With Workbooks("organigramme test.xlsm").Worksheets("REPARTITION PART 1")
'On boucle de i = 1 à i = 3
For i = 1 To 6
'On set Rg à l'endroit ou se trouve la valeur "T" & i dans la colonne 1 à savoir T1, T2 et T3 à chaque itération
Set Rg = .Columns(1).Find("T" & i, LookIn:=xlValues, LookAt:=xlWhole)
'On set Rg_suiv à l'endroit ou se trouve la valeur "T" & i+1 dans la colonne 1 à savoir T2, T3 et T4 à chaque itération
Set Rg_suiv = .Columns(1).Find("T" & i + 1, LookIn:=xlValues, LookAt:=xlWhole)
'Si on trouve un Rg_suiv (c'est pour le cas où on a i = 4, on ne trouvera pas de "T4")
If Not Rg_suiv Is Nothing Then
'Petite condition sur les lignes pour être sur d'avoir quelque chose dans le tableau
If Rg.Row + 2 < Rg_suiv.Row Then
'Alors on supprime toutes les lignes
.Rows(Rg.Row + 1 & ":" & Rg_suiv.Row - 2).Delete Shift:=xlUp
End If
'... si on ne trouve pas de T4
Else
'Petite condition sur les lignes pour être sur d'avoir quelque chose dans le tableau
If Rg.Row < .Columns(1).Find("*", , , , , xlPrevious).Row Then
'Alors on supprime ce qu'on a en dessous de T3
.Rows(Rg.Row + 1 & ":" & .Columns(1).Find("*", , , , , xlPrevious).Row).Delete Shift:=xlUp
End If
End If
'On set "nom" à la valeur située de colonne à droite de TX (X = 1 à 6)
nom = Rg.Offset(0, 2)
'Si on trouve une correspondace dans l'onglet "ORGANIGRAMME"...
If Not Worksheets("ORGANIGRAMME").Range("A13:D26").Find(nom, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
'... alors on remplace "nom" par l'organigramme correspondant
nom = Worksheets("ORGANIGRAMME").Range("A13:D26").Find(nom, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 1)
Else
'... sinon, on affiche une MsgBox
MsgBox "Le nom " & nom & " ne possède pas d'organigramme."
End If
'Dans le classeur "PORTEFEUILLE PRGE", sur la feuille "PORTEF PRGE"
With Workbooks("PORTEFEUILLE PRGE_Liste des PM_032014.xlsm").Worksheets("PORTEF PRGE")
'On se place sur la cellule C4
Set Rg_final = .Range("C4")
'De j = 1 à la dernière ligne...
For j = 1 To .Columns(3).Find("*", , , , , xlPrevious).Row - 3
'... si nom est égale à une valeur de la colonne C
If Rg_final.Offset(j, 0) = nom Then
'... alors dans l'onglet "REPARTITION PART 1" du classeur "Explication 2"
With Workbooks("organigramme test.xlsm").Worksheets("REPARTITION PART 1")
'... on insère une ligne 'ici j'ai un souci ca m'insère une ligne (beige) dans tous le document alors que je voudrais une ligne blanche totalement encadrée (bordure) dans le tableau uniquement...j'essaye de trouver le code pour spécifier cela'
.Rows(Rg.Row + 1).Insert Shift:=xlDown
'... et on met ce qu'on veut dans la ligne insérée
Rg.Offset(1, 0) = Rg_final.Offset(j, -2) 'Colonne A tableau organigramme'
Rg.Offset(1, 1) = Rg_final.Offset(j, 4) 'Colonne B tableau organigramme'
Rg.Offset(1, 2) = Rg_final.Offset(j, 3) 'Colonne C tableau organigramme'
End With
End If
Next j
End With
Next i
End With
End Sub |
Atteindre la cellule en dessous de la cellule "fonction find"
Répondre avec citation
Envoyé par mederick
Partager