XL 2013 Importation d'un classeur fermé et classement

an@s · 3 Mars 2018

Bonsoir à tous,
après une petite absence je reviens vers vous pour solliciter votre aide concernant ma problématique que je vous expliquerai ci-après :
j'ai deux classeurs inventaires & Gestion de stock
je cherche un créer un code et le lier au bouton de l'onglet BD ARTICLES qui fait les rôles suivants :

importer les données des colonnes B, C, D, E à partir de la ligne 24 de l'onglet INV du fichier Inventaires et les mettre dans les colonnes B, C, D, E à partir de la ligne 7 de l'onglet BD ARTICLES du fichier Gestion de stock
importer les données des colonnes B, F, H à partir de la ligne 24 de l'onglet INV du fichier Inventaires et les mettre dans les colonnes B, D, E à partir de la ligne 7 de l'onglet ETAT DES STOCKS du fichier Gestion de stock
dans la colonne A de l'onglet BD ARTICLES du fichier Gestion de stock j'aimerai avoir les deux premières lettre de la colonne B + les deux premières lettres de la colonne C et un tiret et le numéro de claseement qui sera comme ça en 0001. si on prend l'exemple de la cellule A7 on aura COCL-0001 c'est à dire deux lettres de B7 + deux lettres de C7 plus un tiret et le numéro de classement, une fois on a une nouvelle famille dans la colonne B le classement commence dès le début.
on copie les données de la colonne A de l'onglet BD ARTICLES dans la colonne A de l'onglet ETAT de stock à partir de la ligne 7

NB: pour la colonne H du fichier Inventaire il faut importer la valeur et non pas la formule

je vous remercie par avance

Amicalement
An@s

Lone-wolf · 3 Mars 2018

Bonjour An@s

Je travail dessus, il y a juste un problème avec une boucle et j'ai demandé de l'aide.

Lone-wolf · 3 Mars 2018

Re

La macro est à mettre dans un module du classeur Gestions des stocks. Mais avant il faut l'enregistrer sous Classeur Excel prenant en charge les macros. Défusionne aussi les premières cellules, c'est inutile; il y a assez de place dans la colonne D de la feuille "BD ARTICLES".

VB:

Option Explicit
Public derlig As Long

Sub Importer()
Dim wkSource As Workbook, wkDest As Workbook, ShA As Worksheet, ShB As Worksheet
Dim shC As Worksheet, Fichier As String

    Application.ScreenUpdating = False

    Fichier = ThisWorkbook.Path & "\INVENTAIRES.xlsx"

    Set wkSource = Workbooks.Open(Fichier)
    Set wkDest = ThisWorkbook
    Set ShA = ActiveWorkbook.Sheets("INV")
    Set ShB = wkDest.Sheets("BD ARTICLES")
    Set shC = wkDest.Sheets(3)


    derlig = shC.Range("f" & Rows.Count).End(xlUp).Row


    With ShA
        derlig = .Range("b" & Rows.Count).End(xlUp).Row
        .Range("b24:e" & derlig).Copy ShB.Range("b7")
        .Range("b24:b" & derlig).Copy shC.Range("b7")
        .Range("f24:f" & derlig).Copy shC.Range("d7")
        .Range("h24:h" & derlig).Copy shC.Range("e7")
    End With
    ActiveWorkbook.Close False




  With ShB
          derlig = .Range("b" & Rows.Count).End(xlUp).Row
          .Range(.Cells(7, "A"), .Cells(derlig, "A")).FormulaR1C1 = "=LEFT(RC[1],2)&LEFT(RC[2],2)&""-000"" &ROW()-6"
          .Range(.Cells(7, "A"), .Cells(derlig, "A")).Value = .Range(Cells(7, "A"), .Cells(derlig, "A")).Value
          If IsEmpty(.Range("b7:b" & derlig)) Then .Range("a7:a" & derlig).ClearContents
          .Range("a7:a" & derlig).Copy shC.Range("a7")
          Application.Goto .Range("a6")
  End With



    Application.DisplayAlerts = False
    ThisWorkbook.Save
End Sub

an@s · 3 Mars 2018

Bonjour Lone-Wolf,
merci beaucoup pour votre réponse
mais j'ai des remarques à modifier si c'est possible :

pour le 3ème point concernant les deux premières lettre: pour le première famille c'est COCL-0001 jusqu'a COCL-0016 par contre la 2ème famille ça doit être COVE-0001 et non pas COVE-0017 puis ELAC-0001 et non pas ELAC-0018... il faut commencer dès le début pour chaque nouveau dans la colonne A...ensuite les lettres doivent être toutes majiscule
après importation je veux que la dernière ligne du tableau ait une bordure ligne continue que ce soit le tableau des onglet BD ARTICLES & ETAT DES STOCKS
pour la colonne H du fichier inventaire il faut importer la valeur et non pas la formule

