XL 2010 [Résolu par Bebere] Incrémenter code article selon la catégorie

[Lone-wolf]

Bonjour à toutes et à tous

Dans le classeur Base qui se trouve dans le sous-dossier, j'aimerai faire une mise à jour des codes articles selon la catégorie. Exemple du code final:

Ber-20273-20255
Ber-20274-20256
Ber-20275-20257
Bij-0110-092
Bij-0111-093
Bij-0112-094
Chc-1124-1106
Chc-1125-1107
Chc-1126-1108

Dans la feuille Ventes Catégories, j'ai déjà préparé les nouveaux codes; dans la feuille Produits, ceux-ci (les anciens codes), je les ai écrit manuellement. J'aimerais automatiser tout cela, mais la plus grosse difficulté c'est: lors de la suppréssion d'un ou plusieurs anciens articles, comment incrémenter le code pour y ajouter les nouveaux? Par exemple, si je supprime Bij-0111-093 qui se trouve entre deux codes.

D'avance, merci pour votre aide

 

[Bebere]

Lone-wolf
compare les formules,tu as mis toutes les mêmes
tu pourrais te simplifier la vie avec la colonne Id (A) et la colonne préfixe (B ou F) de ventes catégories
mettre aussi Id dans produits et tu as le préfixe directement
la macro tiens compte des ajouts et suppession,faire attention de rester grouper avec les différents préfixes(Comme maintenant)
Je n'ai pas le temps pour le moment pour en faire plus

 

[Lone-wolf]

Re Bebere

Et bien ça tombe bien (te simplifier la vie). En PJ un nouveau classeur avec ceci

Sub test()
Dim plage As Range, plg As Range, _
cel As Range, c As Range, x&
x = 0
Set plage = Feuil1.Range("e2:e226")
Set plg = Feuil2.Range("a2:a26")
For Each c In plg
For Each rw In plage
If rw.Offset(0, 0) = c.Offset(0, 0) Then
With Feuil2.Range("a2:a26")
Set cel = .Find(rw.Offset(0, 0), , xlValues)
If Not cel Is Nothing Then
x = x + 1
rw.Offset(0, -3).Value = rw.Offset(0, 0) & "-" &   _
cel.Offset(0, 2) + x  & "-" & cel.Offset(0, 3) + x
End If
End With
End If
Next rw
Next c
End Sub

 

[Lone-wolf]

Bonjour Bebere

Ne tiens pas compte de mon post (macro simplifiée), c'est tout faux. J'ai refait une mise à jour des numéros (catégories), et enlevé la formule de la colonne H en la remplaçant par le texte. C'est rentré dans l'ordre, mais pas testé lors de la suppression et rajout d'une nouvelle catégorie.

A+

 

[Bebere]

bonjour Lone-wolf
voilà un autre code
je pense que quelque part je me suis trompé ou mal réfléchi
pour ajouter/modifier cela doit il se faire dans ventes catégories et produits
je pense faire un userform


Public Sub ChangeRef1() 'avec formules en H
Dim tblVenteCategorie(), i As Long, j As Long
Dim d As Long, f As Long
tblproduit = Feuil4.Range("A2:H" & Feuil4.Range("A65536").End(xlUp).Row)
tblVenteCategorie = Feuil16.Range("F2:H" & Feuil16.Range("F65536").End(xlUp).Row)
debut = 1
For i = 1 To UBound(tblVenteCategorie)
x = Nbref(Left(tblVenteCategorie(i, 1), 3))
fin = debut + x - 1
For j = debut To fin 'tblproduit
If d = 0 Then
tblproduit(j, 2) = tblVenteCategorie(i, 1) & "-" & tblVenteCategorie(i, 2) & "-" & tblVenteCategorie(i, 3): x = x - 1
d = tblVenteCategorie(i, 2): f = tblVenteCategorie(i, 3)
Else
d = d + 1: f = f + 1
tblproduit(j, 2) = tblVenteCategorie(i, 1) & "-" & d & "-" & f: x = x - 1
End If
Next j
d = 0: f = 0: debut = fin + 1
Next i
'changer J2 en A2
Feuil4.Range("A2").Resize(UBound(tblproduit, 1), 2) = tblproduit

End Sub

Function Nbref(x As String) As Long
Dim j As Long
For j = 1 To UBound(tblproduit)
If Left(tblproduit(j, 2), 3) = x Then
Nbref = Nbref + 1
End If
Next
End Function

 

[Lone-wolf]

Bonjour Bebere

Pourquoi faire un Userform alors qu'il existe déjà Post #1 ??? . Je remets le nouveau dossier mis à jour.

J'ai aussi un souci concernant la macro SupTous dans le formulaire Articles pour supprimer toutes les catégories après sélection dans la Listview, je ne sais pas ce qui cloche, les lignes ne sont pas supprimées.

 

[Lone-wolf]

Bonsoir Bebere

Nouvelles mises à jour des fichiers.

1.- Correction de la macro de suppression des catégories
2. - Modification de la feuille Stock, remplacé les formules des colonnes H et J par une macro + ajout de la colonne Catégories.

 

[Bebere]

bonjour Lone-wolf
une suggestion concernant la listview usfarticles
d' abord sélectionner une catégorie et ensuite sélection de l'article dans la listview
qui alimente les textbox
tu aurais l'index ligne(via propriété key) de produits pour supprimer

pour moi cbmarticles est inutile

 

[Lone-wolf]

Hello Bebere

