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
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
A voir également:
- Incrémenter ligne vba copie
- Copie cachée - Guide
- Partager photos en ligne - Guide
- Aller à la ligne excel - Guide
- Copie écran samsung - Guide
- Site de vente en ligne particulier - Guide
2 réponses
michel_m
Messages postés
16603
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
16 décembre 2023
3 312
Modifié par michel_m le 30/12/2015 à 12:16
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:
Dans l’attente
transféré dans forum VBA
Michel
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
michel_m
Messages postés
16603
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
16 décembre 2023
3 312
Modifié par michel_m le 30/12/2015 à 14:21
Modifié par michel_m le 30/12/2015 à 14:21
En attendant,code "à l'aveugle" et donc "à risque" puisque classeur non fourni
je repasse en fin d'aprem
Michel
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