Cordialement

Lone-wolf · 4 Mars 2018

Bonsoir an@s

Désolé, là c'est un peu compliqué pour moi.

En ce qui concerne la colonne H

With ShA
derlig = .Range("b" & Rows.Count).End(xlUp).Row
.Range("b24:e" & derlig).Copy ShB.Range("b7")
.Range("b24:b" & derlig).Copy shC.Range("b7")
.Range("f24:f" & derlig).Copy shC.Range("d7")
.Range("h24:h" & derlig).Copy shC.Range("e7")
End With
Après le End With de ShA, ajoute ceci: shC.Range("e7:e" & derlig).Value = shC.Range("e7:e" & derlig).Value

an@s · 4 Mars 2018

Bonsoir Lone-wolf
j'ai rien compris dans votre 2ème code
j'ai eu un autre problème, le premier code ne marche pas sur un autre pc...

Cordialement
An@s

an@s · 4 Mars 2018

Bonjour à tous,
aidez moi s'il vous plait

Lone-wolf · 4 Mars 2018

Bonjour an@s

Voici le code au complet. La macro "Codes" est de Chti160 et permet pour chaque famille de commencer la numérotation à 1.

VB:

Option Explicit
Public derlig As Long

Sub Importer()
Dim wkSource As Workbook, wkDest As Workbook, ShA As Worksheet, ShB As Worksheet
Dim shC As Worksheet, Fichier As String

    Application.ScreenUpdating = False

    Fichier = ThisWorkbook.Path & "\INVENTAIRES.xlsx"

    Set wkSource = Workbooks.Open(Fichier)
    Set wkDest = ThisWorkbook
    Set ShA = ActiveWorkbook.Sheets("INV")
    Set ShB = wkDest.Sheets("BD ARTICLES")
    Set shC = wkDest.Sheets(3)


    derlig = shC.Range("f" & Rows.Count).End(xlUp).Row


    With ShA
        derlig = .Range("b" & Rows.Count).End(xlUp).Row
        .Range("b24:e" & derlig).Copy ShB.Range("b7")
        .Range("b24:b" & derlig).Copy shC.Range("b7")
        .Range("f24:f" & derlig).Copy shC.Range("d7")
        .Range("h24:h" & derlig).Copy shC.Range("e7")
    End With
    shC.Range("e7:e" & derlig).Value = shC.Range("e7:e" & derlig).Value

    ActiveWorkbook.Close False

    Call Codes

    Application.DisplayAlerts = False
    ThisWorkbook.Save
End Sub

Public Sub Codes()
Dim tbl As Range, ShB As Worksheet
Set Coll_Str = New Collection


Set ShB = Sheets("BD ARTICLES")

With ShB
DerLgn = .Cells(.Rows.Count, 2).End(xlUp).Row
DerCol = .Cells(6, .Columns.Count).End(xlToLeft).Column
Tablo = .Range(.Cells(7, 1), .Cells(DerLgn, DerCol)).Value
ReDim Tab_Ref(UBound(Tablo, 1), 1)
On Error Resume Next
For L = 1 To UBound(Tablo, 1)
Str_Search = IIf(Tablo(L, 3) <> "", Left(Tablo(L, 2), 2) & Left(Tablo(L, 3), 2), "")
    Coll_Str.Add Str_Search, CStr(Str_Search)
If Err.Number = 0 Then
x = 1
For LL = 1 To UBound(Tablo, 1)
   Str_Compare = Left(Tablo(LL, 2), 2) & Left(Tablo(LL, 3), 2)
   If Str_Compare Like Str_Search Then
      Tab_Ref(LL, 1) = Str_Compare & Format(x, "-0000")
        x = x + 1
   End If
Next LL
End If
Err.Clear
Next L
      .Range("A7").Resize(UBound(Tab_Ref, 1), 1) = Tab_Ref
End With
Set Tablo = Nothing: Set Coll_Str = Nothing
End Sub

an@s · 4 Mars 2018

Bonjour Lone-Wolf,
le code bug sur cette ligne :

Set Coll_Str = New Collection

Lone-wolf · 4 Mars 2018

Re

Je suis entrain de corriger le problème, un peu de patience.

ChTi160 · 4 Mars 2018

Re
As tu déclaré les variables ?
j'avais mis ceux ci , un Module Standard.

