1 pièce(s) jointe(s)
Problème sur macro excel en boucle
Bonjour à tous,
Je me présente, François, je suis géologue, je me sers un peu des macro excel en temps habituel mais je n'ai pas une utilisation suffisante pour surmonter un problème qui semblera à certains d'entre vous une broutille...
Je reprend le poste d'une collègue qui à crée la macro afin d'automatiser une tâche assez rébarbative et répétitive, le niveau du code est trop complexe pour moi, aussi j'aimerais bien avoir des explications sur comment celui-ci fonctionne.
Mais le problème que je rencontre aujourd'hui est le suivant : une fonction des différentes macros plante systématiquement : je vous explique le process :
J'ai a la base un fichier excel comme suit :
Pièce jointe 469767
Il s'agit d'analyses de carottages.
Le but du jeu est de séparer chacun des items hole_id dans un onglet chacun et d'adapter l’épaisseur des échantillons à la largeur de la ligne.
Pour ce faire 3 macro ont été crées par ma prédécesseuse (?) je vous le colle ici dans l'ordre où elles doivent être éxécutées :
CODE 1 : Création feuille
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
| Option Explicit
Sub CreationFeuilles()
Dim J As Long
Dim Ws As Worksheet
Sheets("labo").Select
Application.ScreenUpdating = False
Set Ws = Sheets("labo")
For J = 1 To Range("D" & Rows.Count).End(xlUp).Row
If Not ExisteFeuille(Ws.Range("D" & J).Text) Then
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = Ws.Range("D" & J)
Sheets("Modèle").Cells.Copy Destination:=Range("A1")
ActiveSheet.Cells(4, 5) = Ws.Range("D" & J)
End If
Next J
Sheets("Hole_ID").Select
ActiveWindow.SelectedSheets.Delete
Ws.Select
End Sub
Function ExisteFeuille(Nom As String) As Boolean
On Error Resume Next
ExisteFeuille = Sheets(Nom).Name <> ""
On Error GoTo 0
End Function |
CODE 2 : Remplir feuille
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
| Sub remplir_feuilles()
Dim hole(1000)
Dim Ligne As Long
Dim ld As Long
Dim lf As Long
Ligne = Columns(4).Find("*", , , , xlByColumns, xlPrevious).Row 'dernière ligne remplie de la colonne A
hole(1) = Range("D2") ' code premier hole
' LISTAGE DIFFERENTS CODES
x = 1 ' variable pour compter nombre de hole
For n = 3 To Ligne ' boucle sur les lignes depuis la 3eme jusqu'à la dernière
' si code différent du précedent incrementationd e l variable et relevé du code
If Range("D" & n) <> hole(x) Then x = x + 1: hole(x) = Range("D" & n)
Next n
'TRAITEMENT DONNEES
' Boucle sur le nombre de codes
For h = 1 To x
' récupère première ligne du code et dernière ligen du code
ld = Columns(4).Find(hole(h), , , xlWhole, xlByColumns, xlNext).Row
lf = Columns(4).Find(hole(h), , , xlWhole, xlByColumns, xlPrevious).Row
nomf = hole(h) ' recupère nom du code
' Inscription des données dans la feuille
With Sheets(nomf)
ligneT = 8 ' ligne des titres
For y = ld To lf 'boucle sur les lignes du code en Feuil 1
.Range("B" & ligneT + y - ld) = Range("E" & y)
.Range("C" & ligneT + y - ld) = Range("H" & y)
.Range("D" & ligneT + y - ld) = Range("P" & y)
.Range("E" & ligneT + y - ld) = Range("R" & y)
.Range("F" & ligneT + y - ld) = Range("S" & y)
.Range("G" & ligneT + y - ld) = Range("T" & y)
.Range("H" & ligneT + y - ld) = Range("AC" & y)
.Range("I" & ligneT + y - ld) = Range("I" & y)
.Range("J" & ligneT + y - ld) = Range("J" & y)
.Range("K" & ligneT + y - ld) = Range("K" & y)
.Range("L" & ligneT + y - ld) = Range("M" & y)
Next y
End With
Next h
End Sub |
CODE 3 : boucle feuille
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
| Sub bouclefeuille()
'
' Macro1 Macro
'
Dim hgt As Variant
Dim WorkRng As Range
Dim Ws As Worksheet
For Each Ws In Worksheets
If Ws.Name Like "CG_PE_????" Then
Ws.Activate
' xTxt = ActiveWindow.RangeSelection.Address
Set WorkRng = Range("C8:C27")
For Each h In WorkRng
hgt = h.Value * 500
h.EntireRow.Select
Selection.RowHeight = hgt
Next h
'Application.Run "sondages2018Amontre3.xlsm!Boutontest"
End If
Next Ws
End Sub |
Ma problématique est sur cette dernière fonction : elle plante systématiquement sur la ligne "Selection.RowHeight = hgt" et je ne comprend pas pourquoi...
Merci de l'attention que vous avez prêté à mon message et de l'aide que vous voudrez bien me donner =)
Bonne journée à tous
