Recopie des valeurs

[alcalzone]

Bonjour à tous,

J'au adapté un code trouvé sur ce forum pour recopier les lignes non vides de tous les onglets "SEM" vers l'onglet "Données"
Ce code fonctionne à merveille sauf que: Il recopie aussi les formules et du coup, le résulatat n'est pas bon dans les colonnes RSC et SEM.
Je voudrai donc recopier uniquement les valeurs vers la feuille données.

Merci de votre aide

 

[Fred0o]

Re : Recopie des valeurs

Bonsoir alcalzone,

Essaie donc avec ceci :

Application.ScreenUpdating = False 'masque les changements à l'écran
Set oc = Sheets("Données") 'définit l'onglet cible
Set ad = oc.Range("a5").CurrentRegion 'définit la plage des anciennes données
If ad.Rows.Count > 1 Then 'condition si la plage ad compte plus d'une seule ligne
    Set ad = ad.Offset(1, 0).Resize(ad.Rows.Count - 1, ad.Columns.Count) 'redéfinit la plage ad (sans la première ligne)
    ad.ClearContents 'efface les anciennes données
End If 'fin de la condition
For Each o In Sheets 'boucle 1 : sur tous les onglets du classeur
    If Not o.Name = "Nb Visites terrain client-T" Then
    If Not o.Name = "Activité TBC " Then
    If Not o.Name = "Synthèse activité 1" Then
    If Not o.Name = "Synthèse activité 2" Then
    If Not o.Name = "Nb Clients différents visités" Then
    If Not o.Name = "Clients_différents" Then
    If Not o.Name = "Données" Then 'condition : si le nom de l'onglet est différent de "Données"
        dl = o.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée de la colonne A de l'onglet o
        Set pl = o.Range("f5:f" & dl) 'définit la plage pl
        For Each cel In pl 'boucle sur toutes les cellules de la plage pl
            Set dest = oc.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0) 'définit la cellule de destination dest
            'si la cellule n'est pas vide, copie les cellules visibles de la ligne dans dest
            If cel.Value <> "" Then
                cel.EntireRow.SpecialCells(xlCellTypeVisible).Copy
                dest.PasteSpecial (xlPasteValues)
                Application.CutCopyMode = False
            End If
        Next cel 'prochaine cellule de la plage pl
    End If 'fin de la condition
    End If
    End If
    End If
    End If
    End If
    End If
Next o 'prochain onglet de la boucle 1
Application.ScreenUpdating = True 'affiche les changements à l écran
End Sub

A+

 

[laurent950]

Re : Recopie des valeurs

Bonsoir,

Option Explicit


Sub Formeautomatique1_QuandClic()
Dim oc As Object 'déclare la variable oc (Onglet Cible)
Dim ad As Range 'déclare la variable ad (Anciennes Données)
Dim o As Object 'déclare la variable o (Onglet)
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim dest As Range 'déclare la variable dest (cellule de DESTination)
Dim pl As Range 'déclare la variable pl (PLage)
Dim cel As Range 'déclare la variable cel (CELlule)

Sheets("Données").Select
Range("a4:aj60000").Select
Selection.ClearContents
Application.ScreenUpdating = False 'masque les changements à l'écran
Set oc = Sheets("Données") 'définit l'onglet cible
Set ad = oc.Range("a5").CurrentRegion 'définit la plage des anciennes données
If ad.Rows.Count > 1 Then 'condition si la plage ad compte plus d'une seule ligne
    Set ad = ad.Offset(1, 0).Resize(ad.Rows.Count - 1, ad.Columns.Count) 'redéfinit la plage ad (sans la première ligne)
    ad.ClearContents 'efface les anciennes données
