Copier 20% des lignes non vide et selon un prefixe

Le 27/08/2014 à 13:41

Bonjour

Aider moi SVP:

  • Je veux copier les lignes non vide du tableau 2 ver tableau 3
  • Puit je veux copier seulement le 1/4 des lignes selon le numero de vol et par jour, par exmple le 01/09/2014 j'ai 6 vol qui commence par "BJ" dans ce cas je copie que 1 seul vol,
18test-v1.xlsx (162.43 Ko)
Le 27/08/2014 à 14:55

Bonjour j'ai essaiyer de modifier le fichier,

SVP aider moi

13test-v2.xlsx (201.94 Ko)
Le 28/08/2014 à 00:46

Bonsoir,

J'ai regardé un peu, voici une solution ou un début de solution, si j'ai bien compris la problématique (!)

Bouben

avec le fichier zippé

21gestiondesvols.zip (216.79 Ko)
Le 28/08/2014 à 11:51

Bonjour,

Une proposition VBA à étudier.

Voir description du code.

(ALT F11 pour ouvrir l'éditeur ; voir modConsolidation)

Cdlt.

12chaouch-nayeh-v1.xlsm (44.67 Ko)
Option Explicit
Option Private Module
'http://forum.excel-pratique.com/excel/copier-20-des-lignes-non-vide-et-selon-un-prefixe-t54758.html
Public Sub Consolidation()
' declaration des variables
Dim ws As Worksheet
Dim lastRow As Long, lRow As Long, I As Long
Dim lo As ListObject
Dim so As Sort
Dim strCode As String

    ' optimisation code
    Application.ScreenUpdating = False
    Application.Calculation = False
    ' initialisation objet
    Set ws = Worksheets("Data")

    With ws
        .Range("F1:J1").EntireColumn.Delete
        .[F4:J4] = Array("date arrive", "vol d'arrive", "date depart", "vol depart", "Code")

        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        lRow = 5
        ' copie des donnes initiales suivant conditions pre-etablies
        For I = 2 To lastRow
            If .Cells(I, 1) = .Cells(I, 3) Then
                If Right(.Cells(I, 2), 1) <> "F" And Right(.Cells(I, 2), 1) <> "P" Then
                    If Right(.Cells(I, 4), 1) <> "F" And Right(.Cells(I, 4), 1) <> "P" Then
                        .Range(.Cells(lRow, 6), .Cells(lRow, 9)) = _
                            .Range(.Cells(I, 1), .Cells(I, 4)).Value
                        lRow = lRow + 1
                    End If
                End If
            End If
        Next I
        ' initialisation tableau final
        Set lo = .ListObjects.Add(xlSrcRange, .Cells(4, 6).CurrentRegion, , xlYes)
        With lo
            .Name = "tblFinal"
            .TableStyle = "TableStyleLight1"
        End With
        ' tri tableau date/vol d'arrivee
        With lo.Sort
            With .SortFields
                .Clear
                .Add Key:=Range("tblFinal[date arrive]"), _
                    SortOn:=xlSortOnValues, Order:=xlAscending
                .Add Key:=Range("tblfinal[vol d''arrive]"), _
                    SortOn:=xlSortOnValues, Order:=xlAscending
            End With
            .Header = xlYes
            .Orientation = xlSortColumns
            .Apply
        End With
        ' insertion code pour supprimer les caracteres numeriques
        strCode = "=DeleteNum([@[vol d''arrive]])"
        .Cells(5, 10) = strCode
        ' suppression des doublons date / code
        lastRow = .Cells(Rows.Count, 6).End(xlUp).Row
        For I = lastRow To 5 Step -1
            If .Cells(I, 6) = .Cells(I - 1, 6) And .Cells(I, 10) = Cells(I - 1, 10) Then
                .Range(.Cells(I, 6), .Cells(I, 10)).Delete
            End If
        Next I
        ' suppression formules code
        Range("tblFinal[code]") = Range("tblFinal[code]").Value
        ' suppression colonnes inutiles (à adapter)
        .Range("G1:I1").EntireColumn.Delete
        .Range("F:G").Columns.AutoFit

    End With
    ' reinitilisation calcul automatique
    Application.Calculation = True

    Set ws = Nothing: Set lo = Nothing

End Sub
Private Function DeleteNum(chaine) As String
' supprime les caracteres numériques d'une chaîne alphanumérique.
Dim obj As Object
    Set obj = CreateObject("vbscript.regexp")
    obj.Global = True
    obj.Pattern = "\d+"
    DeleteNum = obj.Replace(chaine, "")
End Function
Le 28/08/2014 à 11:59

Merci beaucoup Bouben et Jean-Eric

Bonjour j'ai essayé de modifier le fichier, mais mon problme maitenant reside dans la supression de 80% des vols selon le prefixe du numero de vol ( par exemple si j'ai 100 vols qui commence par "BJ" je veux qu'il reste que 25 vols)

Merci beaucoup

12test-v2.xlsm (100.64 Ko)
Le 28/08/2014 à 13:49

Re,

Question initiale pas précise :

Puit je veux copier seulement le 1/4 des lignes selon le numero de vol et par jour, par exmple le 01/09/2014 j'ai 6 vol qui commence par "BJ" dans ce cas je copie que 1 seul vol,

Peux-tu préciser quel est le critère de choix des dates à conserver et la mise en forme des résultats souhaitée?

Et préciser aussi ton objectif?

Cdlt.

Le 28/08/2014 à 14:05

Mon objectif est de voir 20% du programme des vols avec la mise en forme (date arrive / numero de vol arrive/ date depart / numero de vol depart)

Comme critere de selection par exemple:

  • un meme numero de vol ne se repete pas plus que quatre fois,
  • et si la premier condition n'est pas valide nous pouvons determiner que pour un seul jour juste un seul vol avec un prefixe defini existe ( je m'explique : pour le 01/09 par exmple il exite 6 vols qui commence avec 'BJ' l'objectif est d'avoir 1 seul vol),
