XL 2013 Ventilation de données et Ecarts de lignes

JBond13600

XLDnaute Nouveau
Bonjour à tous,

Nouveau sur ce site et débutant dans le VBA, j'aurais besoin de 3 macros que je ne suis pas encore actuellement en mesure de sortir.

La 1re consiste à ventiler des lignes de données d'un premier onglet vers les autres. (1er fichier joint avec résultats attendus).

La seconde est une mise à jour de ces données selon le même principe. (2me fichier joint avec résultats attendus).

La troisième consiste à calculer les écarts de ces lignes de données dans tous les onglets à partir d'une référence précise. (3me fichier joint avec résultats attendus).

S'il vous était possible de noter à l'intérieur de la macro ce à quoi consiste chaque ligne de commande, cela serait du top pour moi.

Merci par avance de votre aide.
 

Fichiers joints

jp14

XLDnaute Barbatruc
Bonjour et bienvenue suur le Forum
Ci dessous une macro pour le premier fichier
Code:
Option Explicit


Sub travdem()
Dim Cellule1 As Range, Plg1 As String, Dl1 As Long
Dim Nomfeuille1 As String, Col1 As String

'parametre
Nomfeuille1 = "Base"
Col1 = "A"
'code
With Sheets(Nomfeuille1)

    'vérification de l’existence de la feuille
For Each Cellule1 In .Range(Col1 & "1:" & Col1 & .Range(Col1 & .Rows.Count).End(xlUp).Row)

    If FeuillePresente(Cellule1.Value) = False Then
    Call MsgBox("La feuille : " & Cellule1.Value & " n'existe pas" _
                & vbCrLf & "Ligne :" & Cellule1.Row _
                , vbCritical, Application.Name)
        Exit Sub
    End If
Next Cellule1

' Copie des données

For Each Cellule1 In .Range(Col1 & "2:" & Col1 & .Range(Col1 & .Rows.Count).End(xlUp).Row)
    Dl1 = Sheets(Cellule1.Value).Range(Col1 & Sheets(Cellule1.Value).Rows.Count).End(xlUp).Row + 1
    .Range("a" & Cellule1.Row & ":" & "h" & Cellule1.Row).Copy _
    Destination:=Worksheets(Cellule1.Value).Range("A" & Dl1)

Next Cellule1
End With
End Sub

Private Function FeuillePresente(NomFeuille As String) As Boolean
Dim Sh As Worksheet
    For Each Sh In Worksheets
        If Sh.Name = NomFeuille Then
            FeuillePresente = True
            Exit Function
        End If
    Next Sh
 
End Function
Autant pour moi je ne n'ai pas lu toutes les lignes.
A tester

JP14
 
Dernière édition:

jp14

XLDnaute Barbatruc
Bonjour (Re)

Ci dessous la macro avec sélection de la ligne de départ.
Code:
Option Explicit
Sub travdem()
Dim Cellule1 As Range, Plg1 As String, Dl1 As Long, Dl2 As Long, Plg3 As Range
Dim Nomfeuille1 As String, Col1 As String
Dim MonTab As Variant, Compt1 As Long
'parametre
Nomfeuille1 = "Base"
Col1 = "A"
'code
With Sheets(Nomfeuille1)

Select Case MsgBox("Les données seront recopiées à partir de la ligne active  " _
                   & vbCrLf & "ligne active : " & ActiveCell.Row _
                   & vbCrLf & "" _
                   , vbYesNo Or vbExclamation Or vbDefaultButton1, "Ligne de départ")

    Case vbYes
        Select Case MsgBox("Les données seront recopiées à partir de la ligne " & ActiveCell.Row _
                   & vbCrLf & "" _
                   & vbCrLf & "Veuillez confirmer " _
                   & vbCrLf & "" _
                   & vbCrLf & "" _
                   , vbYesNo Or vbExclamation Or vbDefaultButton1, "Départ")

        Case vbYes
            Dl2 = ActiveCell.Row
        Case vbNo
            Exit Sub
        End Select

    Case vbNo
        Exit Sub
End Select

Set Plg3 = .Range(Col1 & Dl2 & ":" & Col1 & .Range(Col1 & .Rows.Count).End(xlUp).Row)
    'vérification de l'existance de la feulle
For Each Cellule1 In Plg3
    If FeuillePresente(Cellule1.Value) = False Then
    Call MsgBox("La feuille : " & Cellule1.Value & " n'existe pas" _
                & vbCrLf & "Ligne :" & Cellule1.Row _
                , vbCritical, Application.Name)
        Exit Sub
    End If