End If 'fin de la condition
For Each o In Sheets 'boucle 1 : sur tous les onglets du classeur
    If Not o.Name = "Nb Visites terrain client-T" Then
    If Not o.Name = "Activité TBC " Then
    If Not o.Name = "Synthèse activité 1" Then
    If Not o.Name = "Synthèse activité 2" Then
    If Not o.Name = "Nb Clients différents visités" Then
    If Not o.Name = "Clients_différents" Then
    If Not o.Name = "Données" Then 'condition : si le nom de l'onglet est différent de "Données"
        dl = o.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée de la colonne A de l'onglet o
        Set pl = o.Range("f5:f" & dl) 'définit la plage pl
        For Each cel In pl 'boucle sur toutes les cellules de la plage pl
            Set dest = oc.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0) 'définit la cellule de destination dest
            'si la cellule n'est pas vide, copie les cellules visibles de la ligne dans dest
            If cel.Value <> "" Then
            cel.EntireRow.SpecialCells(xlCellTypeVisible).Copy dest
           ' *************************           
           ' Rajout par rapport a votre macro
            ' copie + collage spéciale des valeur sur les 2 premieres colonnes uniquement
            cel.Offset(, -5).Resize(1, 2).Copy
            dest.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            Application.CutCopyMode = False
            End If
            ' Fin du Rajout
          ' ************************* 
          Next cel 'prochaine cellule de la plage pl
    End If 'fin de la condition
    End If
    End If
    End If
    End If
    End If
    End If
Next o 'prochain onglet de la boucle 1
Application.ScreenUpdating = True 'affiche les changements à l écran
End Sub

Laurent

 

[alcalzone]

Re : Recopie des valeurs

Bonsoir FredOo et Laurent950,

Vos propositions fonctionnent mais sur la première ligne de recopie de la feuille "données", la macro crée un doublon avec "0" en RSC et "0" en SEM???

Qu'en pensez vous?

 

[laurent950]

Re : Recopie des valeurs

Je vois pas ou c'est a dire par rapport à quoi se doublon ?

 

[laurent950]

Re : Recopie des valeurs

Avec cette macro cela devrais être plus simple a gérer

Sub test()

Dim TouteFeuille As Worksheet

Dim F2 As Worksheet
Set F2 = Worksheets("Synthèse activité 1")

' A ajouter si les onglet existe dans votre macro
'Dim F3 As Worksheet
'Set F3 = Worksheets("Nb Visites terrain client-T")
'Dim F4 As Worksheet
'Set F4 = Worksheets("Activité TBC ")
'Dim F5 As Worksheet
'Set F5 = Worksheets("Synthèse activité 1")
'Dim F6 As Worksheet
'Set F6 = Worksheets("Synthèse activité 2")
'Dim F7 As Worksheet
'Set F7 = Worksheets("Nb Clients différents visités")
'Dim F8 As Worksheet
'Set F8 = Worksheets("Clients_différents")

Application.ScreenUpdating = False 'masque les changements à l'écran

Dim F1 As Worksheet
Set F1 = Worksheets("Données")

' Nettoyage
 F1.Range("a4:aj60000").ClearContents

' Boucle
cpt = 4
For Each TouteFeuille In Worksheets
If TouteFeuille.Name <> F1.Name And TouteFeuille.Name <> F2.Name Then
    ' A rajouter si vos onglet existe voir si dessus
    ' Or TouteFeuille.Name <> F3.Name Or TouteFeuille.Name <> F4.Name Or
    ' TouteFeuille.Name <> F5.Name Or TouteFeuille.Name <> F6.Name Or TouteFeuille.Name <> F7.Name Or _
    ' TouteFeuille.Name <> F8.Name Then

  dl = TouteFeuille.Cells(65536, 3).End(xlUp).Row 'définit la dernière ligne éditée de la colonne C ' coriger A de l'onglet o
  pl = TouteFeuille.Range(TouteFeuille.Cells(5, 1), TouteFeuille.Cells(dl, 36))
    For i = 1 To UBound(pl)
    If pl(i, 6) <> Empty Then
        For j = 1 To 36
        F1.Cells(cpt, j) = pl(i, j)
        Next j
    End If
    Next i
  cpt = cpt + 1
  End If
Next TouteFeuille

End Sub

Laurent