Incrémenter ligne vba copie

Fermé

Elise12 - 30 déc. 2015 à 11:38
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 - 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
Hors ligne instagram - Guide
Aller à la ligne excel - Guide
Vente en ligne particulier - Guide
Copie écran samsung - Guide

2 réponses

Réponse 1 / 2

michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
Modifié par michel_m le 30/12/2015 à 12:16

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 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
Modifié par michel_m le 30/12/2015 à 14:21

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

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

Statut « en ligne » alors que non

Ligne occupée : pourquoi mon téléphone sonne occupé ?

Discussions similaires

Newsletters