XL 2010 Copier selon conditions sur autre classeur dans l'ordre

jdjlecto

XLDnaute Nouveau
Bonjour, je pêche sur un sujet depuis un moment alors je viens voir ici si un connaisseur pourra me sortir de là ^^.
Voilà mon problème;
J'ai un tableau avec 10 en-tête de B à J.
Sur ce tableau j'ajoute des données au fur et à mesure (donc tous les champs ne sont pas entré forcément en une seule fois).
J'ai besoin qu'à chaque fois que j'entre une donnée, qu'une copie se fasse automatiquement , dans un autre tableau qui n'est pas exactement le même et au fur et à mesure (par un bouton ou de manière automatique).
Mais surtout qu'il n'y est pas de doublon dans le tableau qui reçoi la copie, et que les info s'accumule de ligne en ligne sans en écraser et sans faire d'espace.
Quelqu'un pense avoir une solution ?
Je débute en VBA, j'en apprend chaque jour mais là j'ai vraiment besoin.

J'ai été aider pour avoir de quoi copier, et sans doublon mais ça ne fonctionne que si tous les champs on été rempli.
Code:
Option Explicit

Sub Cp2()
Dim wkb1 As Workbook
Dim wkb2 As Workbook
Dim der1 As Long
Dim der2 As Long
Dim c As Range
Dim res As Variant

  Application.ScreenUpdating = False
  Set wkb1 = ActiveWorkbook
  der1 = ActiveSheet.Cells(Application.Rows.Count, "B").End(xlUp).Row
  If der1 = 2 Then Exit Sub
  Workbooks.Open Filename:=wkb1.Path & "\fichier1.xlsm"
  Set wkb2 = ActiveWorkbook
  wkb1.Activate
   For Each c In wkb1.Sheets(1).Range("C3:C" & der1)
       res = Application.Match(c, wkb2.Sheets(1).Range("C3:C500"), 0)
       If IsError(res) Then
 
       der2 = wkb2.Sheets(1).Cells(Application.Rows.Count, "B").End(xlUp).Row + 1
          wkb2.Sheets(1).Range("B" & der2 & ":I" & der2).Value = wkb1.Sheets(1).Range("B" & c.Row & ":I" & c.Row).Value
       End If
    Next c
  wkb2.Activate
  wkb2.Close savechanges:=True
Application.ScreenUpdating = True
End Sub
 
Dernière édition:

jdjlecto

XLDnaute Nouveau
Oui, je me suis fait aider sur un autre forum, puis j'ai adapter en rapport à ma situation.

Code:
Sub CopieDonnéesJour3()
Dim wkb1 As Workbook
Dim wkb2 As Workbook
Dim der1 As Long
Dim der2 As Long
Dim c As Range
Dim res As Variant
Application.ScreenUpdating = False
Set wkb1 = ActiveWorkbook
der1 = ActiveSheet.Cells(Application.Rows.Count, "B").End(xlUp).Row
If der1 = 2 Then Exit Sub
Workbooks.Open Filename:=wkb1.Path & "\PF RECAP.xlsm"
Set wkb2 = ActiveWorkbook
  For Each c In wkb1.Sheets(1).Range("K3:K" & der1)
       If c <> "" Then
          res = Application.Match(c, wkb2.Sheets(1).Range("K3:K500"), 0)
          If IsError(res) Then
         der2 = wkb2.Sheets(1).Cells(Application.Rows.Count, "B").End(xlUp).Row + 1
             wkb2.Sheets(1).Range("B" & der2 & ":K" & der2).Value = wkb1.Sheets(1).Range("B" & c.Row & ":K" & c.Row).Value
          End If
        End If
    Next c
wkb2.Activate
wkb2.Close savechanges:=True
Application.ScreenUpdating = True
End Sub
 

Discussions similaires

Réponses
2
Affichages
827

Statistiques des forums

Discussions
298 792
Messages
1 971 811
Membres
203 481
dernier inscrit
kamrankaghar