Pour la sélection de la listview, la macro y est déjà. Concernant cmbarticles, je viens de la supprimer. Merci pour le conseil.

Depuis mon dernier message, le projet a légerement progressé. J'ai créé un nouveau formulaire pour la gestion des commandes et ça avance gentiment.

A+

 

[Bebere]

Lone-wolf
changement dans code listview et bouton supprimer
ajout de option compare text
je rechercherais plutôt le code de l'article

ajout de workbooks("base").activate,j'aurais mis set WbBase=workbooks("base") en variable public
et changer activeworbook par WbBase

 

[Lone-wolf]

Bonjour Bebere

Dans le module affiche classeur, j'avait mis en variable public WbBase As Workbook et ceci

Sub Ouvrir()
Dim Chemin$, Fichier$
Chemin = ThisWorkbook.Path & "\Tables\"
Fichier = "Base.xls"
Application.WindowState = xlMinimized
Workbooks.Open (Chemin & Fichier)
'Set WbBase = Workbooks("Base.xls")
'WbBase.Windows.Application.Visible = False
UsfBDD.Show
End Sub

Je ne sais pas si j'ai bien compris. Est-ce que il faut écrire à la place Public Const WbBase As Object = "Base.xls" ??

 

[Lone-wolf]

Re

En PJ le projet modifié selon tes sujestions. Si tu as d'autres remarques, n'hésite pas.

 

[Bebere]

bonjour Lone-wolf
commentaires dans usfarticles et dans code

 

[Lone-wolf]

Bonjour Bebere

Merci pour ces nouveaux codes

 

[Lone-wolf]

Re Bebere,

Il y a un problème avec la macro de suppression. Dans Produits, elle me laisse la 2ème ligne vide, dans stock 2 lignes vides et supprime aussi une ligne différente; dans ventes catégories rien est supprimé. J'ai fait un test avec "Coussins".

En PJ, une nouvelle version.

 

[Bebere]

Lone-Wolf
je continue sur le dernier fichier envoyé
regarde la ligne set itemcmde=
pour le bouton supprimer,fait un autre code pour supprimer
si j'ai bien compris tu n'as qu'une ligne à supprimer et refaire la numéroration de A2 à X, 1 à x


Private Sub CmbCategories_Change()
Dim ItemCmde As ListItem, cel As Range, plage As Variant, i&, premaddress
On Error Resume Next
ListView1.ListItems.Clear
Set plage = WsProd.[D1].CurrentRegion
Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1)
Set cel = plage.Find(Me.CmbCategories, , , xlWhole)
If Not cel Is Nothing Then
premaddress = cel.Address
Do
Set ItemCmde = ListView1.ListItems.Add(, "A" & cel.Row, Text:=cel.Offset(0, -3))'ligne à changer pour cle
ItemCmde.SubItems(1) = cel.Offset(0, -2)
ItemCmde.SubItems(2) = cel.Offset(0, -1)
ItemCmde.SubItems(3) = cel.Offset(0, 1)
ItemCmde.SubItems(4) = Format(cel.Offset(0, 3), "0.00.-")
ListView1.ColumnHeaders(2).Width = 100
ListView1.ColumnHeaders(3).Width = 184
ListView1.ColumnHeaders(4).Width = 100
Set cel = plage.FindNext(cel)
Loop While Not cel Is Nothing And cel.Address <> premaddress
End If

End Sub

Private Sub CmdSupprimer_Click()
Dim lig&, i&, j&, k&, n&, r&, x&

If cle <> "" Then
With WsProd
.Range(cle & ":H" & Mid(cle, 2)).Delete shift:=xlUp
Call ChangeCode
End With

With WsStock
derlig = .Cells(65536, 3).End(xlUp).Row
For j = derlig To 2 Step -1
If .Cells(j, 3).Value = TextBox3.Value Then
.Range("A" & k & ":M" & k).Delete shift:=xlUp
Exit For
Next j
.Range("A2") = 1
.Range("A3") = 2
.Range("A2:A3").AutoFill .Range("A2:A" & derlig - 1)

End With

' Set WsCat = WbBase.Sheets("Categories")
' WsCat.Visible = True
With WsCat
derlig = .Cells(65536, 3).End(xlUp).Row
For k = derlig To 2 Step -1
If .Cells(k, 3).Value = TextBox3.Value Then
.Range("A" & k & ":E" & k).Delete shift:=xlUp
Exit For
End If
Next k
.Range("A2") = 1
.Range("A3") = 2
.Range("A2:A3").AutoFill .Range("A2:A" & derlig - 1)
End With

' Set WsVProd = WbBase.Sheets("Ventes Produits")
' WsVProd.Visible = True
With WsVProd
lig = .Cells(65536, 2).End(xlUp).Row
For r = lig To 2 Step -1
If .Cells(r, 2).Value = TextBox3.Value Then .Cells(r, 2).EntireRow.Delete
.Cells(r, 1).Value = .Cells(r - 1, 3).Value + 1
Next r
End With


' Set WsVCat = WbBase.Sheets("Ventes Categories")
' WsVCat.Visible = True
With WsVCat
derlig = .Cells(65536, 3).End(xlUp).Row
For x = derlig To 2 Step -1
If .Cells(x, 3).Value = CodeArticle.Value Then .Cells(x, 3).EntireRow.Delete
Next x
End With

Me.ListView1.ListItems.Remove Me.ListView1.ListItems(cle): cle = ""
For n = 2 To 7
Controls("TextBox" & n) = ""
Next n
Else
MsgBox "Votre sélection,svp"
End If

End Sub