Copier coller

Fermé

pat - Modifié le 5 nov. 2017 à 13:29
yg_be Messages postés 22692 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 16 avril 2024 - 5 nov. 2017 à 23:31

Bonjour,
Alors voila je cherche a faire un petit Code VBa qui me permettrais de faire un copier coller.

j'ai récupérer un code bien complet et j'ai essayer de l'adapter au mieux a ma situation

Globalement ca se passe plutôt bien excepté le fait qu'il me copie les lignes vide.

Je voudrais donc ajouter une condition copier uniquement les ligne qui contienne au moins 1 valeur "texte ou numérique" (attention le tableau est remplis de formule)

Sub completer_Base_de_donnée_1()

    
    '----compléter Database 1
    Range("CT12:DN45").Select
    Selection.Copy
    Sheets("Base_de_donnée_1").Select
    
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    ActiveSheet.Range("A2").Select
    
    Dim MyTable1 As ListObject
    Set MyTable1 = Application.Worksheets("Base_de_donnée_1").ListObjects("Database1")
    Dim LastRow As Long
    LastRow = MyTable1.ListRows.Count + 2
    
  
    ActiveSheet.Range("A" & LastRow).Select

     If ActiveCell.Value <> "" Then
        On Error Resume Next
        ActiveCell.Offset(1, 0).Select
        Err.Clear
   
     End If
    
      
    
    
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Application.CutCopyMode = False
    
  '----compléter Database 2

   



End Sub

Merci d'avance a ceux qui essayerons de m'aider!

A voir également:

Copier coller
Copier coller pdf - Guide
Copier une vidéo youtube - Guide
Super copier - Télécharger - Gestion de fichiers
Copier coller chatgpt ✓ - Forum Réseaux sociaux
Dessin sms copier coller - Forum Jeux vidéo

2 réponses

Réponse 1 / 2

yg_be Messages postés 22692 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 16 avril 2024 1 471
Modifié le 5 nov. 2017 à 15:54

bonjour, je suggère ceci:

Sub completer_Base_de_donnée_1()
Dim dest As Range
Dim pave As Range, cell As Range
Dim vide As Boolean
Dim lig As Range, clig As Range
Dim lpave As Long
    
    '----compléter Database 1
    Set pave = Range("CT12:DN45")
    lpave = pave.Columns.Count
    Sheets("Base_de_donnée_1").Select
    
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    ActiveSheet.Range("A2").Select
    
    Dim MyTable1 As ListObject
    Set MyTable1 = Application.Worksheets("Base_de_donnée_1").ListObjects("Database1")
    Dim LastRow As Long
    LastRow = MyTable1.ListRows.Count + 2
  
    ActiveSheet.Range("A" & LastRow).Select

     If ActiveCell.Value <> "" Then
        On Error Resume Next
        ActiveCell.Offset(1, 0).Select
        Err.Clear
   
     End If
    
Set dest = Selection
For Each lig In pave.Rows
    Set clig = Intersect(pave, lig)
    vide = True
    For Each cell In clig
        If cell <> "" Then
            vide = False
            Exit For
        End If
    Next cell
    If Not vide Then
        dest.Resize(1, lpave).Cells.Value = clig.Cells.Value
        Set dest = dest.Offset(1, 0)
     End If
Next lig
    
  '----compléter Database 2

End Sub

Réponse 2 / 2

pat
5 nov. 2017 à 21:12

Merci Yg-be
a première vue ton code fonctionne parfaitement, je vais encore faire des test pendant quelques jour et j'espere que je ne verrais pas de bug apparaître!!

Donc tout ce que j'ai a dire en ce moment c'est MERCI!!!!!

yg_be Messages postés 22692 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 16 avril 2024 1 471
5 nov. 2017 à 23:31

petit changement:

Sub completer_Base_de_donnée_1()
Dim dest As Range
Dim pave As Range, cell As Range
Dim vide As Boolean
Dim lig As Range, clig As Range
    
    '----compléter Database 1
    Set pave = Range("CT12:DN45")
    Sheets("Base_de_donnée_1").Select
    
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    ActiveSheet.Range("A2").Select
    
    Dim MyTable1 As ListObject
    Set MyTable1 = Application.Worksheets("Base_de_donnée_1").ListObjects("Database1")
    Dim LastRow As Long
    LastRow = MyTable1.ListRows.Count + 2
  
    ActiveSheet.Range("A" & LastRow).Select

     If ActiveCell.Value <> "" Then
        On Error Resume Next
        ActiveCell.Offset(1, 0).Select
        Err.Clear
   
     End If
    
Set dest = Selection.Resize(1, pave.Columns.Count)
For Each lig In pave.Rows
    Set clig = Intersect(pave, lig)
    vide = True
    For Each cell In clig
        If cell <> "" Then
            vide = False
            Exit For
        End If
    Next cell
    If Not vide Then
        dest.Cells.Value = clig.Cells.Value
        Set dest = dest.Offset(1, 0)
     End If
Next lig
    
  '----compléter Database 2

End Sub

Copier coller

2 réponses

Discussions similaires

Newsletters