XL 2013 MACRO : Transférer des données entre onglets

Omegan · 16 Juillet 2019

Bonjour à tous,

Actuellement grand débutant en VBA, je suis entrain de monter un outil de Suivi dans le cadre de mon boulot. Pour cela j'utilise principalement une macro qui copie/colle une base de donnée stocké d'un onglet à un autre. Mon objectif final est de pouvoir automatiser le transfert et classer l'ensemble des informations présente (classé par lignes) pour pouvoir les analyser et établir un suivi.

Avant de vous dévoiler le code, j'aimerai que vous m'apportiez les éléments suivants :
- Créer une fonction pour éviter de recopier le code inutilement
- Simplifier mon code en évitant les .Select
- Effacer la ligne sur 0. lorsqu'elle a était copié
- Mettre en place un système qui permettrai que mes formules de total puissent inclurent les lignes collées automatiquement (pour ça je suis vraiment coincé, voir formules onglet 2.)
- Faire en sortes que mon code fonctionne parfaitement (en effet, au vu de mon tâtonnement je pense avoir fais des petites erreurs qui influent sur l'efficacité du code)

Voici le code que j'utilise (en PJ le document en entier) :

Sub MAJSuivi()

' Définition des variables
Dim Fourni As String
Dim Fourni2 As Range
Dim lig, lig2, lig3 As Long
Dim col As String
Dim i, j As Integer

Dim wsA As Worksheet
Dim wsB As Worksheet
Dim Suivi As Workbook
Dim nblignetot As Long

' Paramétrage des variables

Set Suivi = ThisWorkbook
Set wsA = Suivi.Worksheets("0.")
Set wsB = Suivi.Worksheets("Test")

nblignetot = WorksheetFunction.CountA(Range("D")) 'Delimitation de la zone de travail
lig2 = 0 'Initialisation

'MsgBox "Nombre de ligne =" & nblignetot

For i = 8 To nblignetot

wsA.Select 'Trouver le n° du fournisseur
col = "B"
lig = i
Fourni = Cells(lig, col)
MsgBox "Nombre de ligne tot : " & nblignetot 'Verif des variables
MsgBox "Fournisseur en cours : " & Fourni
MsgBox "numéro de ligne = " & lig

If Fourni = "1" Then

wsB.Select
Columns("B:B").Select
Set Fourni2 = Selection.Find(What:=Fourni, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False) 'Recherche dans l'onglet Test du placement du fournisseur en question

If Fourni2 Is Nothing Then
MsgBox ("Fournisseur non attribué : ") & Fourni

Else

'MsgBox ("Fourni2 = " & Fourni2) 'Verif Valeur Fourni2
Fourni2.Select
Selection.EntireRow.Insert 'Ajout d'une ligne pour coller les infos de l'onglet 0.
lig2 = ActiveCell.Row
'MsgBox ("lig2 : " & lig2) 'Verif valeur ligne active lig2
'MsgBox ("lig : " & lig)

wsA.Select 'Couper coller (+ mise en forme de la ligne selon n-1)
Rows(lig).Cut

wsB.Select
Rows(lig2).Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("A" & lig2 & ":B" & lig2).Select
Selection.ClearContents

lig3 = lig2 - 1
MsgBox ("lig3 = " & lig3)

Rows(lig3).Copy
Rows(lig2).PasteSpecial xlFormats

Application.CutCopyMode = False 'Fin

End If

ElseIf Fourni = "2" Then

//Ainsi de suite jusqu'à mon dernier fournisseur.

Calvus · 17 Juillet 2019

Bonjour Omegan,

Bienvenue sur le forum.

Voici un fichier permettant de répondre à tes besoins, si j'ai bien tout compris.
Il manque juste la dernière ligne du tableau à renseigner, je regarderai ce soir si j'ai le temps.
Voici le code

VB:

Option Explicit

Sub Copie()
Dim f As Worksheet, f1 As Worksheet, i As Integer, j As Integer, t, t1, a(), n As Integer, m As Integer
Dim valeur As String, k As Single, dep As Single, fin As Single
Set f = Sheets("0.")
Set f1 = Sheets("Test")

t = f.Range("B8" & ":H" & f.Range("B" & Rows.Count).End(xlUp).Row)
t1 = f1.Range("B25" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row)

ReDim a(1 To UBound(t1) + UBound(t), 1 To UBound(t1))

For i = 2 To UBound(t1)
    If t1(i, 1) <> "" Then
    valeur = t1(i, 1)
                n = n + 1
                a(n, 1) = t1(i, 1)
                a(n, 2) = t1(i - 1, 2)
                a(n, 3) = t1(i - 1, 3)
                a(n, 4) = t1(i - 1, 4)
                a(n, 5) = t1(i - 1, 5)
                a(n, 6) = t1(i - 1, 6)
dep = n
        For j = 1 To UBound(t)
            If t1(i, 1) = t(j, 1) And t1(i, 3) <> t(j, 3) Then
                n = n + 1
                a(n, 1) = t(j, 1)
                a(n, 2) = t(j, 2)
                a(n, 3) = t(j, 3)
                a(n, 4) = t(j, 4)
                a(n, 5) = t(j, 5)
                a(n, 6) = t(j, 6)
                m = m + 1
            End If
fin = n
        Next j
    If valeur <> "" Then
                n = n + 1
                a(n, 1) = valeur
                a(n, 2) = "Total"
                a(n, 3) = ""
                a(n, 4) = "=sum(E" & dep + 25 & ":E" & fin + 25 & ")"
                a(n, 5) = ""
                a(n, 6) = ""
End If
    End If
    For k = 1 To UBound(a)
        If a(k, 2) = "Total" Then
            a(k, 1) = a(k, 1)
        Else
            a(k, 1) = ""
        End If

        If a(k, 1) = "Nbr Fournisseurs" Then
            a(k, 2) = "/"
            a(k, 3) = "Nbr de Projets"
            a(k, 4) = ""
        End If
    Next k
Next i
f1.[B26].Resize(UBound(a, 1), UBound(a, 1)) = a
Call MFC
End Sub
Sub MFC()
Dim i%, f1 As Worksheet, tableau As Range
Set f1 = Sheets("Test")
Set tableau = f1.Range("B24" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row)
f1.Activate
tableau.Borders.LineStyle = xlNone

    With tableau
    .Borders.LineStyle = xlNone
        With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
    End With
    f1.Range("B24" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row).Select
f1.Range("B25" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row).Interior.Color = xlNone
For i = 26 To Cells(Rows.Count, 2).End(xlUp).Row
        With Range(Cells(i, 2), Cells(i, 4))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        End With
    If IsNumeric(Cells(i, 2)) And Cells(i, 2) <> "" Then
        With Range(Cells(i, 2), Cells(i, 14))
        .Interior.Color = 15652540
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        End With
        Cells(i, 2).Interior.Color = 10086399
    End If
Next i
For i = 24 To Cells(Rows.Count, 2).End(xlUp).Row
Cells(i, 4).Borders(xlEdgeRight).Weight = xlMedium
Next i

Dim derligne
derligne = Range("B" & Rows.Count).End(xlUp).Row
With Range("B" & derligne, "n" & derligne)
.Interior.Color = 15773696
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlMedium
End With
End Sub

C'est toujours le même bouton pour lancer la macro.

A+

Ikito · 17 Juillet 2019

Bonjour à vous deux,

Simple remarque :

VB:

n = n + 1
                a(n, 1) = t1(i, 1)
                a(n, 2) = t1(i - 1, 2)
                a(n, 3) = t1(i - 1, 3)
                a(n, 4) = t1(i - 1, 4)
                a(n, 5) = t1(i - 1, 5)
                a(n, 6) = t1(i - 1, 6)

A modifier par :

VB:

n = n + 1
a(n, 1) = t1(i, 1)
For ii = 2 To 6
    a(n, ii) = t1(i - 1, ii)
Next

Et a réitérer.

Calvus · 17 Juillet 2019

Re,

Bonjour Ikito,

C'est juste, c'est plus court, mieux donc.

A+

Omegan · 17 Juillet 2019

Bonjour Calvus,

Tout d'abord je te remercie pour ta réponse et le code que tu me propose, j'ai essayé de comprendre point par point mais j'ai vraiment du mal.

Du coup j'ai essayé de le lancer vite fais et j'ai remarqué que le code réalise bien le fameux copié collé mais si je supprime les lignes en doc 2 (0.) et que je relance la procédure avec une nouvelle ligne, tout le tableau déjà stocké sur l'onglet Test s'efface entièrement. Tu peux faire en sortes que les données une fois copiés, puissent rester dans le tableau et que les prochains projet se stock juste à la suite ?

EDIT : Pour que les infos soient anonyme, j'ai fais en sortes que les noms des fournisseurs n'apparaissent pas, peux-tu me dire ou je peux changer ces informations ? Thanks

A+ !

Calvus · 17 Juillet 2019

Re,

Je regarde ça ce soir.

A+

Calvus · 18 Juillet 2019

Bonjour Omegan, Ikito, le forum,

Une autre proposition ici.

Malheureusement j'ai un problème avec les limites du tableau quand on supprime des lignes de la feuille 0.
Je ne comprends pas..

Je n'ai plus le temps de regarder maintenant.
Je serai en déplacement pendant 4 jours, je regarderai à mon retour, à moins que quelqu'un ne t'ai réglé le problème d'ici là.

VB:

Option Explicit

Sub Copie()
Dim f As Worksheet, f1 As Worksheet, i As Integer, j As Integer, t, t1, t2, a(), n As Integer, m As Integer, b(), c()
Dim valeur As String, k As Single, dep As Single, fin As Single
Set f = Sheets("0.")
Set f1 = Sheets("Test")

t = f.Range("B8" & ":H" & f.Range("B" & Rows.Count).End(xlUp).Row)
t1 = f1.Range("B25" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Row)

If f.Cells(8, 2) = "" Then MsgBox "Tableau vide, lancement impossible": Exit Sub


Dim derligne
derligne = f1.Range("B" & Rows.Count).End(xlUp).Row
f1.Range("B" & derligne, "N" & derligne + 1).Copy Destination:=f1.Range("B200")

f1.Range("B25" & ":N" & f1.Range("B198").End(xlUp).Offset(1, 0).Row).Clear


Feuil3.Range("B1" & ":N" & Feuil3.Range("B" & Rows.Count).End(xlUp).Row).ClearContents

ReDim a(1 To UBound(t1), 1 To UBound(t1))

For i = 1 To UBound(t1) 'Remplissage du 1er tableau
    If t1(i, 1) <> "" Then
            n = n + 1
                a(n, 1) = t1(i, 1)
        For j = 2 To 13
            a(n, j) = t1(i, j)
        Next j
    End If
Next i

For k = 1 To UBound(a)
    If a(k, 2) = "Total" Or a(k, 1) = "Nbr Fournisseurs" Then
        For j = 1 To UBound(a)
            a(k, j) = ""
        Next j
    End If
Next k
Feuil3.[B1].Resize(UBound(a, 1), UBound(a, 1)) = a

n = 0
ReDim b(1 To UBound(t), 1 To UBound(t))
For i = 1 To UBound(t) 'Remplissage du 2eme tableau
    If t(i, 1) <> "" Then
        n = n + 1
            b(n, 1) = t(i, 1)
    For j = 2 To 7
        b(n, j) = t(i, j)
    Next j
End If
Next i
Feuil3.Range("B" & Rows.Count).End(xlUp).Resize(UBound(b, 1), UBound(b, 1)) = b

 f.Range("B8" & ":H" & f.Range("B" & Rows.Count).End(xlUp).Row).ClearContents

'Tri des données
    Feuil3.Sort.SortFields.Clear
    Feuil3.Sort.SortFields.Add Key:=Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Feuil3.Sort
        .SetRange Feuil3.Range("B1" & ":N" & Feuil3.Range("B" & Rows.Count).End(xlUp).Row)
        .Apply
    End With


'Inertion des lignes
Feuil3.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Feuil3.Range("B" & Rows.Count).End(xlUp)
Feuil3.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = "Total"
For i = Feuil3.Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
    If Feuil3.Cells(i, 2) <> Feuil3.Cells(i - 1, 2) Then
        Feuil3.Cells(i, 2).EntireRow.Insert Shift:=xlDown
            Feuil3.Cells(i, 3) = "Total"
                Feuil3.Cells(i, 5) = "=sum(e1:e5)"
        For j = i To 1 Step -1
            If Feuil3.Cells(i, 2) = "" Then fin = Feuil3.Cells(j, 2).Row
        Next j
    End If
Next i
For i = 1 To Feuil3.Range("B" & Rows.Count).End(xlUp).Row 'Insertion des sommes
    If Feuil3.Cells(i, 4) <> "" And Feuil3.Cells(i, 2) = Feuil3.Cells(i + 1, 2) Then
        For j = i To Feuil3.Range("B" & Rows.Count).End(xlUp).Row
            dep = Feuil3.Cells(j, 4).Row
                Do Until Feuil3.Cells(j, 4) = ""
                    fin = Feuil3.Cells(j, 4).Row
                    j = j + 1
                        If Feuil3.Cells(j, 4) = "" Then
                            Feuil3.Cells(j, 5) = "=sum(E" & dep & ":E" & fin & ")"
                                i = j
                            Exit For
                        End If
                Loop
        Next j
    End If
Next i

For i = 2 To Feuil3.Range("B" & Rows.Count).End(xlUp).Row 'Insertion des sommes pour ligne seule
                    If Feuil3.Cells(i - 1, 2) = "" And Feuil3.Cells(i + 1, 2) = "" Then _
                        Feuil3.Cells(i + 1, 5) = "=sum(E" & Feuil3.Cells(i, 5).Row & ":E" & Feuil3.Cells(i, 5).Row & ")"
Next i



Feuil3.Range("B1" & ":N" & Feuil3.Range("C" & Rows.Count).End(xlUp).Row).Copy Destination:=f1.[B26]
Call MFC

derligne = f1.Range("B" & Rows.Count).End(xlUp).Row
f1.Range("B" & derligne, "N" & derligne + 1).Copy Destination:=f1.Range("B198").End(xlUp)(3)

Dim ligneinf As String, lignesup As String
lignesup = f1.Range("B198").End(xlUp)(3).Row
ligneinf = f1.Range("B" & Rows.Count).End(xlUp)(2).Row

Rows(lignesup & ":" & ligneinf).Delete Shift:=xlUp
End Sub
Sub MFC()
Dim i%, f1 As Worksheet, tableau As Range
Set f1 = Sheets("Test")
Set tableau = f1.Range("B24" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row)
f1.Activate
tableau.Borders.LineStyle = xlNone

    With tableau
    .Borders.LineStyle = xlNone
        With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
    End With
    f1.Range("B24" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row).Select
f1.Range("B25" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row).Interior.Color = xlNone
For i = 26 To Cells(Rows.Count, 2).End(xlUp).Row
        With Range(Cells(i, 2), Cells(i, 4))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        End With
    If IsNumeric(Cells(i, 2)) And Cells(i, 2) <> "" Then
        With Range(Cells(i, 2), Cells(i, 14))
        .Interior.Color = 15652540
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        End With
        Cells(i, 2).Interior.Color = 10086399
    End If
Next i
For i = 24 To Cells(Rows.Count, 2).End(xlUp).Row
Cells(i, 4).Borders(xlEdgeRight).Weight = xlMedium
Next i

Dim derligne
derligne = Range("B" & Rows.Count).End(xlUp).Row
With Range("B" & derligne, "n" & derligne)
.Interior.Color = 15773696
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlMedium
End With
End Sub

A+

Calvus · 19 Juillet 2019

Bonsoir,

Voilà, tout fonctionne maintenant, mise à part le traitement de la dernière ligne que je n'ai pas encore fait.

A+

Calvus · 19 Juillet 2019

Bonjour,

Petit rectificatif permettant de colorer les lignes avec des noms, ce qui ne fonctionnait pas dans la version précédente.

D'ailleurs :

Omegan à dit:
EDIT : Pour que les infos soient anonyme, j'ai fais en sortes que les noms des fournisseurs n'apparaissent pas, peux-tu me dire ou je peux changer ces informations ? Thanks

Que voulais tu dire par là ?

VB:

Option Explicit
Option Base 1
Sub Copie()
Application.ScreenUpdating = False
Dim f As Worksheet, f1 As Worksheet, i As Integer, j As Integer, t, t1, t2, a(), n As Integer, m As Integer, b(), c()
Dim valeur As String, k As Single, dep As Single, fin As Single
Set f = Sheets("0.")
Set f1 = Sheets("Test")

t = f.Range("B8" & ":H" & f.Range("B" & Rows.Count).End(xlUp).Row)
t1 = f1.Range("B25" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Row)

If f.Cells(8, 2) = "" Then MsgBox "Tableau vide, lancement impossible": Exit Sub


Dim derligne
derligne = f1.Range("B" & Rows.Count).End(xlUp).Row
f1.Range("B" & derligne, "N" & derligne + 1).Copy Destination:=f1.Range("B200")

f1.Range("B25" & ":N" & f1.Range("B198").End(xlUp).Offset(1, 0).Row).Clear


Feuil3.Range("B1" & ":N" & Feuil3.Range("B" & Rows.Count).End(xlUp).Row).ClearContents

ReDim a(1 To UBound(t1), 1 To UBound(t1))

For i = 1 To UBound(t1) 'Remplissage du 1er tableau
    If t1(i, 1) <> "" Then
            n = n + 1
                a(n, 1) = t1(i, 1)
        For j = 2 To 13
            a(n, j) = t1(i, j)
        Next j
    End If
Next i

For k = 1 To UBound(a)
    If a(k, 2) = "Total" Or a(k, 1) = "Nbr Fournisseurs" Then
        For j = 1 To UBound(a)
            a(k, j) = ""
        Next j
    End If
Next k
Feuil3.[B1].Resize(UBound(a, 1), UBound(a, 1)) = a

n = 0
ReDim b(1 To UBound(t), 1 To UBound(t))
If UBound(t) < 7 Then ReDim b(1 To UBound(t), j)
For i = 1 To UBound(t) 'Remplissage du 2eme tableau
    If t(i, 1) <> "" Then
        n = n + 1
            b(n, 1) = t(i, 1)
    For j = 2 To 7
        b(n, j) = t(i, j)
Debug.Print b(n, j)
    Next j
End If
Next i
Feuil3.Range("B" & Rows.Count).End(xlUp)(2).Resize(UBound(b, 1), j) = b

 f.Range("B8" & ":H" & f.Range("B" & Rows.Count).End(xlUp).Row).ClearContents

'Tri des données
    Feuil3.Sort.SortFields.Clear
    Feuil3.Sort.SortFields.Add Key:=Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Feuil3.Sort
        .SetRange Feuil3.Range("B1" & ":N" & Feuil3.Range("B" & Rows.Count).End(xlUp).Row)
        .Apply
    End With


'Inertion des lignes
Feuil3.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = "Total"
For i = Feuil3.Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
    If Feuil3.Cells(i, 2) <> Feuil3.Cells(i - 1, 2) Then
        Feuil3.Cells(i, 2).EntireRow.Insert Shift:=xlDown
            Feuil3.Cells(i, 3) = "Total"
                Feuil3.Cells(i, 5) = "=sum(e1:e5)"
        For j = i To 1 Step -1
            If Feuil3.Cells(i, 2) = "" Then fin = Feuil3.Cells(j, 2).Row
        Next j
    End If
Next i
For i = 1 To Feuil3.Range("B" & Rows.Count).End(xlUp).Row 'Insertion des sommes
    If Feuil3.Cells(i, 4) <> "" And Feuil3.Cells(i, 2) = Feuil3.Cells(i + 1, 2) Then
        For j = i To Feuil3.Range("B" & Rows.Count).End(xlUp).Row
            dep = Feuil3.Cells(j, 4).Row
                Do Until Feuil3.Cells(j, 4) = ""
                    fin = Feuil3.Cells(j, 4).Row
                    j = j + 1
                        If Feuil3.Cells(j, 4) = "" Then
                            Feuil3.Cells(j, 5) = "=sum(E" & dep & ":E" & fin & ")"
                                i = j
                            Exit For
                        End If
                Loop
        Next j
    End If
Next i

For i = 2 To Feuil3.Range("B" & Rows.Count).End(xlUp).Row 'Insertion des sommes pour ligne seule
                    If Feuil3.Cells(i - 1, 2) = "" And Feuil3.Cells(i + 1, 2) = "" Then _
                        Feuil3.Cells(i + 1, 5) = "=sum(E" & Feuil3.Cells(i, 5).Row & ":E" & Feuil3.Cells(i, 5).Row & ")"
Next i



Feuil3.Range("B1" & ":N" & Feuil3.Range("C" & Rows.Count).End(xlUp).Row).Copy Destination:=f1.[B26]
Call MFC

derligne = f1.Range("B" & Rows.Count).End(xlUp).Row
f1.Range("B" & derligne, "N" & derligne + 1).Copy Destination:=f1.Range("B198").End(xlUp)(3)

Dim ligneinf As String, lignesup As String
lignesup = f1.Range("B198").End(xlUp)(3).Row
ligneinf = f1.Range("B" & Rows.Count).End(xlUp)(2).Row

Rows(lignesup & ":" & ligneinf).Delete Shift:=xlUp
    f1.Range("B24" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row).Select
Application.ScreenUpdating = True
End Sub
Sub MFC()
Dim i%, f1 As Worksheet, tableau As Range
Set f1 = Sheets("Test")
Set tableau = f1.Range("B24" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row)
f1.Activate
tableau.Borders.LineStyle = xlNone

    With tableau
    .Borders.LineStyle = xlNone
        With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
    End With
    f1.Range("B24" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row).Select
f1.Range("B25" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row).Interior.Color = xlNone
For i = 26 To Cells(Rows.Count, 2).End(xlUp).Row
        With Range(Cells(i, 2), Cells(i, 4))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        End With
    If Cells(i, 2) <> "" Then
        With Range(Cells(i, 2), Cells(i, 14))
        .Interior.Color = 15652540
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        End With
        Cells(i, 2).Interior.Color = 10086399
    End If
Next i
For i = 24 To Cells(Rows.Count, 2).End(xlUp).Row
Cells(i, 4).Borders(xlEdgeRight).Weight = xlMedium
Next i

Dim derligne
derligne = Range("B" & Rows.Count).End(xlUp).Row
With Range("B" & derligne, "n" & derligne)
.Interior.Color = 15773696
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlMedium
End With
End Sub

Remarques :
On doit mettre le nom du fournisseur à chaque ligne. Les cellules fusionnées sont un cauchemar sinon.
J'ai ajouté une feuille pour pouvoir traiter les données. Cette feuille peut être cachée, ce que j'ai fait dans cette dernière version.

A +

Omegan · 19 Juillet 2019

Salut Calvus,

Merci pour la MAJ de ton code et le travail que tu as réalisé jusqu'ici cela m'aide vraiment beaucoup !

J'ai remarqué que la première colonne du tableau présent dans l'onglet "0. " ne s'efface pas contrairement aux autres (voir image ci-après).

Pour le sujet des fournisseurs, je viens de voir qu'avec ta solution il n'y a pas besoin de changer les noms par les chiffres, ils sont traités en direct dans le tableau ! (Autant pour moi ! aha)

Est-ce possible de rajouter des colonnes supplémentaires (voir ci-dessous) ?

Pour finir, comment puis-je faire en sortes que les formules des totaux puissent fonctionner avec l'insertion du tableau ? (voir tableau onglet 2. )

Merci d'avance !!

EDIT : J'ai pu voir que tu avais ajouté la couleur aux cellules ajoutée, est-ce possible de mettre en couleur les lignes des totaux à la place ?
Et vraiment je suis navré de te demander tout ces changements mais j'arrive pas à le faire en touchant à ton code...

Calvus · 22 Juillet 2019

Bonjour,

Omegan à dit:
J'ai remarqué que la première colonne du tableau présent dans l'onglet "0. " ne s'efface pas contrairement aux autres (voir image ci-après).

Omegan à dit:
Est-ce possible de rajouter des colonnes supplémentaires (voir ci-dessous) ?

Alors tout d'abord, il est beaucoup plus facile d'avoir la bonne réponse quand la demande est claire est complète dès le début..

Voici le fichier avec les correctifs.
Tout devrait être bon maintenant, normalement.

VB:

Option Explicit
Option Base 1
Sub Copie()
Application.ScreenUpdating = False
Dim f As Worksheet, f1 As Worksheet, i As Integer, j As Integer, t, t1, t2, a(), n As Integer, m As Integer, b(), c()
Dim valeur As String, k As Single, dep As Single, fin As Single
Set f = Sheets("0.")
Set f1 = Sheets("Test")

'Changement
t = f.[B8].CurrentRegion.Offset(1, 1).Resize(f.[B8].CurrentRegion.Offset(1, 1).Rows.Count - 1, f.[B8].CurrentRegion.Columns.Count - 1)
t1 = f1.Range("B25" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Row)

If f.Cells(8, 2) = "" Then MsgBox "Tableau vide, lancement impossible": Exit Sub


Dim derligne
derligne = f1.Range("B" & Rows.Count).End(xlUp).Row
f1.Range("B" & derligne, "N" & derligne + 1).Copy Destination:=f1.Range("B200")

f1.Range("B25" & ":N" & f1.Range("B198").End(xlUp).Offset(1, 0).Row).Clear


Feuil3.Range("B1" & ":N" & Feuil3.Range("B" & Rows.Count).End(xlUp).Row).ClearContents

ReDim a(1 To UBound(t1), 1 To UBound(t1))

'Remplissage du 1er tableau
For i = 1 To UBound(t1)
    If t1(i, 1) <> "" Then
            n = n + 1
                a(n, 1) = t1(i, 1)
        For j = 2 To 13
            a(n, j) = t1(i, j)
        Next j
Debug.Print a(n, j)
    End If
Next i

For k = 1 To UBound(a)
    If a(k, 2) = "Total" Or a(k, 1) = "Nbr Fournisseurs" Then
        For j = 1 To UBound(a)
            a(k, j) = ""
        Next j
    End If
Next k
Feuil3.[B1].Resize(UBound(a, 1), UBound(a, 1)) = a

'Remplissage du 2eme tableau
Dim col As Integer
col = f.Cells(7, Columns.Count).End(xlToLeft).Column - 1
n = 0
ReDim b(1 To UBound(t), 1 To col)
If UBound(t) < col Then ReDim b(1 To UBound(t), col)
For i = 1 To UBound(t)
    If t(i, 1) <> "" Then
        n = n + 1
            b(n, 1) = t(i, 1)
    For j = 2 To col
        b(n, j) = t(i, j)
    Next j
End If
Next i
Feuil3.Range("B" & Rows.Count).End(xlUp)(2).Resize(UBound(b, 1), col) = b

'Changement
f.[A8].CurrentRegion.Offset(1, 0).Resize(f.[A8].CurrentRegion.Rows.Count - 1).ClearContents

'Tri des données
    Feuil3.Sort.SortFields.Clear
    Feuil3.Sort.SortFields.Add Key:=Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Feuil3.Sort
        .SetRange Feuil3.Range("B1" & ":N" & Feuil3.Range("B" & Rows.Count).End(xlUp).Row)
        .Apply
    End With


'Inertion des lignes
Feuil3.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = "Total"
For i = Feuil3.Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
    If Feuil3.Cells(i, 2) <> Feuil3.Cells(i - 1, 2) Then
        Feuil3.Cells(i, 2).EntireRow.Insert Shift:=xlDown
            Feuil3.Cells(i, 3) = "Total"
                Feuil3.Cells(i, 5) = "=sum(e1:e5)"
        For j = i To 1 Step -1
            If Feuil3.Cells(i, 2) = "" Then fin = Feuil3.Cells(j, 2).Row
        Next j
    End If
Next i
For i = 1 To Feuil3.Range("B" & Rows.Count).End(xlUp).Row 'Insertion des sommes
    If Feuil3.Cells(i, 4) <> "" And Feuil3.Cells(i, 2) = Feuil3.Cells(i + 1, 2) Then
        For j = i To Feuil3.Range("B" & Rows.Count).End(xlUp).Row
            dep = Feuil3.Cells(j, 4).Row
                Do Until Feuil3.Cells(j, 4) = ""
                    fin = Feuil3.Cells(j, 4).Row
                    j = j + 1
                        If Feuil3.Cells(j, 4) = "" Then
                            Feuil3.Cells(j, 5) = "=sum(E" & dep & ":E" & fin & ")"
                                i = j
                            Exit For
                        End If
                Loop
        Next j
    End If
Next i

For i = 2 To Feuil3.Range("B" & Rows.Count).End(xlUp).Row 'Insertion des sommes pour ligne seule
                    If Feuil3.Cells(i - 1, 2) = "" And Feuil3.Cells(i + 1, 2) = "" Then _
                        Feuil3.Cells(i + 1, 5) = "=sum(E" & Feuil3.Cells(i, 5).Row & ":E" & Feuil3.Cells(i, 5).Row & ")"
Next i



Feuil3.Range("B1" & ":N" & Feuil3.Range("C" & Rows.Count).End(xlUp).Row).Copy Destination:=f1.[B26]
Call MFC

derligne = f1.Range("B" & Rows.Count).End(xlUp).Row
f1.Range("B" & derligne, "N" & derligne + 1).Copy Destination:=f1.Range("B198").End(xlUp)(3)

Dim ligneinf As String, lignesup As String
lignesup = f1.Range("B198").End(xlUp)(3).Row
ligneinf = f1.Range("B" & Rows.Count).End(xlUp)(2).Row

Rows(lignesup & ":" & ligneinf).Delete Shift:=xlUp
    f1.Range("B24" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row).Select
ligneinf = f1.Range("B" & Rows.Count).End(xlUp)(2).Row

Dim projets As Integer, mwc As Integer 'Calcul des totaux
For i = 26 To ligneinf - 2
    If Cells(i, 4) <> "" Then projets = Cells(i, 5) + projets: mwc = Cells(i, 6) + mwc
Next i
Cells(ligneinf, 4) = projets
Cells(ligneinf, 6) = mwc

Application.ScreenUpdating = True
End Sub
Sub MFC()
Dim i%, f1 As Worksheet, tableau As Range
Set f1 = Sheets("Test")
Set tableau = f1.Range("B24" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row)
f1.Activate
tableau.Borders.LineStyle = xlNone

    With tableau
    .Borders.LineStyle = xlNone
        With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        End With
    End With
    f1.Range("B24" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row).Select
f1.Range("B25" & ":N" & f1.Range("B" & Rows.Count).End(xlUp).Row).Interior.Color = xlNone
For i = 26 To Cells(Rows.Count, 2).End(xlUp).Row
        With Range(Cells(i, 2), Cells(i, 4))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        End With
    If Cells(i, 2) <> "" Then
        With Range(Cells(i, 2), Cells(i, 14))
        .Interior.Color = 15652540
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        End With
        Cells(i, 2).Interior.Color = 10086399
    End If
    If Cells(i, 3) = "Total" Then
        With Range(Cells(i, 2), Cells(i, 14))
        .Interior.Color = 11324408
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        End With
    End If
Next i
For i = 24 To Cells(Rows.Count, 2).End(xlUp).Row
Cells(i, 4).Borders(xlEdgeRight).Weight = xlMedium
Next i

Dim derligne
derligne = Range("B" & Rows.Count).End(xlUp).Row
With Range("B" & derligne, "n" & derligne)
.Interior.Color = 15773696
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlMedium
End With
End Sub

A+

Staple1600 · 22 Juillet 2019

Bonjour le fil

Autre remarque (mais sur le code initial du message#1)
Dim lig, lig2, lig3 As Long
Ici seul lig3 est déclaré as Long, lig et lig2 eux sont en Variant
Donc si on veut du Long tout du long
Il faut écrire
Dim lig As Long, lig2 As Long, lig3 As Long
ou encore en syntaxe "raccourcie"
Dim lig&, lig2&, lig3&

Omegan · 23 Juillet 2019

Bonjour à tous !

Au top merci Calvus !

Oui excuse moi de te rajouter des choses en plus mais je pensais vraiment pouvoir retoucher partiellement ton code pour faire mes dernières modifs mais enfaîte il est trop complexe pour moi.

Petit bémol mais bon je t'avoue que j'ose pas trop te demander au vu du taf que t'as déjà fait.. Tu penses que je pourrai faire comment pour que les formules sur la ligne des totaux puisse automatiquement prendre en compte toutes les lignes du tableau ?

Le but final de l'outil étant d'avoir un récapitulatif par Fournisseur, il faut donc que je trouve un moyen d'automatiser tout ça.

Calvus · 23 Juillet 2019

Bonjour Omegan, mon ami Maître Staple-Yoda, le forum,

Omegan à dit:
comment pour que les formules sur la ligne des totaux puisse automatiquement prendre en compte toutes les lignes du tableau ?

Ce n'est pas déjà le cas avec ma dernière version ?

Omegan à dit:
Le but final de l'outil étant d'avoir un récapitulatif par Fournisseur, il faut donc que je trouve un moyen d'automatiser tout ça.

Le mieux, comme toujours, reste un fichier exemple avec des données inscrites manuellement...

A+

Omegan · 23 Juillet 2019

Calvus,

Si tu vas dans l'onglet 2. tu verras mon ancienne version avant tes modifs, dans la ligne des totaux, il y a toutes les formules que j'aimerai mettre en place automatiquement lors de la création du tableau.

Actuellement il n'y a que la formule de la somme des projets gagnés qui fonctionne :

Par exemple pour la colonne Prix, pour les 5 projets ça donne ça :

Dès que je copie les formules dans le tableau récap, et lorsqu'il se génère à nouveau, l'ensemble des formules s'effacent hormis celle des projets gagnés. J'imagine donc que tu l'as intégrée dans ton code ?

Bien à toi,
Omegan

XL 2013 MACRO : Transférer des données entre onglets

Omegan

XLDnaute Nouveau

Pièces jointes

Calvus

XLDnaute Barbatruc

Pièces jointes

Ikito

XLDnaute Occasionnel

Calvus

XLDnaute Barbatruc

Omegan

XLDnaute Nouveau

Calvus

XLDnaute Barbatruc

Calvus

XLDnaute Barbatruc

Pièces jointes

Calvus

XLDnaute Barbatruc

Pièces jointes

Calvus

XLDnaute Barbatruc

Pièces jointes

Omegan

XLDnaute Nouveau

Calvus

XLDnaute Barbatruc

Pièces jointes

Staple1600

XLDnaute Barbatruc

Omegan

XLDnaute Nouveau

Calvus

XLDnaute Barbatruc

Omegan

XLDnaute Nouveau

Discussions similaires