Incrémenter ligne vba copie

Elise12 -
michel_m Messages postés 16602 Date d'inscription Statut Contributeur Dernière intervention - 30 déc. 2015 à 14:15

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 :

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 :)

A voir également:

Incrémenter ligne vba copie
Copie cachée - Guide
Partager photos en ligne - Guide
Copie écran samsung - Guide
Copie disque dur - Guide
Mètre en ligne - Guide

2 réponses

Réponse 1 / 2

michel_m Messages postés 16602 Date d'inscription Statut Contributeur Dernière intervention 3 314

bonjour

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

Réponse 2 / 2

michel_m Messages postés 16602 Date d'inscription Statut Contributeur Dernière intervention 3 314

En 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

Discussions similaires

Copier un lien instagram

copie d'un lien dans le navigateur internet

lien copié presse papier smartphone Samsung

Que veut dire "correspondant occupé" lors d'un appel ?

Votre réponse

Discussions similaires