Nouveau - Remplissage sous conditions
Bonjour à tous,
J'aurais besoin d'un coup d e pouce pour finaliser une fonction VBA.
Je considère deux Worksheets, ws1 et ws2.
Sur ws1 se trouve un tableau à trois colonnes (B, C, D). La colonne B est composée de chiffre allant de 1 à 14. La colonne D est remplie par des éléments de texte. La colonne C n'est pas utilisée.
Sur ws2 se trouve un autre tableau de deux colonnes, A et B. La colonne A est rempli par une suite de chiffres, allant de 1 à 14, rangés par ordre croissant, et se répétant 150 fois : (1 1 ... 1 1 2 2 2 2.... 2 2 2... 3 3 3 3...)
J'aimerais que ma fonction :
==> dans un premier temps, remplisse la colonne B de la feuille ws2 avec l'élément de texte de la colonne D de ws1, qui est associé au même chiffre allant de 1 à 14
==> dans un second temps, cache les lignes de la colonne B de ws2 non remplies
Je joins le fichier test. Le troisième onglet est ce que j'aimerais obtenir.
Voici le code que j'ai pour le moment :
Sub Remplissage()
Dim ws2 As Worksheet
Dim ws1 As Worksheet
Dim last As Integer
Dim myrange As Range
Set ws1 = Sheets("Choix_équipements")
Set ws2 = Sheets("Synthèse 1")
last = ws1.[B65000].End(xlUp).Row
Set myrange = ws1.Range("B15:B65000")
max = Application.WorksheetFunction.max(myrange)
For i = 15 To last
For j = 1 To max
If Cells(i, 2) = j Then
ws2.Range("B65000").End(xlUp).Offset(1) = ws1.Cells(i, 4).Value'problème !
End If
Next j
Next i
End SubJ'ai un problème dans la boucle For. Je ne sais pas comment traduire le fait que le remplissage doit se faire sur la dernière ligne non remplie ayant un chiffre fixé dans la colonne A sur ws2.
Pouvez-vous m'aider ?
Merci à tous !
Mim125
bonjour,
une proposition
Sub Remplissage()
Dim ws2 As Worksheet
Dim ws1 As Worksheet
Dim last As Integer
Dim myrange As Range
Set ws1 = Sheets("Choix_équipements")
Set ws2 = Sheets("Synthèse 1")
last = ws1.[B65000].End(xlUp).Row
Set myrange = ws1.Range("B15:B65000")
max = Application.WorksheetFunction.max(myrange)
dlws2 = 4
ws2.Range("A5:C5000").Clear
For j = 1 To max
For i = 15 To last
If ws1.Cells(i, 2) = j And ws1.Cells(i, 4) <> "" Then
dlws2 = dlws2 + 1
ws2.Cells(dlws2, 2) = ws1.Cells(i, 4).Value
ws2.Cells(dlws2, 1) = j
End If
Next i
Next j
End SubMerci pour cette proposition !
Ça effectue seulement en partie ce dont j'ai besoin. La fonction que tu proposes remplace les chiffres dans la colonne A de ws2. J'aimerais que les éléments de textes se placent dans la colonne B de ws2 en fonction de ce qu'il y a dans la colonne A.
Je propose ce nouveau code, qui n'est pas concluant cependant :
Sub Remplissage()
Dim ws2 As Worksheet
Dim ws1 As Worksheet
Dim last1 As Integer, last2 As Integer
Dim myrange As Range
Set ws1 = Sheets("Choix_équipements")
Set ws2 = Sheets("Synthèse 1")
last1 = ws1.[B65000].End(xlUp).Row
last2 = ws2.[B65000].End(xlUp).Row
Set myrange = ws1.Range("B15:B65000")
max = Application.WorksheetFunction.max(myrange)
For j = 1 To max
For i = 15 To last1
If ws1.Cells(i, 2) = j And ws1.Cells(i, 4) <> "" Then
k = 6
If ws2.Cells(k, 1).Value = j And ws2.Cells(k, 2) = "" Then
ws2.Cells(k, 2).Value = ws1.Cells(i, 4).Value
k = k + 1
End If
End If
Next i
Next j
End SubBonjour,
une autre proposition
Sub Remplissage()
Dim ws2 As Worksheet
Dim ws1 As Worksheet
Dim last As Integer
Dim myrange As Range
Set ws1 = Sheets("Choix_équipements")
Set ws2 = Sheets("Synthèse 1")
last = ws1.[B65000].End(xlUp).Row
Set myrange = ws1.Range("B15:B65000")
max = Application.WorksheetFunction.max(myrange)
ws2.Range("B5:C5000").ClearContents
For j = 1 To max
dlws2 = ws2.Columns(1).Find(j).Row
For i = 15 To last
If ws1.Cells(i, 2) = j And ws1.Cells(i, 4) <> "" Then
ws2.Cells(dlws2, 2) = ws1.Cells(i, 4).Value
ws2.Cells(dlws2, 1) = j
dlws2 = dlws2 + 1
End If
Next i
Next j
ws2.Rows("4:4").AutoFilter
ws2.Range("$A$4:$C$2085").AutoFilter Field:=2, Criteria1:="<>", _
Operator:=xlAnd
End Sub