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 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103
|
Option Explicit
Sub Essai_Electrique_modelage()
Dim nom As String ' Variable du nom de l'essai
Dim Dep As String ' Variable dépendance
Dim Cellule As Range ' Variable pour sélectionner la cellule
Dim Essais As Variant ' Déclaration tableau
Dim Rng As Range ' Variable servant à trouver la récurrence
Dim MotFreq As String ' Variable sortant le mot
Dim Mx As Integer
Dim c As Range
Dim Str As String
Dim nompresent As Range 'range qui vérifie si le mot est présent dans le tableau ou non
Dim firstAddress As String
Dim derligne As Integer
Dim i As Integer
Dim dl As Integer
Dim exec As String
Dim reper As Range
'Ecriture du tableau recompiler
Essais = Array("Nom de l'essais", "Emplacement", "Durée Te(min)", "Dépendance", "Support", "Sous-tension")
Cells(1, 12) = Essais(0)
Cells(1, 13) = Essais(1)
Cells(1, 14) = Essais(2)
Cells(1, 15) = Essais(3)
Cells(1, 16) = Essais(4)
'Test Essai commetant le plus de dépendance
Set Rng = Range("G5:G11") 'Plage où l'on veut trouver le mot
derligne = Range("G" & Rows.Count).End(xlUp).Row
For i = 5 To derligne
Set reper = Columns(7).Find(what:=nom, LookIn:=xlValues, LookAt:=xlWhole)
If Not reper Is Nothing Then
For Each c In Rng
If reper <> c Then
Mx = Application.CountIf(Rng, c.Value)
Str = c.Value
End If
Next c
MotFreq = Str
nom = MotFreq
'Test si l'essai trouvé possède une dépendance
Dep = Application.WorksheetFunction.Index(Sheets("Feuil1").Range("G5:G11"), Application.WorksheetFunction.Match(nom, Sheets("Feuil1").Range("D5:D11"), 0), 0) 'Trouve la dépendance correspondante à l'essai
If Dep = "0" Then
'Recherche dans la première colonne du tableau, la variable
Set Cellule = Columns(4).Find(what:=nom, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cellule Is Nothing Then Range(Cellule, Cellule(1, 5)).Select
Selection.Copy Destination:=Range("L1:P1").Offset(1, 0)
Else
Set Cellule = Columns(4).Find(what:=Dep, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cellule Is Nothing Then Range(Cellule, Cellule(1, 5)).Select
Selection.Copy Destination:=Range("L1:P1").Offset(1, 0)
'Ecris la deuxième ligne dans le tableau
Set Cellule = Columns(4).Find(what:=nom, LookIn:=xlValues, LookAt:=xlWhole)
If Not Cellule Is Nothing Then Range(Cellule, Cellule(1, 5)).Select
Selection.Copy Destination:=Range("L1:P1").Offset(2, 0)
End If
With ActiveSheet
Set nompresent = Columns(7).Find(what:=nom, LookIn:=xlValues, LookAt:=xlWhole)
If Not nompresent Is Nothing Then
firstAddress = nompresent.Address
Do
Range(Range(nompresent, nompresent(1, 0)).End(xlToLeft), Range(nompresent, nompresent(1, 0)).End(xlToRight)).Select
Selection.Copy Destination:=Range("L1:P1").End(xlDown).Offset(1, 0)
Set nompresent = Columns(7).FindNext(nompresent)
exec = Application.WorksheetFunction.Index(Sheets("Feuil1").Range("L2:L24"), Application.WorksheetFunction.Match(nom, Sheets("Feuil1").Range("L2:L24"), 0), 0)
Loop While Not nompresent Is Nothing And nompresent.Address <> firstAddress
End If
End With
End If
Next
End Sub |
Partager