Modification d'un code vca archiver conditionnel

Le 23/01/2021 à 23:39

Bonsoir

je veux faire une modification dans ce code vba (bon de réception il archive dans la feuille stock seulement )

je veux ajouter une condition si la cellule R5 de la feuille bon de réception "stock" il archive dans la feuille stock,si la cellule R5 de la feuille bon de réception "consommable" il doit archiver de la feuille consommable, si la cellule R5 de la feuille bon de réception "immobilisation" il doit archiver de la feuille immobilisation

merci

Sub Archiver()

Set fa = Sheets("STOCK")
Set fbr = Sheets("BON DE RECEPTION")
lgn = fa.Range("H" & Rows.Count).End(xlUp)(2).Row

If Application.CountIf(fa.Columns(1), fbr.Range("H6").Value) > 0 Then
MsgBox "existe dejà"
Exit Sub
End If

Application.ScreenUpdating = False

For i = 12 To fbr.Range("C52").End(xlUp).Row Step 2

fa.Range("A" & lgn + i / 2 - 6) = fbr.Range("H6")
fa.Range("B" & lgn + i / 2 - 6) = fbr.Range("I9")
fa.Range("C" & lgn + i / 2 - 6) = fbr.Range("N22")
fa.Range("D" & lgn + i / 2 - 6) = fbr.Range("P42")
fa.Range("E" & lgn + i / 2 - 6) = fbr.Range("M44")
fa.Range("F" & lgn + i / 2 - 6) = fbr.Range("L25")
fa.Range("G" & lgn + i / 2 - 6) = fbr.Range("L18")
fa.Range("H" & lgn + i / 2 - 6) = fbr.Range("J12")
fa.Range("O" & lgn + i / 2 - 6) = fbr.Range("L48")
fa.Range("D" & lgn + i / 2 - 6) = fbr.Range("M42")
fa.Range("I" & lgn + i / 2 - 6) = fbr.Range("A" & i) * 1
fa.Range("J" & lgn + i / 2 - 6) = fbr.Range("C" & i)
fa.Range("K" & lgn + i / 2 - 6) = fbr.Range("E" & i)
fa.Range("L" & lgn + i / 2 - 6) = fbr.Range("G" & i) * 1
fa.Range("M" & lgn + i / 2 - 6) = fbr.Range("H" & i)
fa.Range("N" & lgn + i / 2 - 6) = fbr.Range("G" & i) * fbr.Range("H" & i)

fbr.Range("A" & i) = ""
fbr.Range("C" & i) = ""
fbr.Range("E" & i) = ""
fbr.Range("G" & i) = ""
fbr.Range("H" & i) = ""

Next i
fbr.Range("j12:p12,L24:M24,P24,P25,J28:P28,J30:P30,M40:P40,M42:O42,M44:P44,L55:P55").ClearContents
For i = 1 To 6
adb = Choose(i, "I9", "N22", "P42", "L25", "L18", "L48")
fbr.Range(adb) = ""
Next i
fbr.Range("H6") = fbr.Range("H6") + 1
MsgBox "Les données ont été enregistrées."
End Sub
Le 24/01/2021 à 00:26
15bt.xlsm (57.68 Ko)
Le 24/01/2021 à 01:18

Bonjour,

Une idée en passant en attendant les pros du forum, espérant que l'onglet Bon de réception n'est qu'un test parce que c'est pas très lisible

Par contre chez moi il n'a rien archiver, ou j'ai mal tester , bon courage 

Sub Test ()

    Dim ws As Worksheet

    Select Case Range("R5")

        Case "STOCK"
        Set ws = Worksheets("STOCK")

        Case "CONSOMMABLE"
        Set ws = Worksheets("CONSOMMABLE")

        Case "IMMOBILISATION"
        Set ws = Worksheets("IMMOBILISATION")

    End Select

    '''''''''''''''''''''''''''''''''''''''''''''''''''

'    If Range("R5") = "STOCK" Then
'        Set ws = Worksheets("STOCK")

'    ElseIf Range("R5") = "CONSOMMABLE" Then
'        Set ws = Worksheets("CONSOMMABLE")

'    Else
'        Set ws = Worksheets("IMMOBILISATION")
'    End If

    ws.Range("A10") = Range("A6")

End Sub
Le 24/01/2021 à 06:15

ca marche pas

Le 24/01/2021 à 09:05

Chez moi sa marche en testant juste le code que jai.donner faites des test

Après faut l'intégrer a votre code efficacement, mais comme jai dis, votre code ne marche pas chez moi, c'est peut être pour ca que sa ne marche pas, peut être que vous devriez revoir votre code car y a des choses que je ne comprends pas

Peut être que d'autres comprendront votre code.

Le 24/01/2021 à 12:43

Bonjour,

Fournir un classeur testable. Sur un claseur vide, pas étonnant que ça ne marche pas...

Ça ne marche pas n'est pas une réponse : Que se passe -t-il ?

Rien, Le code fourni provoque u erreur ? Si oui laquelle ? Si non le résultat est partiellement atteint ou pas ?

Bref YAPA que le répondeur qui doit fatiguer : Vous avez le droit de participer aussi...

A+

Le 24/01/2021 à 13:12

Cela dit j'ai regardé rapidement,

C'est compliquer de comprendre, j'ai colorisé les cellules viser par le code et fais des test, mais sa marche chez moi, mais je trouve la feuille un peu ...

image

Consommable

image

Immobilisation

image

Stock

image

cela dit à la fin il ne colle pas toute les infos, ni ne supprime toute les infos, sa doit venir du fameu step 2 qui par d'en bas et remonter vers le haut avec le .end(xlUp), je crois car il y a des cellules fusionné un coup sur deux etc

image

J'ai pas compris le but de ce code mise a part qu'il doit supprimer les cellules, mais un coup il y en a dans la boucle i, une autre avec un enchainement de cellule et une autre boucle for i avec choose qui part du premier argument au dernier pour les supprimer

Par exemple J12:P12 est une cellule fusionné

        fbr.Range("A" & i) = ""
        fbr.Range("C" & i) = ""
        fbr.Range("E" & i) = ""
        fbr.Range("G" & i) = ""
        fbr.Range("H" & i) = ""
'
    Next i

'    fbr.Range("j12:p12,L24:M24,P24,P25,J28:P28,J30:P30,M40:P40,M42:O42,M44:P44,L55:P55").ClearContents

    For i = 1 To 6

        adb = Choose(i, "I9", "N22", "P42", "L25", "L18", "L48")
        fbr.Range(adb) = ""

    Next i

Si les pros pouvaient nous éclairer

Le 24/01/2021 à 21:28

Bonjour,

La suite du sujet est ici :

https://forum.excel-pratique.com/excel/archiver-des-donnees-conditionne-151982#p938410

A+

Le 24/01/2021 à 21:57

Je vois ça, c'est sympa c'est le premier fichier que j'ai ouvert en me levant ce matin alors j'ai des projets VBA en cours pour ma boite

Au moins le nouveau fichier du nouveau sujet a des couleur lui et moins de fusion de cellule foireuse

Pourtant c'est pas compliquer Akssel le select case ou la condition if fonctionne il suffit juste de remplacer ton set = fa bidule par le code et de modifier ws = du code par ton fa =

Peut être que quelqu'un d'autres aura de meilleur conseil de pro ;)

Rechercher des sujets similaires à "modification code vca archiver conditionnel"