15test-v3.xlsm (125.22 Ko)
Le 28/08/2014 à 14:33

j'ai trouver une solution mais pouvez vous s'il vous plais m'aider pour optimiser le fichier:

  • Je veux automatise le filtrage des vols de la premiere page(ne pas utiliser des formules comme dans le fichier joint)
  • et je veux ajouter un bouton qui permet d'importer un fichier text et remplir le tableau de premier page
13test-v4.xlsm (170.35 Ko)
14txt.zip (5.65 Ko)
Le 28/08/2014 à 19:02

Re,

Je ne pense pas que ta solution soit viable.

Pas beaucoup plus de précisions, mais...

Voir fichier modifié avec ce que j'ai compris.

J'ai mis des 'Stop' dans la procédure, pour que tu puisses comprendre la logique retenue ( et lis les commentaires ).

Dans l'éditeur VBE, faire F5 pour pou poursuivre son déroulement

Pour l'importation, on verra après, quand on aura résolu la demande initiale.

A te relire.

Cdlt

21chaouch-nayeh-v2.xlsm (47.16 Ko)
Option Explicit
Option Private Module
'http://forum.excel-pratique.com/excel/copier-20-des-lignes-non-vide-et-selon-un-prefixe-t54758.html
Public Sub Consolidation()
' declaration des variables
Dim ws As Worksheet
Dim lastRow As Long, lRow As Long, I As Long
Dim lo As ListObject
Dim strCode As String, strCritere1 As String, strCritere2 As String

    ' optimisation code
    Application.ScreenUpdating = False
    Application.Calculation = False
    ' initialisation objet
    Set ws = Worksheets("Data")

    With ws

        .Range("F1:L1").EntireColumn.Delete
        .[F4:L4] = Array("date arrive", "vol d'arrive", "date depart", "vol depart", "Code", "Critère1", "Critère2")

        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        lRow = 5
        ' copie des donnes initiales suivant conditions pre-etablies
        For I = 2 To lastRow
            If .Cells(I, 1) = .Cells(I, 3) Then
                If Right(.Cells(I, 2), 1) <> "F" And Right(.Cells(I, 2), 1) <> "P" Then
                    If Right(.Cells(I, 4), 1) <> "F" And Right(.Cells(I, 4), 1) <> "P" Then
                        .Range(.Cells(lRow, 6), .Cells(lRow, 9)) = _
                            .Range(.Cells(I, 1), .Cells(I, 4)).Value
                        lRow = lRow + 1
                    End If
                End If
            End If
        Next I

        Stop

        ' initialisation tableau final
        Set lo = .ListObjects.Add(xlSrcRange, .Cells(4, 6).CurrentRegion, , xlYes)
        With lo
            .Name = "tblFinal"
            .TableStyle = "TableStyleLight1"
        End With

        Stop

        ' tri tableau date/vol d'arrivee
        With lo.Sort
            With .SortFields
                .Clear
                .Add Key:=Range("tblFinal[date arrive]"), _
                    SortOn:=xlSortOnValues, Order:=xlAscending
                .Add Key:=Range("tblfinal[vol d''arrive]"), _
                    SortOn:=xlSortOnValues, Order:=xlAscending
            End With
            .Header = xlYes
            .Orientation = xlSortColumns
            .Apply
        End With

        Stop

        ' Formules texte
        ' supprimer les caracteres numeriques
        strCode = "=DeleteNum([@[vol d''arrive]])"
        ' compter le nombre d'occurences total des codes
        strCritere1 = "=COUNTIFS([date arrive],[@[date arrive]],[Code],[@Code])"
        ' rang code
        strCritere2 = "=COUNTIFS(R5C[-6]:RC[-6],RC[-6],R5C[-2]:RC[-2],RC[-2])"
        ' insertion Formules
        .Cells(5, 10).Formula = strCode
        .Cells(5, 11).Formula = strCritere1
        .Cells(5, 12).Formula = strCritere2

        Stop

        ' suppression formules code
        Range("tblFinal[code]") = Range("tblFinal[code]").Value
        Range("tblFinal[Critère1]") = Range("tblFinal[Critère1]").Value
        Range("tblFinal[Critère2]") = Range("tblFinal[Critère2]").Value

        Stop

        ' suppression des doublons codes suivant conditions pre-etablies
        lastRow = .Cells(Rows.Count, 6).End(xlUp).Row
        For I = lastRow To 5 Step -1
            If .Cells(I, 11) > 4 And .Cells(I, 12) > 1 Then
                .Range(.Cells(I, 6), .Cells(I, 12)).Delete
            End If
        Next I

        Stop

        ' suppression colonnes inutiles (à adapter)
        .Range("J1:L1").EntireColumn.Delete
        .Range("F:I").Columns.AutoFit

    End With
    ' reinitilisation calcul automatique
    Application.Calculation = True

    Set ws = Nothing: Set lo = Nothing