VB:

Option Explicit
Option Base 1
Dim Tablo As Variant
Dim Tab_Ref() As Variant
Dim DerLgn As Long
Dim DerCol As Byte
Dim I As Long
Dim L As Long
Dim LL As Long
Dim x As Long
Dim Coll_Str As Collection
Dim Str_Search As String
Dim Str_Compare As String

Public Sub Test()

Set Coll_Str = New Collection
I = 1
With Worksheets("Feuil1")
DerLgn = .Cells(.Rows.Count, 2).End(xlUp).Row 'on definit la derniere ligne non vide de la plage de  donnees a partir de la colonne "B"
DerCol = .Cells(6, .Columns.Count).End(xlToLeft).Column 'on definit la derniere Colonne non vide de la plage de  donnees a partir de la Ligne "6"
 Tablo = .Range(.Cells(7, 1), .Cells(DerLgn, DerCol)).Value 'on récupére les donnees de la plage ainsi définie
ReDim Tab_Ref(UBound(Tablo, 1), 1) 'on rédimensionne le tableau des Références x Lignes , Une Colonne
On Error Resume Next 'gestion des erreurs eventuelles
For L = I To UBound(Tablo, 1) 'pour chaque ligne du tableau des donnees
 Str_Search = IIf(Tablo(L, 3) <> "", Left(Tablo(L, 2), 2) & Left(Tablo(L, 3), 2), "") 'on récupére si la Colonne 3 n'est pas vide les deux premiers caracteres des Colonne "B"(2) et "C"(3)
    Coll_Str.Add Str_Search, CStr(Str_Search) 'on entre la variable ainsi définie dans la Collection des références
 If Err.Number = 0 Then 'Si réference Non encore référencée
        x = 1 'on incremente la variable
 For LL = I To UBound(Tablo, 1)  'puis pour chaque ligne du tableau
   Str_Compare = Left(Tablo(LL, 2), 2) & Left(Tablo(LL, 3), 2) 'on va récupérer les deux premiers caracteres des Colonne "B"(2) et "C"(3)
   If Str_Compare Like Str_Search Then 'on compare les deux variables si Ok
      Tab_Ref(LL, 1) = Str_Compare & Format(x, "-0000") 'Récupére dans le tableau des références la Variable formatee
        x = x + 1: I = I + 1: L = I  'on incremente les Variables
   End If
 Next LL
 End If
Err.Clear 'on efface l'erreur eventuelle
Next L
      .Range("A7").Resize(UBound(Tab_Ref, 1), 1) = Tab_Ref 'on colle dans la premiere colonne le tableau des références
End With
Set Tablo = Nothing: Set Coll_Str = Nothing 'on vide les variables
End Sub

jean marie

Lone-wolf · 4 Mars 2018

Re

Voilà c'est fait. Très bon dimanche.

ChTi160 · 4 Mars 2018

Re
pour ce qui est des majuscules si j'ai bien compris
mettre :

VB:

Str_Compare =Ucase( Left(Tablo(LL, 2), 2) & Left(Tablo(LL, 3), 2)

au lieu de

VB:

Str_Compare = Left(Tablo(LL, 2), 2) & Left(Tablo(LL, 3), 2)

je vais revoir le fichier car j'en étais resté au premier
jean marie

Lone-wolf · 4 Mars 2018

Re

jean marie c'est à cette ligne qu'il faut mettre UCase: Tab_Ref(LL, 1) = UCase(Str_Compare) & Format(x, "-0000"), sinon la colonne est éffacée.

Lone-wolf · 4 Mars 2018

Re

@an@s: pour la bordure de fin ajoute ces lignes en rouge, mais avant il faut écrire

Dim plage As Range - à ajouter aux autres variables

Next L
.Range("A7").Resize(UBound(Tab_Ref, 1), 1) = Tab_Ref

Set plage = .Range("a" & DerLgn, .Range("f" & DerLgn))
End With

With plage.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
Set Tablo = Nothing: Set Coll_Str = Nothing

Effectuez une recherche sur Excel Downloads...

XL 2013 Importation d'un classeur fermé et classement

an@s

XLDnaute Occasionnel

Pièces jointes

Lone-wolf

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

an@s

XLDnaute Occasionnel

Lone-wolf

XLDnaute Barbatruc

an@s

XLDnaute Occasionnel

an@s

XLDnaute Occasionnel

Lone-wolf

XLDnaute Barbatruc

an@s

XLDnaute Occasionnel

Lone-wolf

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

Pièces jointes

ChTi160

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

Lone-wolf

XLDnaute Barbatruc

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums