Extraction données sous conditions

Version imprimable

25/05/2019, 16h02
dudesson

1 pièce(s) jointe(s)

Extraction données sous conditions

bonjour le forum,
bonjour à tous,
j'ai une demande un peu compliquée (je m'en excuse d'avance) que j'aimerais soumettre à votre expertise.
dans l'exemple joint, j'ai un fichier ( feuille 1) importée de façon brute dont je souhaite exploiter les données en colonnes I et J via un code VBA.
il y a les ENTREES, les SORTIES et des quantités mouvementées à l'intérieur d'une chaîne de caractères: exemple en J4 de la feuille 1 il est renseigné une sortie de 24300 et une reférence = 1908356 (toujours à 7 chiffres) et la date de ce mouvement en colonne I.
est-il possible via un bouton en feuille 2 d'avoir, en ayant choisi au préalable la date de début et la date de fin (la date de fin peut être égale ou supérieure à la date de début) =
sorties
- à partir de A2 de la feuille 2 = la liste des références (7 chiffres)
- à partir de B2 de la feuille 2 = le liste des quantités (juste après "SORTIE" à l'intérieur de la parenthèse)
entrées
- à partir de D2 de la feuille 2 = la liste des 6 caractères (ex en J10 = 22/05A)
- à partir de E2 de la feuille 2 = la liste des quantités (juste après "ENTREE" à l'intérieur de la parenthèse)
j'espère avoir été clair dans mes explications.
merci d'avance pour votre aide.
Pedro.

1 pièce(s) jointe(s)

Bonjour,

Une façon de faire:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Option Explicit
 
Sub ListerES()
    Dim D As Date, D1 As Date, D2 As Date, mD As String
    Dim wSh1 As Worksheet, wSh2 As Worksheet
    Dim kR1 As Long, kR2 As Long
    Dim kS As Long, kE As Long
    If Cells(2, 1) & Cells(2, 4) <> "" Then
        MsgBox "Commencer par vider cette feuille de ses données !", _
                vbExclamation, "Opération annulée"
        Exit Sub
    End If
    Set wSh1 = Worksheets("Feuil1")
    Set wSh2 = Worksheets("Feuil2")
    kR1 = 4             '--- n° première ligne feuille 1
    kR2 = 2             '--- n° première ligne feuille 2
    wSh2.Select
    D1 = Range("H1")    '--- date1
    D2 = Range("J1")    '--- date2
    With wSh1
        While .Cells(kR1, 9) <> ""
            D = .Cells(kR1, 9)
            If D >= D1 And D <= D2 Then
                mD = .Cells(kR1, 10)            '--- mouvement à la date D
                kS = InStr(mD, "(SORTIE")
                kE = InStr(mD, "(ENTREE")
                If kS > 0 Then
                    Cells(kR2, 2) = Mid(mD, kS + 8, Len(mD) - kS - 8)
                    Cells(kR2, 3) = D
                    '--- extraire référence Sortie
                    mD = Replace(mD, "NC ", "") '--- retire le NC éventuel
                    Cells(kR2, 1) = Val(mD)     '--- prend le nombre
                    kR2 = kR2 + 1
                ElseIf kE > 0 Then
                    Cells(kR2, 5) = Mid(mD, kE + 8, Len(mD) - kE - 8)
                    Cells(kR2, 6) = D
                    '--- extraire référence Entrée
                    kE = InStr(mD, "/") '--- suppose qu'il y a TOUJOURS une / dans la référence
                    mD = Mid(mD, kE - 2)
                    Cells(kR2, 4) = Left(mD, InStr(mD, " ") - 1)
                    kR2 = kR2 + 1
                Else
                    MsgBox "Ni SORTIE ni ENTREE en ligne " & kR1, _
                            vbExclamation, "Anomalie"
                End If
            End If
            kR1 = kR1 + 1
        Wend
    End With
    Set wSh1 = Nothing
    Set wSh2 = Nothing
End Sub

Bonne continuation.

26/05/2019, 23h13
dudesson

bonsoir @EricDgn,
vraiment très élaboré et particulièrement abouti ce que vous avez réalisé!!!!
j'ai juste ajouté un "clearcontents" et donc supprimé le msgbox.
ça fait 2 h que je test dans tous les sens, rien à dire...
mes sincères remerciements.
Pedro Dudesson.
09/06/2019, 12h19
dudesson

bonjour@EricDgn,
j'ai eu un cas concernant les entrées avec 3 lettres au lieu de 2 avant "/"
j'ai essayé comme ceci :

mD = Mid(mD, kE - 2) Or mD = Mid(mD, kE - 3)

mais ça bug.
merci de m'aider svp.
Dudesson

Salut.

Une approche légèrement différente, qui s'appuie sur la structure des données que tu as présentées. Il a fallu tenir compte des 4 premières sorties dont la structure est différente des autres sorties. Le code tient compte du fait d'une longueur fluctuante pour les codes à prendre en entrée. Je n'ai pas nettoyé la feuille 2 en entrée car ce n'est pas la responsabilité de la fonction, dont le boulot est juste de transférer les données avant. Si une donnée n'était pas conforme, elle serait mise en rouge sur la feuille source pour ne pas interrompre le code par un msgbox.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub ExtractBetweenDates(BeginDate As Date, EndDate As Date)
  Dim SourceCell As Range
  Dim TargetOut As Range
  Dim TargetIn As Range
  Dim Qty As Long
 
  Set TargetOut = Feuil2.Range("a2")
  Set TargetIn = Feuil2.Range("d2")
  For Each SourceCell In Feuil1.Range("j4:j" & Feuil1.Range("i1048576").End(xlUp).Row)
    If SourceCell(1, 0).Value >= BeginDate And SourceCell(1, 0).Value <= EndDate Then
      If SourceCell.Value Like "*SORTIE*" Then
        If IsNumeric(Left(SourceCell.Value, 7)) Then
          TargetOut.Value = Left(SourceCell.Value, 7)
        Else
          TargetOut.Value = Split(SourceCell.Value, " ")(1)
        End If
        TargetOut(1, 2).Value = Replace(Mid(SourceCell.Value, InStr(1, SourceCell.Value, "SORTIE") + 7, 1000), ")", "") * 1
        Set TargetOut = TargetOut(2)
      ElseIf SourceCell.Value Like "*ENTREE*" Then
        TargetIn.Value = Split(SourceCell.Value, " ")(2)
        TargetIn(1, 2) = Replace(Mid(SourceCell.Value, InStr(1, SourceCell.Value, "ENTREE") + 7, 1000), ")", "") * 1
        Set TargetIn = TargetIn(2)
      Else
        SourceCell.Interior.Color = vbRed
      End If
    End If
  Next SourceCell
End Sub

11/06/2019, 12h08
dudesson

bonjour, merci beaucoup. votre code fonctionne bien, merci pour la contribution. Pedro.