Next Cellule1
'recopie des données
For Each Cellule1 In Plg3
    Dl1 = Sheets(Cellule1.Value).Range(Col1 & Sheets(Cellule1.Value).Rows.Count).End(xlUp).Row + 1
    .Range("a" & Cellule1.Row & ":" & "h" & Cellule1.Row).Copy _
    Destination:=Worksheets(Cellule1.Value).Range("A" & Dl1)

Next Cellule1




End With
End Sub
Private Function FeuillePresente(NomFeuille As String) As Boolean
Dim Sh As Worksheet
    For Each Sh In Worksheets
        If Sh.Name = NomFeuille Then
            FeuillePresente = True
            Exit Function
        End If
    Next Sh
   
End Function
A tester

JP14
 

JBond13600

XLDnaute Nouveau
Bonjour et bienvenue suur le Forum
Ci dessous une macro pour le premier fichier
Code:
Option Explicit


Sub travdem()
Dim Cellule1 As Range, Plg1 As String, Dl1 As Long
Dim Nomfeuille1 As String, Col1 As String

'parametre
Nomfeuille1 = "Base"
Col1 = "A"
'code
With Sheets(Nomfeuille1)

    'vérification de l’existence de la feuille
For Each Cellule1 In .Range(Col1 & "1:" & Col1 & .Range(Col1 & .Rows.Count).End(xlUp).Row)

    If FeuillePresente(Cellule1.Value) = False Then
    Call MsgBox("La feuille : " & Cellule1.Value & " n'existe pas" _
                & vbCrLf & "Ligne :" & Cellule1.Row _
                , vbCritical, Application.Name)
        Exit Sub
    End If
Next Cellule1

' Copie des données

For Each Cellule1 In .Range(Col1 & "2:" & Col1 & .Range(Col1 & .Rows.Count).End(xlUp).Row)
    Dl1 = Sheets(Cellule1.Value).Range(Col1 & Sheets(Cellule1.Value).Rows.Count).End(xlUp).Row + 1
    .Range("a" & Cellule1.Row & ":" & "h" & Cellule1.Row).Copy _
    Destination:=Worksheets(Cellule1.Value).Range("A" & Dl1)

Next Cellule1
End With
End Sub

Private Function FeuillePresente(NomFeuille As String) As Boolean
Dim Sh As Worksheet
    For Each Sh In Worksheets
        If Sh.Name = NomFeuille Then
            FeuillePresente = True
            Exit Function
        End If
    Next Sh
 
End Function
A tester

JP14
 

JBond13600

XLDnaute Nouveau
Salut JP14,

D'abord un grand merci pour ta réponse. J'ai testé la 1re macro mais elle ne traite que les onglet C1 à C7.
Pas de message d'erreur. Il semble donc qu'elle ne reconnaît pas les autres.
 

kingfadhel

XLDnaute Impliqué
Re,
à propos de 2me Macro

tu insère le code suivant dans un module.

VB:
Sub kingfadhel2()
a = InputBox("Saisir la première ligne de mise à jour")
b = InputBox("Saisir la dernière ligne de mise à jour")
Application.ScreenUpdating = False
Dim sh As Worksheet
Dim wbk As Workbook
'lig = Range("A" & Rows.Count).End(xlUp).Row
For i = a To b
    For k = 2 To Sheets.Count
        If Left(Sheets(k).Name, 1) = "C" Then
        J = Right(Sheets(k).Name, Len(Sheets(k).Name) - 1)
        txt = Right(Range("a" & i), 1)
        If InStr(1, J, txt, vbTextCompare) > 0 Then
            Range("A" & i & ":I" & i).Copy
            Sheets("C" & J).Activate
            lig2 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
            Range("A" & lig2).Select
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Sheets("Base").Activate
            End If
        End If
    Next
Next
Application.ScreenUpdating = True
End Sub
 

JBond13600

XLDnaute Nouveau
Re,
à propos de 2me Macro

tu insère le code suivant dans un module.

VB:
Sub kingfadhel2()
a = InputBox("Saisir la première ligne de mise à jour")
b = InputBox("Saisir la dernière ligne de mise à jour")
Application.ScreenUpdating = False
Dim sh As Worksheet
Dim wbk As Workbook
'lig = Range("A" & Rows.Count).End(xlUp).Row
For i = a To b
    For k = 2 To Sheets.Count
        If Left(Sheets(k).Name, 1) = "C" Then
        J = Right(Sheets(k).Name, Len(Sheets(k).Name) - 1)
        txt = Right(Range("a" & i), 1)
        If InStr(1, J, txt, vbTextCompare) > 0 Then
            Range("A" & i & ":I" & i).Copy
            Sheets("C" & J).Activate
            lig2 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
            Range("A" & lig2).Select
            ActiveSheet.Paste
            Cells.EntireColumn.AutoFit
            Sheets("Base").Activate
            End If
        End If
    Next
