merci pour ce travail mais ce n'est pas ce que je voulais .
comme il est montré sur les images chaque lignes vide doit etre rempli lors du lancement de la macro sub_way3 et non supprimé
essayer d'adapté votre solution a mon code afin d'avoir le meilleur rendu possible
merci
le code :
Copie les 3 premieres colonnes de la feuille "Cartographie" pour ensuite les copiés dans la feuille "Analyse de risque" et création de la 4eme colonnes "Menace" :
A LANCER DANS LA FEUILLE "Cartographie"
Sub way2()
Dim cell_ori As Range
Dim cell_des As Range
Set cell_des = Worksheets("Analyse de risques").Range("A1")
With Worksheets("Cartographie")
Set cell_ori = .Range("A1")
For j = 0 To 3
For i = 0 To .Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row - 1
If j <> 3 Then
cell_des.Offset(i, j) = cell_ori.Offset(i, j)
Else
If i = 0 Then
cell_des.Offset(i, j) = "Menaces"
End If
End If
Next i
Next j
End With
End Sub
Recherche les infos de la feuille "Menaces" grace au 3 premieres lettres du type de ressource et copie de ces informations dans la feuille analyse de risque (Creation de lignes en cas de menaces multiples) :
A LANCER DANS LA FEUILLE "Analyse de risques"
Sub way3()
Dim Sh As Worksheet, x As Long 'Declaration des variables "Sh" de type Feuille et "x" de type long
Set Sh = Sheets("Analyse de risques") 'Donne la valeur a la variable "Sh"
With Sheets("Analyse de risques") 'Avec la feuille "Cartographie"
Ligne = .Cells(.Rows.Count, 2).End(xlUp).Row 'Attribut la valeur de la cellule puis incremente dans la colonne jusqu'a fin cellule
.[D2:D2000].ClearContents 'Efface les lignes 2 à 2000 de la colonne D
For i = .Cells(.Rows.Count, 2).End(xlUp).Row To 2 Step -1 'au bout de 2 pas faire un pas en arriere
If .Cells(i, 2) = "" Then .Cells(i, 2).EntireRow.Delete 'si la cellule est vide alors la supprimée
Next i 'Valeur suivante
End With 'Fin de la feuille "Cartographie"
With Sheets("Menaces") 'Avec la feuille "Cartographie"
For x = Ligne To 2 Step -1 'faire varier x depuis la valeur de Ligne jusqu'à la valeur 2 en retirant 1 à chaque fois
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row 'Pour i etant egale a 2 jusqu'a fin cellule incrementer de 1
var2 = .Cells(i, 1)
If .Cells(i, 1) = Left(Sh.Cells(x, 2), 3) And Sh.Cells(x, 2).Offset(, 2) = "" Then
Sh.Cells(x, 2).Offset(, 2) = .Cells(i, 2)
ElseIf .Cells(i, 1) = Left(Sh.Cells(x, 2), 3) And Sh.Cells(x, 2).Offset(, 2) <> "" Then
Rows(x + 1).Insert
Sh.Cells(x + 1, 2).Offset(, 2) = .Cells(i, 2)
End If
Next i
Next x
End With
End Sub