XL 2013 Ventilation de données et Ecarts de lignes

JBond13600

XLDnaute Junior
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.
 

Pièces jointes

  • 1re Macro.xlsx
    80.6 KB · Affichages: 25
  • 2me Macro.xlsx
    83.1 KB · Affichages: 26
  • 3me Macro.xlsx
    15.2 KB · Affichages: 26

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 Junior
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
 

kingfadhel

XLDnaute Impliqué
Bonjour le fil, le forum,
à propos de : 1er Macro
à toi, testé chez moi

C14.PNG C1347.PNG C235.PNG C47.PNG
 

Pièces jointes

  • 1re Macro.xlsm
    110.3 KB · Affichages: 26

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 Junior
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
 

Discussions similaires

Réponses
20
Affichages
1 K

Statistiques des forums

Discussions
311 720
Messages
2 081 910
Membres
101 837
dernier inscrit
Ugo