Next
Application.ScreenUpdating = True
End Sub
 

JBond13600

XLDnaute Nouveau
Oupsssssssssss,

Pour cette 2me macro, il m'envoie : Erreur de compilation : Erreur de syntaxe
sur la ligne :
For k = 2 To Sheets.Count
 

kingfadhel

XLDnaute Impliqué
Tu remplace
For k=2 to sheets.count
Par
For Each sh In ThisWorkbook.Worksheets

Et teste.
Desolé je me connecte à partir de mon smartphone.
 

JBond13600

XLDnaute Nouveau
Je ne me vois pas faire une erreur de copie dans le module.

Si tu peux m'envoyer non pas le code à recopier mais le fichier "macro" comme le premier, cela éliminerait une nouvelle piste d'erreur de ma part.
 

JBond13600

XLDnaute Nouveau
Salut Kingfadhel,

Parfaitement géniale ta 2me macro. J'avais pas eu le temps de la tester avant ce matin.
C'est impressionnant comme tu maîtrises le truc.

Pour la 3me macro à laquelle j'ai apporté des modifications pour plus de clarté, quelques explications dont la réponse à ton interrogation précédente :

Le projet sur lequel je travail depuis un certain temps maintenant consiste à analyser des séries et à en récupérer, pour chacune et à des moments différents, leur "Ecart Maximum" et leur "Ecart en Cours".

Les séries sont celles contenues dans la colonne "I" de chaque feuille. On y trouve des zéros et des étoiles.
Chaque zéro "0" correspond à un événement recherché et chaque étoile correspond à un écart entre deux événements recherchés ("0").
Si deux "0" se succèdent immédiatement, l'écart entre ces deux événements est égal à zéro. c'est pour cette raison que la comptabilisation des écarts commence par un zéro et non par un "1".
C'est le cas des lignes "22" et "23". Après un Ecart de "9" en ligne "22", l'événement s'est reproduit immédiatement en ligne "23".
Si l'événement s'était reproduit à nouveau en ligne "24" nous aurions eu effectivement un "0" en ligne "25". Or l'événement ne s'est pas reproduit tout de suite (étoile de la ligne "24") mais à la 2me ligne suivante (ligne "25"). Il y a donc bien un Ecart de "1" entre l'événement de la ligne "23" et celui de la ligne "25".

Par suite, si la macro définitive devait être décomposée en plusieurs étapes de traitement du fichier, cela donnerait ce qui suit :

Etape 1 :
Comptabilisation des Ecarts de chaque série de chaque feuille (fichier joint "3me macro Etape 1").
Remarque 1 : Lorsque la série débute par une ou plusieurs étoiles, l'Ecart constaté dès le premier événement est seulement indicatif car on ne connaît pas les lignes précédentes. L'Ecart sera alors précédé d'un "?" pour le signifier.
Remarque 2 : Lorsque la série se termine par une ou plusieurs étoiles cela veut dire qu'un écart est en cours. La dernière étoile de la série sera alors remplacé par l'écart trouvé, précédé de "EEC" pour "Ecart En Cours".

Etape 2 :
Suppression de toutes les lignes comportant une étoile, de chaque série, de chaque feuille. Ces lignes ayant été comptabilisées en Ecarts, elles ne servent plus à rien. (fichier joint "3me macro Etape 2").

Etape 3 et dernière :
Création d'une feuille regroupant tous les résultats obtenus et appelée "Résultats" (fichier joint "3me macro Finale"). Cette feuille serait en 2me position dans le fichier afin de pouvoir y accéder rapidement dès l'ouverture du fichier.
Remarque 1 : L'Ecart Max constaté d'une série peut être celui précédé de "?" ou de "EEC"
Remarque 2 : Il peut ne pas y avoir d'Ecart En Cours lorsque la série ne comporte que des étoiles.


Voilà pour l'ensemble des explications qui me semblaient être utiles.

Je ne doute pas de tes capacités à réaliser cette macro qui me semble moins complexe que les deux précédentes. En revanche je ne sais si tu auras ou prendras le temps de la créer.

En tous les cas, un immense merci pour ce qui a déjà été réalisé et qui boost mon projet en cours.

Bonne Journée.
 

Fichiers joints

Discussions similaires


Haut Bas