Boucle pour copier certaines valeurs d'une ligne [Résolu/Fermé]

Signaler
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
-
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
-
Bonjour,


J'ai créer une macro pour copier les valeurs de la première ligne d'un tableau de la colonne A à C, jusqu'à la prochaine cellule non vide qui correspond à une nouvelle valeur.

Dans mon tableau, dans les 3 premières colonnes se retrouve mes info principales : NO_SITE, NO_SONDAGE et NO_PIÉZO. Cette info, se retrouve seulement sur la première ligne de chacun des NO_SONDAGE différent, ensuite dans les autres colonnes se retrouve la date des lectures (colonne D)et les lectures (colonne E).

Donc en gros, je me sert de la colonne D pour savoir jusqu'à qu'elle ligne je doit copier la première ligne (colonne A à C) de chacun des NO_SONDAGE différents. Le nombre de NO_SONDAGE différents dans une feuille est différent d'un fichier à l'autre.

J'ai réussi en partie à réaliser que je veux mais seulement pour 2 NO_SONDAGE différents (module1). J'imagine qu'il y a un autre moyen d'y parvenir! J'ai essayer avec une fonction "For" sans trop de succès (module2)!

Je demande donc votre aide!

Merci!

Voici mon code:
Option Explicit
Sub copie()

Dim lig As Variant
Dim cell As Variant
Dim row As Variant

ActiveSheet.Unprotect

lig = 2

For Each row In Range("D2" & ":D" & lig).Rows

Do While Not IsEmpty(Range("A" & lig))
    lig = lig + 1
    Range("A" & lig - 1 & ":c" & lig - 1).Copy
    If Range("D" & lig) > 0 Then
        Range("A" & lig).PasteSpecial Paste:=xlPasteValues
    ElseIf Range("D" & lig) = "" Then
        MsgBox "Cette ligne est vide: " & lig
        Range("D" & lig).End(xlDown).Select
        cell = ActiveCell.row
        
        Do While Not IsEmpty(Range("A" & cell))
            cell = cell + 1
            Range("A" & cell - 1 & ":c" & cell - 1).Copy
        If Range("D" & cell) > 0 Then
            Range("A" & cell).PasteSpecial Paste:=xlPasteValues
        ElseIf Range("D" & cell) = "" Then
            MsgBox "Cette ligne est vide: " & cell
            Range("D" & cell).End(xlDown).Select
        End If
    Loop
    
    End If
    
Loop
 Next
 
 ActiveSheet.Protect
End Sub

et voici mon fichier: https://www.cjoint.com/c/FCenwY0c2ko

1 réponse

Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
1
Voici un autre code que j'ai essayé. Je voudrais qu'à la fin de la comparaison, il revienne à la fonction copy pour effectuer l"opération avec la nouvelle valeur de la Ligne. J'imagine qu'il faut que je change les variables, mais je suis peu perdue là!
Option Explicit
Sub copie()

Dim NoCol As Integer
Dim NoLig As Variant
Dim var As Variant
Dim lig As Integer
Dim Ligne As Integer

ActiveSheet.Unprotect

NoCol = 4
lig = 2

For NoLig = 2 To Split(ActiveSheet.UsedRange.Address, "$")(4)
    var = ActiveSheet.Cells(NoLig, NoCol)
    
While Not IsEmpty(Range("D" & lig))
        lig = lig + 1
        Range("A" & NoLig & ":C" & NoLig).Copy
    If Range("D" & lig) > 0 Then
        Range("A" & lig).PasteSpecial Paste:=xlPasteValues
    ElseIf Range("D" & lig) = "" Then
        MsgBox "Cette ligne est vide: " & lig
        Range("D" & lig).End(xlDown).Offset(0, -1).Select
        Ligne = ActiveCell.row
           If Range("C" & Ligne).Value <> Range("C2") Then
                MsgBox "Le numéro de la ligne: " & Ligne
            End If
    End If
Wend

Next
    
           
ActiveSheet.Protect
 
End Sub


Je continue mes recherches!
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
1 >
Messages postés
15378
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 octobre 2020

Re,

Il ne copie que la première valeur de NO_SONDAGE de la première feuille.

J'ai déplacé le code de copie ligne(s) dans la boucle des onglets et c'est la même chose. J'ai aussi essayé d'appeler la macro Copie_2 dans la boucle des onglets et ça ne fonctionne pas non plus!
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
1
Voici le fichier avec plusieurs onglet pour tester:

http://www.cjoint.com/c/FChqZbF3EJo

Merci!
Messages postés
15378
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 octobre 2020
1 377 >
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020

Bonjour,

Dites voir, le fichier que vous mettez a dispo est un xlsx donc sans UF et macro, vous ne pourriez pas mettre a dispo le "vrai fichier" ??????????????????????
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
1 >
Messages postés
15378
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
18 octobre 2020

Re,

Et bien oui, ça irais mieux avec ce fichier:

http://www.cjoint.com/c/FChrS6RYk4o

L'autre fichier est le ficher à traiter!

merci!
Messages postés
266
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
14 février 2020
1
Bonjour,

Finalement, tout marche très bien! J'me suis rendu compte que le fichier à été corrompu, il n'y avais plus de données dans la plupart des onglets! Voici le code final!
Private Sub CommandButton1_Click()

Dim nombre As Integer
Dim Motdepasse As String

If Not Application.Dialogs(xlDialogOpen).Show("M:\Entrepot\BDFS\1_Piézomètres") Then Exit Sub


Application.ScreenUpdating = False

Motdepasse = InputBox("Entrer le mot de passe :", "Oter la protection de toutes les feuilles", "")
nombre = ActiveWorkbook.Sheets.Count
For i = 2 To nombre
Worksheets(i).Unprotect Password:=Motdepasse
Next i

For x = 2 To Sheets.Count - 1
    With Sheets(x)
    Sheets(x).Select
    Columns("E:O").Select
    Selection.EntireColumn.Hidden = False
    derlig = .Range("F" & Rows.Count).End(xlUp).row
        For N = 2 To derlig
            If .Range("D" & N) <> "" Then
                If .Range("A" & N) <> "" Then
                    TInfos = .Range("A" & N & ":C" & N)
                Else
                    .Range("A" & N & ":C" & N) = TInfos
                End If
            End If
        Next N
    Sheets(x).Range("A2").Select
    
    End With
    
Next x
   


Motdepasse = InputBox("Entrer le mot de passe :", "Mettre la protection sur toutes les feuilles", "")
nombre = ActiveWorkbook.Sheets.Count
For i = 2 To nombre
Worksheets(i).Protect Password:=Motdepasse
Next i

UserForm1.Hide


Application.Dialogs(xlDialogSaveAs).Show ("M:\Entrepot\BDFS\1_Piézomètres\")
Application.ScreenUpdating = True

ThisWorkbook.Saved = True
'Application.Quit


End Sub

Merci!