Incrémenter ligne vba copie
Bonjour,
Alors mon probleme c'est que j'ai un doc execel avec 3 feuilles 2 de references et une pour faire la correspondance entre les deux et copier dans la 3eme quand il y a une correspondance. Voici mon code :
Mon soucis est que dans ma feuille Synthesevba il copie sur la deuxieme ligne mais ecrase par la suite il ne passe pas à la ligne suivante pour faire la copie. Auriez vous une solution ou une piste cela m'aiderait tres fortement ! Merci beaucoup :)
Alors mon probleme c'est que j'ai un doc execel avec 3 feuilles 2 de references et une pour faire la correspondance entre les deux et copier dans la 3eme quand il y a une correspondance. Voici mon code :
Sub Correspondance()
Dim i As Integer
i = 2
While i <= 40
Dim j As Integer
j = 2
While j <= 14924
Dim k As Integer
k = 2
If Worksheets("Applis").Range("A" + CStr(i)).Value = Worksheets("Produits").Range("A" + CStr(j)).Value Then
Worksheets("Applis").Range("A" + CStr(i)).Copy Destination:=Worksheets("Synthesevba").Range("A" + CStr(k))
Worksheets("Applis").Range("E" + CStr(i)).Copy Destination:=Worksheets("Synthesevba").Range("B" + CStr(k))
Worksheets("Produits").Range("E" + CStr(j)).Copy Destination:=Worksheets("Synthesevba").Range("C" + CStr(k))
k = k + 1
End If
j = j + 1
Wend
i = i + 1
Wend
End Sub
Mon soucis est que dans ma feuille Synthesevba il copie sur la deuxieme ligne mais ecrase par la suite il ne passe pas à la ligne suivante pour faire la copie. Auriez vous une solution ou une piste cela m'aiderait tres fortement ! Merci beaucoup :)
2 réponses
-
ContributeurEn attendant,code "à l'aveugle" et donc "à risque" puisque classeur non fourni
Option Explicit
'--------------------------------------------
Sub sélectionner()
Dim Derlig As Byte
Dim Lig_a As Byte, T_appli
Dim Lig_p As Integer, T_colA, T_colE, D_prod As Object, Ref ' préciser le type de variable Ref
Dim T_out, Lig_out As Byte
Dim Start As Single
'-------------------------------initialisation
Start=timer'
Application.ScreenUpdating = False 'fige l'écran: confort et rapidité
'mémorisation des applis
With Sheets("applis")
Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
T_appli = .Range("A2:E" & Derlig)
End With
'mémorisation des produits
With Sheets("produits")
Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
T_colA = Application.Transpose(.Range("A2:A" & Derlig))
T_colE = Application.Transpose(.Range("E2:E" & Derlig))
'cr'ation d'un dictionnaire clé=colonne A item colonne E
Set D_prod = CreateObject("scripting.dictionary")
For Lig_p = 1 To UBound(T_colA)
Ref = T_colA(Lig_p)
If Not D_prod.exists(Ref) Then: D_prod.Add Ref, T_colE(Lig_p)
Next
End With
'préparation résultats
With Sheets("Synthesevba")
ReDim T_out(1 To UBound(T_appli), 1 To 3)
'---------------------------- traitement des données
For Lig_a = 1 To UBound(T_appli)
Ref = T_appli(Lig_a, 1)
If D_prod.exists(Ref) Then
Lig_out = Lig_out + 1
Ref = T_appli(Lig_a)
Lig_out = Lig_out + 1
T_out(Lig_out, 1) = D_prod(Ref)
T_out(Lig_out, 3) = D_prod.Item(Ref)
T_out(Lig_out, 2) = T_appli(Lig_a, 5)
End If
Next
'-------------------------restitution
.Range("A2:C257").Clear
.Range("A2").Resize(UBound(T_appli), 3) = T_out
.Activate
End With
Application.ScreenUpdating = True
MsgBox "correspondance établie en: " & Timer - Start & " sec."
End Sub
je repasse en fin d'aprem
Michel -
Contributeurbonjour
pour faciliter une proposition
(avec 14000 lignes, il vaut utiliser une autre méthode que "copy destination" sinon la durée risque d'^tre longue!) pour cela:Mettre le classeur sans données confidentielles en pièce jointe sur https://www.cjoint.com/
et coller le raccourci proposé (clic droit) dans le message de réponse
Dans l’attente
transféré dans forum VBA
Michel
