I am writing a code to automatically write information in a specific cell if there is matching information between a main list and a masterlist.
This is the main list which will be printed.
And this is the masterlist which is a bank of components.
in my test, the information i am trying to compare would be "test" cells C3 and C180 and "test2" cells C15 and C191 and the information to be written is a183:C189 to A6:C12 and A194:C200 to A18:C24 if there is a match.
Here is part of the code i have written :
Sub FR_3_08_Filerie_remplissage_automatique()
'sélection worksheet
Set filerie = ActiveWorkbook.Worksheets("FR-3-08_Filerie")
'tableau liste filerie colonne 1
Dim tableau_fi1 As range
Dim nbrligne_fi1 As Integer
Set tableau_fi1 = filerie.range("c3:c75")
nbrligne_fi1 = tableau_fi1.Rows.Count
'tableau liste filerie colonne 2
Dim tableau_fi2 As range
Dim nbrligne_fi2 As Integer
Set tableau_fi2 = filerie.range("n3:n75")
nbrligne_fi2 = tableau_fi2.Rows.Count
'tableau catalogue carte
Dim tableau_cc As range
Dim nbrligne_cc As Integer
Set tableau_cc = filerie.range("c180:c191")
nbrligne_cc = tableau_cc.Columns.Count
'recherche du duplicata
Dim masterlist As range
'code start
For k = 1 To nbrligne_fi1
If IsEmpty(tableau_fi1(k, 1)) = False Then 'si cellule vide skip
Set carte_actif = tableau_fi1(k, 1) 'mise en mémoire du composant de la cellule actif du tableau de filerie
For Each masterlist In tableau_cc 'recherche de duplicata dans le catalogue de carte
If carte_actif.Value = masterlist.Value Then 'si il y a duplicata, écriture de information
'mise en mémoire des cellules utilisé dans les 2 tableaux
Set couleur1 = carte_actif.Offset(3, 0)
Set couleur2 = carte_actif.Offset(5, 0)
Set couleur3 = carte_actif.Offset(7, 0)
Set couleur4 = carte_actif.Offset(9, 0)
Set mcouleur1 = tableau_cc.Offset(3, 0)
Set mcouleur2 = tableau_cc.Offset(5, 0)
Set mcouleur3 = tableau_cc.Offset(7, 0)
Set mcouleur4 = tableau_cc.Offset(9, 0)
Set deg1 = carte_actif.Offset(3, -1)
Set deg2 = carte_actif.Offset(5, -1)
Set deg3 = carte_actif.Offset(7, -1)
Set deg4 = carte_actif.Offset(9, -1)
Set mdeg1 = tableau_cc.Offset(3, -1)
Set mdeg2 = tableau_cc.Offset(5, -1)
Set mdeg3 = tableau_cc.Offset(7, -1)
Set mdeg4 = tableau_cc.Offset(9, -1)
Set qty1 = carte_actif.Offset(3, -2)
Set qty2 = carte_actif.Offset(5, -2)
Set qty3 = carte_actif.Offset(7, -2)
Set qty4 = carte_actif.Offset(9, -2)
Set mqty1 = tableau_cc.Offset(3, -2)
Set mqty2 = tableau_cc.Offset(5, -2)
Set mqty3 = tableau_cc.Offset(7, -2)
Set mqty4 = tableau_cc.Offset(9, -2)
'écriture de l'information dans le tableau couple de serrage
couleur1.Value = mcouleur1.Value
couleur2.Value = mcouleur2.Value
couleur3.Value = mcouleur3.Value
couleur4.Value = mcouleur4.Value
deg1.Value = mdeg1.Value
deg2.Value = mdeg2.Value
deg3.Value = mdeg3.Value
deg4.Value = mdeg4.Value
qty1.Value = mqty1.Value
qty2.Value = mqty2.Value
qty3.Value = mqty3.Value
qty4.Value = mqty4.Value
End If
Next masterlist
End If
k = k 11
Next k
End Sub
The variable i am trying to move is ''masterlist'' in For Each masterlist In tableau_cc down 11 cells each loop which would move from test to test2 in the image bank of components. Else the code tries to verify each cell between the 2 which take more time for the code to finish.
I tried code like masterlist = masterlist.offset(11, 0) but it copies the information in C191 to c180.
I also played with .end(xdown) by moving C180 and C191 to ''E'' but i have the same problem and a new 1 by having for example Set deg1 = carte_actif.Offset(3, -1) broken. the -1 and any other number work but when i enter -3 i get an error which is what i need...
what would be the solution to move ''masterlist'' in the code 12 cells down each loop?
EDIT:
the range written is for test purpose as the range will grow as i add more component in my list. currently it is "C180:C279" but could go to C400 in the future. it is the reason i am trying to move the variable "masterlist" 11 row down each loop.
currently i am using Set tableau_cc = filerie.range("c180, c191, c202, c213, c224, c235, c246, c257, c268, c279") as a solution to force verification on specific cell insteal of the whole range. i will have to add manualy each cell as i expand the masterlist with more component. also added a exit for after the information has been transfered to make the loop faster
CodePudding user response：
The information i am trying to compare would be test cells C3 and C180 and test2 cells C15 and C191 and the information to be written is a183:C189 to A6:C12 and A194:C200 to A18:C24 if there is a match.
Sub copy()
Dim cll3, cll15, cll180, cll191
With Sheets("FR-3-08_Filerie")
Set cll3 = .Range("C3")
Set cll15 = .Range("C15")
Set cll180 = .Range("C180")
Set cll191 = .Range("C191")
If cll3 = cll180 Then
cll3.Offset(3, 0) = cll180.Offset(3, 0)
cll3.Offset(5, 0) = cll180.Offset(5, 0)
cll3.Offset(7, 0) = cll180.Offset(7, 0)
cll3.Offset(9, 0) = cll180.Offset(9, 0)
cll3.Offset(3, -1) = cll180.Offset(3, -1)
cll3.Offset(5, -1) = cll180.Offset(5, -1)
cll3.Offset(7, -1) = cll180.Offset(7, -1)
cll3.Offset(9, -1) = cll180.Offset(9, -1)
cll3.Offset(3, -2) = cll180.Offset(3, -2)
cll3.Offset(5, -2) = cll180.Offset(5, -2)
cll3.Offset(7, -2) = cll180.Offset(7, -2)
cll3.Offset(9, -2) = cll180.Offset(9, -2)
End If
If cll15 = cll191 Then
cll15.Offset(3, 0) = cll191.Offset(3, 0)
cll15.Offset(5, 0) = cll191.Offset(5, 0)
cll15.Offset(7, 0) = cll191.Offset(7, 0)
cll15.Offset(9, 0) = cll191.Offset(9, 0)
cll15.Offset(3, -1) = cll191.Offset(3, -1)
cll15.Offset(5, -1) = cll191.Offset(5, -1)
cll15.Offset(7, -1) = cll191.Offset(7, -1)
cll15.Offset(9, -1) = cll191.Offset(9, -1)
cll15.Offset(3, -2) = cll191.Offset(3, -2)
cll15.Offset(5, -2) = cll191.Offset(5, -2)
cll15.Offset(7, -2) = cll191.Offset(7, -2)
cll15.Offset(9, -2) = cll191.Offset(9, -2)
End If
End With
End Sub
CodePudding user response：
Untested but should be close:
Sub FR_3_08_Filerie_remplissage_automatique()
Dim wb As Workbook, filerie As Worksheet, cModel As Range, i As Long
Dim model, cMatch As Range, matched As Boolean, rw As Long, col As Long
Set wb = ActiveWorkbook
Set filerie = ActiveWorkbook.Worksheets("FR-3-08_Filerie")
Set cModel = filerie.Range("C3") 'first model value to search for
Do
i = i 1
If Len(cModel.Value) > 0 Then 'anything to look for?
Set cMatch = filerie.Range("C180") 'first cell to match on
Do While cMatch.Row < 400 'adjust max row as needed
If cMatch.Value = cModel.Value Then
For col = -2 To 0
For rw = 2 To 8 Step 2
cModel.Offset(rw, col).Value = cMatch.Offset(rw, col).Value
Next rw
Next col
End If
Set cMatch = cMatch.Offset(11)
Loop
End If
If i Mod 2 = 1 Then
Set cModel = cModel.Offset(0, 11) 'move over to the right
Else
Set cModel = cModel.Offset(12, -11) 'move down and back to the left
End If
Loop While cModel.Row < 80
End Sub