Générer un tableau selon la saisie
Bonjour à tous, Banzaï64,
Si vous pouvez jeter un coup d'oeil
J'explique ce que je cherche à faire.
Première étape:
Je saisie le Nombre de site web cela me génèrera le nombre de ligne pour le tableau Site web.
Deuxièmes étapes:
je saisie le tableau et à chaque fois je saisie un nombre dans la colonne Nombre de Mangas , fait la somme automatique et génère le nombre de ligne pour le tableau Mangas téléchargé et partagé
Troisièmes étapes:
Quand il saisit le Nom site web, le N°Site web et le Nombre de Mangas, je récupère ces informations pour les remettre dans le tableau Mangas téléchargé et partagé, dans les colonnes correspondant ,et dans le même ordre que le tableau Site web. Cela incrémente automatiquement le N°Mangas.
Quatrièmes étapes:
Je vérifie dans le tableau mangas télécharger et partager , dans la colonne Download la somme du groupe de cellule fusionné qui correspond au nom du site web si cela correspond au Total download saisi dans le tableau Site web. Mais aussi, que le total de la colonne Download correspond bien au total de la colonne total Download si il y a moins ou plus le prévenir d'un message lui disant qu'il a soit un plus ou moins.
En gros ce qu'il doit faire.
Des conditions:
Si au cours de la saisie;
Il augmente le nombre de site web ou diminue cela doit automatiquement modifie le nombre de ligne du tableau site web, mais si il diminue alors qu'il a saisi des champs dans les dernière lignes le prévenir d'une message d'alerte qu'il va supprime la ligne "ce qu'il a saisit avec les entêtes de colonne".
Si il quitte l'onglet ou Excel, et lui reste des lignes vide à saisir, lui alerter qu'il lui reste des lignes si il ferme Excel enregistrer, mais si il change d'onglet supprimer les lignes vides en lui disant si il souhaite qu'on supprime les lignes vides dans le tableau site web et le nombre de site web change au changement d'onglet.
Je suis en train de le faire j'ai juste besoin d'aide surtout de méthodes car je ne connais pas tout en VBA, je suis programmeur. Donc, dites moi si mon code n'est pas optimisé ou c'est pas la peine de faire.
Je mettrai la MAJ du fichiers au fur et à mesures que j'avance.
Et le code commenté.
bonjour à tous,
Alors j'ai utilisé le code que Banzaï64 m'avait optimisé, dans un de mes post Copier et coller des cellules fusionnées!!!!
voici le code il permet de générer le tableau et dès qu'on saisie le nombre de site web puis il arrête de copier.
Gros soucis normalement si j'augmente le nombre de cellule sa augmente le nombre de ligne mais sa ne le fait.
Aussi je ne sais pas comment faire qu'entre les deux tableau il y a toujours un écart de trois lignes entre la dernière ligne du tableau site web et la première ligne du tableau Mangas
'variable
Dim NbS As Long, Save As Long
Dim PreLg As Long, DerCl As Long, PreCl As Long
Dim PreLg1 As Long, DerCl1 As Long, DerLg1 As Long
Dim CptLg As Long
Dim Fini As Boolean
'initialisation
Fini = False
NbS = Range("E8")
PreLg = 13 'première ligne pour le tableau site web
DerCl = 7 'dernière ligne pour le tableau site web
PreCl = 4 'première colonne pour le tableau site web
' PreLg1 = 16 'première ligne pour le deuxième tableau
' DerLg1 = 20 'dernière ligne pour le deuxième tableau
' DerCl1 = 12 'dernière colonne pour le deuxième tableau
Save = NbS 'sauvegarde la valeur
' MsgBox NbS
Dim Mondico As Object
If NbS = Range("E8") Then
Do While Fini = False And CptLg < NbS
If CptLg < NbS Then
For CptLg = 1 To NbS
' MsgBox CptLg
'si il y a rien je copie les lignes demandé sinon je laisse la saisie
If Intersect(Range(Cells(PreLg + CptLg, PreCl), Cells(PreLg + CptLg, DerCl)), Target) Is Nothing Then
'tous les événements sont désactivé
Application.EnableEvents = False
Set Mondico = CreateObject("Scripting.Dictionary")
If Cells(CptLg, Target.Column) <> "" Then
Mondico(Cells(CptLg, Target.Column).Value) = ""
End If
' je copie la ligne
Range("D13:G13").Copy Range(Cells(PreLg + CptLg, PreCl), Cells(PreLg + CptLg, DerCl))
End If
'jincrémente CptLg
Next CptLg
Else
'je sors de la condition et j'arrête la copie
Fini = True
End If
Loop
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''Si le Nombre de Site web diminue j'efface les lignes en trop''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ElseIf Range("E8") < NbS Then
'' msgbox save
' If Not Intersect(Range(Cells(PreLg + CptLg, PreCl), Cells(PreLg + CptLg, DerCl)), Target) Is Nothing Then
' Application.EnableEvents = False
' Set Mondico = CreateObject("Scripting.Dictionary")
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''lors de la suppresion de ligne si il y a une saisie dans une ligne message d'alerte''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If Cells(CptLg, Target.Column) <> "" Then
' msgbox" voulez vous supprimer la ligne"
' End If
' End If
End IfLà je m'attaque, si le nombre de site web diminue ou augmente.
Si une personne peut dire, si je suis dans le bon chemin
merci à vous
Bonjour à tous
j'ai pu enfin générer le tableau selon la saisi je vous envoie le code et le fichier joint:
j'aimerais qu'une personne l'optimise car c'est long et répétitifs en utilisant une fonction.
voici le code
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'variable
Dim Nbs As Long, IDerLg As Long
Dim PreLg As Long, DerCl As Long, PreCl As Long
Dim PreLg1 As Long, DerCl1 As Long, DerLg1 As Long, PreCl1 As Long
Dim Res As Long
Dim CptLg As Long, CptCl As Long, Cpt As Long, CptAdd As Long, CptSom As Long
Dim Fini As Boolean, Start As Boolean, Somme As Boolean
Dim Total As Long, NbMangas As Long
Dim NbParc As Long
Dim CptVal As Long, CptR As Long, CptIncrParc As Long
Dim IncrParc As Long
Dim PrcdVal As Long, Avc As Long, u As Long
Dim NbSe As Integer, NbSau As Integer, NbPe As Integer
Dim Chaine As String
Dim Num As Long
Dim Nbre As Long, Index As Long
'initialisation
Total = 0
NbMangas = 0
CptLg = 0
CptCl = 0
Cpt = 0
CptSom = 13
CptAdd = 0
Nbs = Range("E8")
PreLg = 13 'première ligne pour le tableau site web
DerCl = 7 'dernière ligne pour le tableau site web
PreCl = 4 'première colonne pour le tableau site web
PreLg1 = 14 'première ligne pour le tableau site web
DerCl1 = 18 'dernière ligne pour le tableau site web
PreCl1 = 9 'première colonne pour le tableau site web
'récupère la dernnière ligne du tableau site web
For Cpt = PreLg To PreLg + Nbs
If Cells(Cpt, DerCl) = O Then
Cells(Cpt, DerCl) = ""
End If
Next
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Condition pour sommer automatiquement'''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Range("D8") <> "" Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''condition'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'si modification du nombre en cours de route
If Nbs <> Range("M8") Then
IDerLg = Cells(Rows.Count, PreCl).End(xlUp).Row
If IDerLg < PreLg Then
IDerLg = PreLg
End If
Res = PreLg + Nbs - IDerLg
If Res < 0 Then
IDerLg = Cells(Rows.Count, 4).End(xlUp).Row
'suppresion de ligne
Cells(IDerLg, PreCl).UnMerge
Range(Cells(IDerLg + Res, PreCl), Cells(IDerLg, DerCl)).Clear
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'reconstruction su tableau et de ligne total
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Range(ActiveSheet.Cells(PreLg, PreCl), ActiveSheet.Cells(PreLg + Nbs, DerCl))
.Interior.ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 1
.Borders(xlEdgeLeft).ColorIndex = 1
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 1
.Borders(xlInsideHorizontal).Weight = xlThin
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'dernière ligne les totaux
Cells(PreLg + Nbs, PreCl) = "Total"
'Fusionne les cellules
Range(Cells(PreLg + Nbs, PreCl), Cells(PreLg + Nbs, DerCl - 2)).Merge
IDerLg = Cells(Rows.Count, 4).End(xlUp).Row
'j'affecte la somme
Cells(IDerLg, DerCl - 1) = Total
Cells(IDerLg, DerCl) = NbMangas
With Range(ActiveSheet.Cells(PreLg + Nbs, PreCl), ActiveSheet.Cells(PreLg + Nbs, DerCl))
.Interior.ColorIndex = 8
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 1
.Borders(xlEdgeLeft).ColorIndex = 1
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 1
.Borders(xlInsideHorizontal).Weight = xlThin
End With
Else
'ajout de ligne
Cells(IDerLg, PreCl).UnMerge
Range(Cells(PreLg + Nbs, PreCl), Cells(IDerLg, DerCl)).Clear
With Range(ActiveSheet.Cells(PreLg, PreCl), ActiveSheet.Cells(PreLg + Nbs, DerCl))
.Interior.ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
End If
End If
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Somme'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'initialisation des variables
IDerLg = Cells(Rows.Count, 4).End(xlUp).Row
Somme = True
CptSom = PreLg
'tant que somme est vrai ert que CptSom est inférieur à la dernière ligne
Do While Somme = True And CptSom < IDerLg
Total = Total + Cells(CptSom, DerCl - 1)
NbMangas = NbMangas + Cells(CptSom, DerCl)
CptSom = CptSom + 1
Loop
'
Somme = False
'J'affecte les sommes aux totaux
Cells(PreLg + Nbs, DerCl - 1) = Total
Cells(PreLg + Nbs, DerCl) = NbMangas
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''saisi du nombre de ligne''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Nbs <> 0 Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''construction du tableau'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Range(ActiveSheet.Cells(PreLg, PreCl), ActiveSheet.Cells(PreLg + Nbs, DerCl))
.Interior.ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Ligne total'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' dernière ligne les totaux
Cells(PreLg + Nbs, PreCl) = "Total"
'Fusionne les cellules
Range(Cells(PreLg + Nbs, PreCl), Cells(PreLg + Nbs, DerCl - 2)).Merge
'j'affecte la somme
Cells(PreLg + Nbs, DerCl - 1) = Total
Cells(PreLg + Nbs, DerCl) = NbMangas
With Range(ActiveSheet.Cells(PreLg + Nbs, PreCl), ActiveSheet.Cells(PreLg + Nbs, DerCl))
.Interior.ColorIndex = 8
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
IDerLg = Cells(Rows.Count, PreCl).End(xlUp).Row
NbParc = Cells(IDerLg, DerCl)
End If
Range("M8") = Nbs
'
' NbParc = Cells(IDerLg, DerCl)
IDerLg = Cells(Rows.Count, PreCl1).End(xlUp).Row
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''construction du tableau parcelles'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''récupération de nom N° et incrémention des parcelles'''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Index = 0
' IDerLg = Cells(Rows.Count, PreCl).End(xlUp).Row
' For CptR = PreLg To IDerLg - 1
' Chaine = Cells(CptR, PreCl)
' Num = Cells(CptR, PreCl + 1)
' Nbre = Cells(CptR, DerCl)
' For CptIncrParc = 0 To Nbre - 1
'
' Cells(PreLg1 + Index + CptIncrParc, PreCl1) = Chaine
' Cells(PreLg1 + Index + CptIncrParc, PreCl1 + 1) = Num
' Cells(PreLg1 + Index + CptIncrParc, PreCl1 + 2) = Num & " - " & CptIncrParc + 1
' If Index = Nbre Then
' For u = 1 To nombre
' Cells(PreLg1 + Nbre + u, PreCl1) = Chaine
' Cells(PreLg1 + Nbre + u, PreCl1 + 1) = Num
' Cells(PreLg1 + Nbre + u, PreCl1 + 2) = Num & " - " & u
' Next
' End If
' Next
' Index = Nbre + Index
' Next
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Condition pour sommer automatiquement'''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Cells(IDerLg, PreCl1) <> "" Then
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''condition'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'si modification du nombre en cours de route
If NbParc <> Range("N8") Then
Res = PreLg1 + NbParc - IDerLg
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''ajout et suppresion de ligne'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
If Res < 0 Then
IDerLg = Cells(Rows.Count, PreCl1).End(xlUp).Row
'suppresion de ligne
Cells(IDerLg, PreCl1).UnMerge
Range(Cells(IDerLg + Res, PreCl1), Cells(IDerLg, DerCl1)).Clear
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 'reconstruction su tableau et de ligne total
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Quadrillage
'tableau de récuparation
With Range(ActiveSheet.Cells(PreLg1, PreCl1), ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 2))
.Interior.ColorIndex = 37
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 1
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
'tableau de saisi
With Range(ActiveSheet.Cells(PreLg1, PreCl1 + 3), ActiveSheet.Cells(PreLg1 + NbParc - 1, DerCl1))
.Interior.ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 1
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Ligne total'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'dernière ligne les totaux
Cells(PreLg1 + NbParc, PreCl1) = "Total"
'Fusionne les cellules
Range(Cells(PreLg1 + NbParc, PreCl1), Cells(PreLg1 + NbParc, PreCl1 + 2)).Merge
'j'affecte la somme
Cells(PreLg1 + NbParc, PreCl1 + 3) = NbSau
Cells(PreLg1 + NbParc, PreCl1 + 4) = NbSe
Cells(PreLg1 + NbParc, PreCl1 + 5) = NbPe
With Range(ActiveSheet.Cells(PreLg1 + NbParc, PreCl1), ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 2))
.Interior.ColorIndex = 8
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
With Range(ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 3), ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 5))
.Interior.ColorIndex = 6
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
IDerLg = Cells(Rows.Count, PreCl1).End(xlUp).Row
Range(Cells(PreLg1 + NbParc, PreCl1 + 6), Cells(IDerLg, DerCl1)).Clear
Else
IDerLg = Cells(Rows.Count, PreCl1).End(xlUp).Row
'ajout de ligne
Cells(IDerLg, PreCl1).UnMerge
Range(Cells(PreLg1 + Range("N8").Value, PreCl1), Cells(IDerLg, DerCl1)).Clear
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''reconstruction du tableau parcelles'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Quadrillage
'tableau de récuparation
With Range(ActiveSheet.Cells(PreLg1, PreCl1), ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 2))
.Interior.ColorIndex = 37
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 1
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
'tableau de saisi
With Range(ActiveSheet.Cells(PreLg1, PreCl1 + 3), ActiveSheet.Cells(PreLg1 + NbParc - 1, DerCl1))
.Interior.ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 1
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
End If
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Ligne total'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'dernière ligne les totaux
Cells(PreLg1 + NbParc, PreCl1) = "Total"
'Fusionne les cellules
Range(Cells(PreLg1 + NbParc, PreCl1), Cells(PreLg1 + NbParc, PreCl1 + 2)).Merge
'J 'affecte la somme
Cells(PreLg1 + NbParc, PreCl1 + 3) = NbSau
Cells(PreLg1 + NbParc, PreCl1 + 4) = NbSe
Cells(PreLg1 + NbParc, PreCl1 + 5) = NbPe
With Range(ActiveSheet.Cells(PreLg1 + NbParc, PreCl1), ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 2))
.Interior.ColorIndex = 8
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
With Range(ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 3), ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 5))
.Interior.ColorIndex = 6
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
Range(Cells(PreLg1 + NbParc, PreCl1 + 6), Cells(PreLg1 + NbParc, DerCl1)).Clear
' Else
' 'ajout de ligne
' Cells(IDerLg, PreCl1).UnMerge
' Range(Cells(PreLg1 + Range("N8").Value, PreCl1), Cells(IDerLg - Res, DerCl1)).Clear
''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Somme'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'initialisation des variables
IDerLg = Cells(Rows.Count, PreCl1).End(xlUp).Row
Somme = True
CptSom = PreLg1
'tant que somme est vrai ert que CptSom est inférieur à la dernière ligne
Do While Somme = True And CptSom < IDerLg
NbSau = NbSau + Cells(CptSom, PreCl1 + 3)
NbSe = NbSe + Cells(CptSom, PreCl1 + 4)
NbPe = NbPe + Cells(CptSom, PreCl1 + 5)
CptSom = CptSom + 1
Loop
'
Somme = False
'J'affecte les sommes aux totaux
'J 'affecte la somme
Cells(PreLg1 + NbParc, PreCl1 + 3) = NbSau
Cells(PreLg1 + NbParc, PreCl1 + 4) = NbSe
Cells(PreLg1 + NbParc, PreCl1 + 5) = NbPe
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''saisi du nombre de ligne''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End If
If NbParc <> 0 Then
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''construction du tableau'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Quadrillage
'tableau de récuparation
With Range(ActiveSheet.Cells(PreLg1, PreCl1), ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 2))
.Interior.ColorIndex = 37
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 1
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
'tableau de saisi
With Range(ActiveSheet.Cells(PreLg1, PreCl1 + 3), ActiveSheet.Cells(PreLg1 + NbParc - 1, DerCl1))
.Interior.ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 1
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Ligne total'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' dernière ligne les totaux
Cells(PreLg1 + NbParc, PreCl1) = "Total"
'Fusionne les cellules
Range(Cells(PreLg1 + NbParc, PreCl1), Cells(PreLg1 + NbParc, PreCl1 + 2)).Merge
'J 'affecte la somme
Cells(PreLg1 + NbParc, PreCl1 + 3) = NbSau
Cells(PreLg1 + NbParc, PreCl1 + 4) = NbSe
Cells(PreLg1 + NbParc, PreCl1 + 5) = NbPe
With Range(ActiveSheet.Cells(PreLg1 + NbParc, PreCl1), ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 2))
.Interior.ColorIndex = 8
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
With Range(ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 3), ActiveSheet.Cells(PreLg1 + NbParc, PreCl1 + 5))
.Interior.ColorIndex = 6
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeRight).ColorIndex = 3
.Borders(xlEdgeLeft).ColorIndex = 3
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideVertical).ColorIndex = 3
.Borders(xlInsideHorizontal).Weight = xlThin
End With
Range(Cells(PreLg1 + NbParc, PreCl1 + 6), Cells(PreLg1 + NbParc, DerCl1)).Clear
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''récupération de nom N° et incrémention des parcelles'''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Index = 0
IDerLg = Cells(Rows.Count, PreCl).End(xlUp).Row
For CptR = PreLg To IDerLg - 1
Chaine = Cells(CptR, PreCl)
Num = Cells(CptR, PreCl + 1)
Nbre = Cells(CptR, DerCl)
For CptIncrParc = 0 To Nbre - 1
Cells(PreLg1 + Index + CptIncrParc, PreCl1) = Chaine
Cells(PreLg1 + Index + CptIncrParc, PreCl1 + 1) = Num
Cells(PreLg1 + Index + CptIncrParc, PreCl1 + 2) = Num & " - " & CptIncrParc + 1
If Index = Nbre Then
For u = 1 To nombre
Cells(PreLg1 + Nbre + u, PreCl1) = Chaine
Cells(PreLg1 + Nbre + u, PreCl1 + 1) = Num
Cells(PreLg1 + Nbre + u, PreCl1 + 2) = Num & " - " & u
Next
End If
Next
Index = Nbre + Index
Next
End If
Range("N8") = NbParc
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Subcomme vous pouvez le voir c'est long comme programme pour ajouter de simple ligne
Bonjour à tous,
il m'a fallut du temps pour j'obtiens ce que je souhaite par même:
Merci au visiteur d'avoir essayé de lire mon problème je vous joints le fichier.
il faut regarder dans le module pour les fonctions.
Je trouve encore le code indigeste.
il me reste à faire les tests de bases suppression de valeur additions
j'ai ouvert un autre poste pour un problème d'addition.
si une personne souhaite bien me dire si j'ai bien fait ou pas merci besoin de votre avis pour l'améliorer
cordialement