End Sub
Le 28/08/2014 à 20:17

Merci beaucoup

mais j'ai un problème de débogage au niveau

"

insertion Formules

.Cells(5, 10).Formula = strCode"

Le 28/08/2014 à 20:32

Re,

Ou as-tu un guillemet dans ce que j'ai envoyé?

A supprimer

Cdlt.

Le 28/08/2014 à 20:35

Oh pardon et merci

Agréable je vais essayer de copier 1/4

Le 29/08/2014 à 12:00

Bonjour,

J'ai essaiyer d'avoir pour un seul jour juste un seul vol avec un prefixe defini existe ( pour le 01/09 par exmple il exite 6 vols qui commence avec 'BJ' l'objectif est d'avoir 1 seul vol) mais j'ai pas puit .

J'ai essaiyer d'ajouter un bouton qui permet d'importer un fichier text et il a fonctionner mais j'ai pas puit copier le contenu dans le tableau de premier page

9txt.zip (5.65 Ko)
13chaouch-najeh-v3.xlsm (63.87 Ko)
Le 29/08/2014 à 12:22

Re,

Je te renvoie le fichier sans les 'Stop' dans le code VBA.

De tout manière, on a bien 1 BJ en date du 01.09.2014...

A tester de nouveau.

Cdlt.

14chaouch-nayeh-v201.xlsm (48.59 Ko)

nb : apprends à recopier un code et ne le modifie pas sans avoir compris sa logique

Le 29/08/2014 à 12:27

Merci;

Mais j'ai deja supprimer les Stop mais le code ne fonctionne pas

8new-microsoft-office-word-document.docx (19.58 Ko)
Le 29/08/2014 à 12:29

Re,

J'ai édité mon dernier message avec un commentaire.

Cdlt.

Le 29/08/2014 à 12:33

Merci Beaucoup pour vos efforts

Et je m'excuse pour perturbation, je pense que je doit me retirer puisque je pourai jamais comprendre VBA,

Merci encore une autre fois

Le 29/08/2014 à 13:10

Re,

Tu abandonnes bien vite

Que veux-tu que je t'explique? ou du moins dis ce que tu ne comprends pas dans le code VBA que j'ai commenté?

Cdlt.

Le 29/08/2014 à 14:14

Votre fichier ne fonctionne pas toujour se debog au niveau de ce parti du code

strCode = "=DeleteNum([@[vol d''arrive]])"

' compter le nombre d'occurences total des codes

strCritere1 = "=COUNTIFS([date arrive],[@[date arrive]],[Code],[@Code])"

' rang code

strCritere2 = "=COUNTIFS(R5C[-6]:RC[-6],RC[-6],R5C[-2]:RC[-2],RC[-2])"

' insertion Formules

.Cells(5, 10).Formula = strCode

.Cells(5, 11).Formula = strCritere1

.Cells(5, 12).Formula = strCritere2

Le 29/08/2014 à 14:58

Nouvelle version

12chaouch-najeh-v5.xlsm (56.45 Ko)
9txt.zip (5.65 Ko)
Rechercher des sujets similaires à "copier lignes vide prefixe"