Re : address et row impossible
Ci-dessous mon code qui marche.... Mais si vous pouvez le simplifier, c'est avec plaisir
Sub RechMulti()
' je nettoie les cellules feuil2
Sheets("Feuil2").Select
[A3:Q100].Select
Selection.ClearContents
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
' je vérifie les version en cherchant "version"
Sheets("PLANNING").Select
Set Plage = Application.InputBox(prompt:="Test", Type:=8)
With Plage
Set c = .Find("Version", LookIn:=xlValues)
If Not c Is Nothing Then
adresse1 = c.Address
Do
VersionC = Range(c.Address).Column
'On saute une ligne
L = L + 1
'adresse trouvée / numero moule / date version a faire
Sheets("Feuil2").Cells(L + 2, 1).Value = Sheets("PLANNING").Range(c.Address).Value
Sheets("Feuil2").Cells(L + 2, 2).Value = Worksheets("PLANNING").Range(c.Address).Offset(1, 0).Value
Sheets("Feuil2").Cells(L + 2, 3).Value = Worksheets("PLANNING").Cells(2, VersionC).Value
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> adresse1
End If
End With
' j'inscrit les changement de moules en chercheant "M+xxx"
With Plage 'defini le range de travail, qui va devenir variable
Set d = .Find("M", LookIn:=xlValues)
If Not d Is Nothing Then
Adresse2 = d.Address
Do
VersionR = Range(d.Address).Column
'recopie en sautant une ligne /L'ne cherche que les M+4 ou 5 chiffres
Ma1ereLettre = Left(d.Text, 1)
If Ma1ereLettre = "M" Then
If d.Text Like "[M]####" Or d.Text Like "[M]#####" Then
L1 = Sheets("Feuil2").Range("F65536").End(xlUp).Row
Sheets("Feuil2").Cells(L1 + 1, 6).Value = Sheets("PLANNING").Range(d.Address).Value
Sheets("Feuil2").Cells(L1 + 1, 7).Value = Worksheets("PLANNING").Cells(2, VersionR).Value
End If
End If
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> Adresse2
End If
End With
'ouvrir rep outillage pour voir état du moule et associé infos
'Workbooks.Open Filename:="X:\Production\SuiviRéparationOutillages.xls"
'aller chercher le numero de moule pour le trouver
Sheets("Feuil2").Select
For t = 3 To L1
Windows("Planning fabrication EN187 rev 2").Activate
x = Cells(t, 6).Value
Workbooks("SuiviRéparationOutillages.xls").Activate
L12 = Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row
Set Plage1 = Sheets("Feuil1").Range(Cells(1, 1), Cells(L12, 1))
With Plage1
Set c = .Find(x, LookIn:=xlValues, LookAt:=False) 'cherche le x = numero moule voir si en rep
If Not c Is Nothing Then
Adresse3 = c.Address
Do
versionU = Range(c.Address).Row
If c.Text <> "" Then
'on repasse sur le planning et on colorie en rouge si une ligne est ouverte
Windows("Planning fabrication EN187 rev 2").Activate
Cells(t, 6).Select
Selection.Interior.Color = 255
Cells(t, 8).Value = c.Address
VersionS = Range(c.Address).Row
'il reste a recopie la date mtn que nous avons toruvé un lien
Workbooks("SuiviRéparationOutillages.xls").Activate
For f = 2 To L12
u = versionU
x1 = Cells(u, f).Select
If Selection.Interior.Color = 255 Then
'trouver cellule rouge il faut donc copier coller
versionfin = ActiveCell.Column
toi = Workbooks("SuiviRéparationOutillages.xls").Sheets("Feuil1").Cells(2, versionfin).Text
Windows("Planning fabrication EN187 rev 2").Activate
Sheets("Feuil2").Cells(t, 9).Value = toi
End If
Next f
Windows("Planning fabrication EN187 rev 2").Activate
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adresse3
End If
End With
Next t
'derniere boucle pour aller chercher via adresse versionS dans tableau out et decaler jusqua rouge
End Sub
