Copier coller
pat
-
yg_be Messages postés 23541 Date d'inscription Statut Contributeur Dernière intervention -
yg_be Messages postés 23541 Date d'inscription Statut Contributeur Dernière intervention -
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)
Merci d'avance a ceux qui essayerons de m'aider!
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
- Historique copier coller - Guide
- Copier coller pdf - Guide
- Copier-coller - Accueil - Informatique
- Style d'écriture a copier coller - Guide
- Arobase copier coller - Forum Windows 10
2 réponses
yg_be
Messages postés
23541
Date d'inscription
Statut
Contributeur
Dernière intervention
Ambassadeur
1 584
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
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!!!!!
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!!!!!
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