IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Extraire d'une cellule un texte [XL-2013]


Sujet :

Macros et VBA Excel

  1. #1
    Membre régulier
    Homme Profil pro
    Ingénieur aéronautique
    Inscrit en
    Août 2017
    Messages
    363
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : France, Tarn (Midi Pyrénées)

    Informations professionnelles :
    Activité : Ingénieur aéronautique
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Août 2017
    Messages : 363
    Points : 79
    Points
    79
    Par défaut Extraire d'une cellule un texte
    Bonjour,

    Dans la colonne B du fichier "schema.xlsx" (onglet "feuil1") je trouve le titre du document. Cette colonne comporte pratiquement 400000 lignes (donc 400000 titres différents). J'ai par exemple en cellule B2 le texte suivant :

    M768_IP_Special detailed installation of fuse external structure, panel 38 splicing at DET43, GH/KH_ID4606 postmod


    Ce texte est mémorisé dans un tableau TAB_SCHEMA(). Il s'agit en fait de la valeur TAB_SCHEMA(1,2) car la première ligne correspond à l'entête et n'est pas mémorisée dans le tableau : valeur de la 1ère ligne et 2ème colonne de ce tableau.

    Je voudrais extraire du titre le numéro de l'ID. Dans le cas présenté plus haut le numéro de l'ID serait égal à 4606. Je précise qu'il y a toujours 4 chiffres juste après le texte "ID". Le texte IDxxxx peut se situer n'importe où dans le texte (en général vers la fin).

    Cette extraction serait faite sur toute la colonne (environ 400000 lignes). Beaucoup de titres ne possèdent pas d'ID dans ce cas on met un vide. L'ensemble des résultats seraient stockés dans un deuxième tableau (par exemple TAB_ID()) qui comporterait en 1ère colonne l'ID et en deuxième le titre.

    Ce tableau (2 colonnes) ressemblerait à :

    4606 M768_IP_Special detailed installation of fuse external structure, panel 38 splicing at DET43, GH/KH_ID4606 postmod
    5307
    5478 Z435 essai de fatigue ID5478
    4804
    4342 ER567 stockage dans le hangar B45 ID4342
    ...
    ...

    Des suggestions ? Merci par avance.

    Cdlt.
    Jérôme.

  2. #2
    Expert confirmé Avatar de Patrice740
    Homme Profil pro
    Retraité
    Inscrit en
    Mars 2007
    Messages
    2 475
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 70
    Localisation : France, Gironde (Aquitaine)

    Informations professionnelles :
    Activité : Retraité
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Mars 2007
    Messages : 2 475
    Points : 5 630
    Points
    5 630
    Par défaut
    Bonjour,

    Pour extraire l'ID du texte :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    Option Explicit
    Sub test()
    Dim str As String
     
      str = "M768_IP_Special detailed installation of fuse external structure, panel 38 splicing at DET43, GH/KH_ID4606 postmod"
      MsgBox ExtraireID(str)
     
    End Sub
     
    Function ExtraireID(s As String) As String
    Dim id As String
      id = Mid("IDxxxx" & s, InStrRev("IDxxxx" & s, "ID") + 2, 4)  'si pas d'ID on obtient xxxx
      If Format(Val(id), "0000") = id Then ExtraireID = id Else ExtraireID = ""
    End Function
    Tu n'a plus qu'à boucler sur les valeurs de ton tableau.
    Cordialement,
    Patrice
    Personne ne peut détenir tout le savoir, c'est pour ça qu'on le partage.

    Pour dire merci, cliquer sur et quand la discussion est finie, penser à cliquer sur

  3. #3
    Membre régulier
    Homme Profil pro
    Ingénieur aéronautique
    Inscrit en
    Août 2017
    Messages
    363
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : France, Tarn (Midi Pyrénées)

    Informations professionnelles :
    Activité : Ingénieur aéronautique
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Août 2017
    Messages : 363
    Points : 79
    Points
    79
    Par défaut
    Bonjour Patrice740,

    Merci beaucoup. Désolé pour le silence radio, des priorités autres .....

    Cdlt.
    Jérôme

  4. #4
    Inactif  

    Homme Profil pro
    cuisiniste
    Inscrit en
    Avril 2009
    Messages
    15 379
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Var (Provence Alpes Côte d'Azur)

    Informations professionnelles :
    Activité : cuisiniste
    Secteur : Bâtiment

    Informations forums :
    Inscription : Avril 2009
    Messages : 15 379
    Points : 12 073
    Points
    12 073
    Billets dans le blog
    8
    Par défaut re
    bonsoir patrice

    je comprends pas trop ton ajout de texte "idxxxx" tout du moins son utilité

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    Option Explicit
    Sub test()
        Dim str As String
        str = "M768_IP_Special detailed installation of fuse external structure, panel 38 splicing at DET43, GH/KH_ID4606 postmod"
        MsgBox ExtraireID(str)
        str = "M768_IP_Special detailed installation of fuse external structure, panel 38 splicing at DET43, GH/KH_OD4606 postmod"
        MsgBox ExtraireID(str)
    End Sub
    Function ExtraireID(s As String) As String
        Dim x
        x = InStrRev(s, "ID")
        ExtraireID = IIf(x > 0, Val(Mid(s, x + 2)), "")
    End Function
    et toujours en espérant que les chaines soit de même acabit
    mes fichiers dans les contributions:
    mail avec CDO en vba et mail avec CDO en vbs dans un HTA
    survol des bouton dans userform
    prendre un cliché d'un range

    si ton problème est résolu n'oublie pas de pointer : : ça peut servir aux autres
    et n'oublie pas de voter

  5. #5
    Expert confirmé Avatar de Patrice740
    Homme Profil pro
    Retraité
    Inscrit en
    Mars 2007
    Messages
    2 475
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 70
    Localisation : France, Gironde (Aquitaine)

    Informations professionnelles :
    Activité : Retraité
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Mars 2007
    Messages : 2 475
    Points : 5 630
    Points
    5 630
    Par défaut
    Bonjour Patrick
    Citation Envoyé par patricktoulon Voir le message
    bonsoir patrice
    je comprends pas trop ton ajout de texte "idxxxx" tout du moins son utilité
    C'est dans l’énoncé du problème :
    Citation Envoyé par licpegpon Voir le message
    .... Je précise qu'il y a toujours 4 chiffres juste après le texte "ID". Le texte IDxxxx peut se situer n'importe où dans le texte (en général vers la fin).
    Beaucoup de titres ne possèdent pas d'ID dans ce cas on met un vide.
    Ça résout simplement (pas besoin de test IF ou IIF) le cas de présence de 'ID' mais d'absence de 'ID' suivi de 4 chiffres, par exemple
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    str = "M768_ID_Special detailed installation of fuse external structure, panel 38 splicing at DET43, GH/KH_OD4606 postmod"
    Cordialement,
    Patrice
    Personne ne peut détenir tout le savoir, c'est pour ça qu'on le partage.

    Pour dire merci, cliquer sur et quand la discussion est finie, penser à cliquer sur

  6. #6
    Inactif  

    Homme Profil pro
    cuisiniste
    Inscrit en
    Avril 2009
    Messages
    15 379
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Var (Provence Alpes Côte d'Azur)

    Informations professionnelles :
    Activité : cuisiniste
    Secteur : Bâtiment

    Informations forums :
    Inscription : Avril 2009
    Messages : 15 379
    Points : 12 073
    Points
    12 073
    Billets dans le blog
    8
    Par défaut re
    re
    dans l'énoncé IDxxxx est une expression dans son explication

    pour en revenir a ton modèle si je comprends bien tu récupère soit ID4096 soit IDxxxx et tu test avec un IF format si c'est bien numérique
    mes fichiers dans les contributions:
    mail avec CDO en vba et mail avec CDO en vbs dans un HTA
    survol des bouton dans userform
    prendre un cliché d'un range

    si ton problème est résolu n'oublie pas de pointer : : ça peut servir aux autres
    et n'oublie pas de voter

  7. #7
    Expert confirmé Avatar de Patrice740
    Homme Profil pro
    Retraité
    Inscrit en
    Mars 2007
    Messages
    2 475
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 70
    Localisation : France, Gironde (Aquitaine)

    Informations professionnelles :
    Activité : Retraité
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Mars 2007
    Messages : 2 475
    Points : 5 630
    Points
    5 630
    Par défaut
    Re,
    Citation Envoyé par patricktoulon Voir le message
    si je comprends bien tu récupère soit ID4096 soit IDxxxx et tu test avec un IF format si c'est bien numérique
    C'est exactement ça.
    C'est une technique que j'emploie fréquemment avec InStr & InStrRev (i.e. InStrRev("xx" & s, "xx")) pour être certain que la chaine cherchée soit trouvée.
    PS : et le test avec Format permet de s'assurer qu'il y a bien 4 chiffres ni plus ni moins.
    Cordialement,
    Patrice
    Personne ne peut détenir tout le savoir, c'est pour ça qu'on le partage.

    Pour dire merci, cliquer sur et quand la discussion est finie, penser à cliquer sur

  8. #8
    Inactif  

    Homme Profil pro
    cuisiniste
    Inscrit en
    Avril 2009
    Messages
    15 379
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Var (Provence Alpes Côte d'Azur)

    Informations professionnelles :
    Activité : cuisiniste
    Secteur : Bâtiment

    Informations forums :
    Inscription : Avril 2009
    Messages : 15 379
    Points : 12 073
    Points
    12 073
    Billets dans le blog
    8
    Par défaut RE
    RE
    je suis plutôt adepte d'astuce de ce genre
    mais dans le cas présent pensant gérer la récup des 4 chiffres et control avec format tu néglige le fait qu'il puisse y avoir plusieurs sous chaine "ID....." dans la chaine
    et que la bonne ne soit pas la dernière

    test celle ci avec ta fonction
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    str = "M768_IP_Special detailed installation of fuse external structure,GH/KH_ID4606 panel 38 splicing at DET43, ABCDEFIDGHIJKL postmod"
        MsgBox ExtraireID(str)

    celle ci est moins jolie mais elle donnera le id en toute circonstance
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    Function ExtraireID(s As String) As String
        Dim tbl, elem
        tbl = Split(s, "ID")
        For Each elem In tbl
            If Format(Val(Left(elem, 4)), "0000") = Left(elem, 4) Then ExtraireID = Left(elem, 4)
        Next
    End Function
    mes fichiers dans les contributions:
    mail avec CDO en vba et mail avec CDO en vbs dans un HTA
    survol des bouton dans userform
    prendre un cliché d'un range

    si ton problème est résolu n'oublie pas de pointer : : ça peut servir aux autres
    et n'oublie pas de voter

  9. #9
    Membre régulier
    Homme Profil pro
    Ingénieur aéronautique
    Inscrit en
    Août 2017
    Messages
    363
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : France, Tarn (Midi Pyrénées)

    Informations professionnelles :
    Activité : Ingénieur aéronautique
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Août 2017
    Messages : 363
    Points : 79
    Points
    79
    Par défaut
    Bonjour à vous (PatrickToulon et Patrice740),

    J'avoue avoir zappé les échanges, j'ai essayé d'avancer de mon côté. Voici un premier jet (qui plante mais bon...) :

    Je copie des données d'un tableau dans un autre mais je pense qu'il doit y avoir un problème pour la déclaration du tableau TAB_ID(). La déclaration du tableau TAB_SCHEMA semble OK par contre. Je ne sais pas comment déclarer TAB_ID() ?
    A l'exécution j'ai le message comme quoi la fonction n'est pas définie ? Où, comment dois-je la déclarer ?

    Je précise que j'ai copié la fonction ci dessous dans "Thisworkbook". Pas sûr de mon coup ?

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    Function ExtraireID(s As String) As String
    Dim id As String
      id = Mid("IDxxxx" & s, InStrRev("IDxxxx" & s, "ID") + 2, 4)  'si pas d'ID on obtient xxxx
      If Format(Val(id), "0000") = id Then ExtraireID = id Else ExtraireID = ""
    End Function
    Voici l'état actuel de la procédure

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    Option Explicit
    Sub ECM()
    '
    'Déclaration des variables
    '
    Dim derniere_ligne As Long
    Dim Tab_SCHEMA() As Variant
    Dim Tab_ID() As Variant
    Dim str As String
    Dim i As Integer
    Dim classeur As String
    Dim statusBarInitial As Long
    '
    'Ouverture du fichier schema.xml_temporary.xlsx
    'On se positionne dans l'onglet "schema.xml_temporary"
    '
    classeur = Application.GetOpenFilename(, 1, "Select 'schema.xml_temporary.xlsx' file", , False)
    Workbooks.Open classeur
    Sheets("schema.xml_temporary").Activate
    '
    derniere_ligne = Range("A" & Rows.Count).End(xlUp).Row
    '
    MsgBox ("Dernière ligne = ") & derniere_ligne
    '
    'La ligne d'instruction ci-dessous suffit à elle seule pour remplir le tableau !!
    'La zone mise en mémoire part de la 2ème ligne --> Range("A2") jusqu'à la ligne "derniere_ligne - 1"
    'Le tableau contient 52 colonnes et "derniere_ligne - 1" lignes
    '
    Tab_SCHEMA = Range("A2").Resize(derniere_ligne - 1, 52).Value
    '
    MsgBox ("Data storage is complete. The repatriation of the data will begin.")
    '
    'MsgBox ("1  2 = ") & Tab_SCHEMA(1, 2)
    'MsgBox ("1  48 = ") & Tab_SCHEMA(1, 48)
    'MsgBox ("399458  2 = ") & Tab_SCHEMA(399458, 2)
    'MsgBox ("399458  48 = ") & Tab_SCHEMA(399458, 48)
    'MsgBox ("399458  49 = ") & Tab_SCHEMA(399458, 49)
    '
    'Fermer le classeur actif
    '
    ActiveWorkbook.Close SaveChanges:=False
    '
    'Ouverture du fichier FOLLOW_UP_TEST.xlsm
    'On se positionne dans l'onglet "ECM"
    '
    classeur = Application.GetOpenFilename(, 1, "Select 'FOLLOW_UP_TEST.xlsm' file", , False)
    Workbooks.Open classeur
    Sheets("ECM").Activate
    '
    Range("A1").Select
    '
    statusBarInitial = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    '
    'Extraction de l'ID de tous les "Document title"
    '
    For i = 1 To derniere_ligne - 1
     
    Application.StatusBar = "Calcul en cours... " & i & " / " & derniere_ligne - 1
     
    str = Tab_SCHEMA(i, 2)
    Tab_ID(i, 1) = ExtraireID(str)
    Tab_ID(i, 2) = Tab_SCHEMA(i, 2)
    Tab_ID(i, 3) = Tab_SCHEMA(i, 3)
    Tab_ID(i, 4) = Tab_SCHEMA(i, 4)
    Tab_ID(i, 5) = Tab_SCHEMA(i, 5)
    Tab_ID(i, 6) = Tab_SCHEMA(i, 22)
    Tab_ID(i, 7) = Tab_SCHEMA(i, 23)
    Tab_ID(i, 8) = Tab_SCHEMA(i, 24)
    Tab_ID(i, 9) = Tab_SCHEMA(i, 25)
    Tab_ID(i, 10) = Tab_SCHEMA(i, 36)
    Tab_ID(i, 11) = Tab_SCHEMA(i, 37)
     
    Next
    '
    '
    'Ecriture des résultats dans l'onglet "ECM"
    '
    For i = 1 To derniere_ligne - 1
     
    Cells(i + 2, 2) = Tab_ID(i, 1)
    Cells(i + 2, 3) = Tab_ID(i, 2)
    Cells(i + 2, 4) = Tab_ID(i, 3)
    Cells(i + 2, 5) = Tab_ID(i, 4)
    Cells(i + 2, 6) = Tab_ID(i, 5)
    Cells(i + 2, 7) = Tab_ID(i, 6)
    Cells(i + 2, 8) = Tab_ID(i, 7)
    Cells(i + 2, 9) = Tab_ID(i, 8)
    Cells(i + 2, 10) = Tab_ID(i, 9)
    Cells(i + 2, 11) = Tab_ID(i, 10)
     
    Next
    '
    End Sub
    Merci à vous.

    Cdlt.
    Jérôme

  10. #10
    Inactif  

    Homme Profil pro
    cuisiniste
    Inscrit en
    Avril 2009
    Messages
    15 379
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Var (Provence Alpes Côte d'Azur)

    Informations professionnelles :
    Activité : cuisiniste
    Secteur : Bâtiment

    Informations forums :
    Inscription : Avril 2009
    Messages : 15 379
    Points : 12 073
    Points
    12 073
    Billets dans le blog
    8
    Par défaut re
    bonjour
    peut être devrais tu commencer par dimensionner "TAB_ID" avant d'essayer de le remplir
    pour sa dimension si j'ai bien compris ton code il a le même nombre de ligne que TAB_SCHEMA mais seulement 11 colonnes
    si c'est bien ca
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    Option Explicit
    Sub ECM()
    '
    'Déclaration des variables
    '
    Dim derniere_ligne As Long
    Dim Tab_SCHEMA() As Variant
    Dim Tab_ID() As Variant
    Dim str As String
    Dim i As Integer
    Dim classeur As String
    Dim statusBarInitial As Long
    '
    'Ouverture du fichier schema.xml_temporary.xlsx
    'On se positionne dans l'onglet "schema.xml_temporary"
    '
    classeur = Application.GetOpenFilename(, 1, "Select 'schema.xml_temporary.xlsx' file", , False)
    Workbooks.Open classeur
    Sheets("schema.xml_temporary").Activate
    '
    derniere_ligne = Range("A" & Rows.Count).End(xlUp).Row
    '
    MsgBox ("Dernière ligne = ") & derniere_ligne
    '
    'La ligne d'instruction ci-dessous suffit à elle seule pour remplir le tableau !!
    'La zone mise en mémoire part de la 2ème ligne --> Range("A2") jusqu'à la ligne "derniere_ligne - 1"
    'Le tableau contient 52 colonnes et "derniere_ligne - 1" lignes
    '
    Tab_SCHEMA = Range("A2").Resize(derniere_ligne - 1, 52).Value
    '
    MsgBox ("Data storage is complete. The repatriation of the data will begin.")
    '
    'MsgBox ("1  2 = ") & Tab_SCHEMA(1, 2)
    'MsgBox ("1  48 = ") & Tab_SCHEMA(1, 48)
    'MsgBox ("399458  2 = ") & Tab_SCHEMA(399458, 2)
    'MsgBox ("399458  48 = ") & Tab_SCHEMA(399458, 48)
    'MsgBox ("399458  49 = ") & Tab_SCHEMA(399458, 49)
    '
    'Fermer le classeur actif
    '
    ActiveWorkbook.Close SaveChanges:=False
    '
    'Ouverture du fichier FOLLOW_UP_TEST.xlsm
    'On se positionne dans l'onglet "ECM"
    '
    classeur = Application.GetOpenFilename(, 1, "Select 'FOLLOW_UP_TEST.xlsm' file", , False)
    Workbooks.Open classeur
    Sheets("ECM").Activate
    '
    Range("A1").Select' a quoi ca sert ca ?
    '
    statusBarInitial = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    '
    'Extraction de l'ID de tous les "Document title"
    '
    ReDim Tab_ID(1 To UBound(Tab_SCHEMA), 11)
    For i = 1 To derniere_ligne - 1'meme si c'est cohérent pourquoi ne boucle tu pas sur TAB_SCHEMA plutôt ?????????
     
    Application.StatusBar = "Calcul en cours... " & i & " / " & derniere_ligne - 1
     str = Tab_SCHEMA(i, 2)
    Tab_ID(i, 1) = ExtraireID(str)
    Tab_ID(i, 2) = Tab_SCHEMA(i, 2)
    Tab_ID(i, 3) = Tab_SCHEMA(i, 3)
    Tab_ID(i, 4) = Tab_SCHEMA(i, 4)
    Tab_ID(i, 5) = Tab_SCHEMA(i, 5)
    Tab_ID(i, 6) = Tab_SCHEMA(i, 22)
    Tab_ID(i, 7) = Tab_SCHEMA(i, 23)
    Tab_ID(i, 8) = Tab_SCHEMA(i, 24)
    Tab_ID(i, 9) = Tab_SCHEMA(i, 25)
    Tab_ID(i, 10) = Tab_SCHEMA(i, 36)
    Tab_ID(i, 11) = Tab_SCHEMA(i, 37)
     
    Next
    '
    '
    'Ecriture des résultats dans l'onglet "ECM"
    '
    'For i = 1 To derniere_ligne - 1
     
    'Cells(i + 2, 2) = Tab_ID(i, 1)
    'Cells(i + 2, 3) = Tab_ID(i, 2)
    'Cells(i + 2, 4) = Tab_ID(i, 3)
    'Cells(i + 2, 5) = Tab_ID(i, 4)
    'Cells(i + 2, 6) = Tab_ID(i, 5)
    'Cells(i + 2, 7) = Tab_ID(i, 6)
    'Cells(i + 2, 8) = Tab_ID(i, 7)
    'Cells(i + 2, 9) = Tab_ID(i, 8)
    'Cells(i + 2, 10) = Tab_ID(i, 9)
    'Cells(i + 2, 11) = Tab_ID(i, 10)
     
    'Next
    '
    Sheets("ECM").Cells(3, 2).Resize(UBound(Tab_ID), UBound(Tab_ID, 2)) .value= Tab_ID
    End Sub
    mes fichiers dans les contributions:
    mail avec CDO en vba et mail avec CDO en vbs dans un HTA
    survol des bouton dans userform
    prendre un cliché d'un range

    si ton problème est résolu n'oublie pas de pointer : : ça peut servir aux autres
    et n'oublie pas de voter

  11. #11
    Membre régulier
    Homme Profil pro
    Ingénieur aéronautique
    Inscrit en
    Août 2017
    Messages
    363
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : France, Tarn (Midi Pyrénées)

    Informations professionnelles :
    Activité : Ingénieur aéronautique
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Août 2017
    Messages : 363
    Points : 79
    Points
    79
    Par défaut
    A l'éxécution j'ai une erreur : fonction non définie. ?

  12. #12
    Membre régulier
    Homme Profil pro
    Ingénieur aéronautique
    Inscrit en
    Août 2017
    Messages
    363
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : France, Tarn (Midi Pyrénées)

    Informations professionnelles :
    Activité : Ingénieur aéronautique
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Août 2017
    Messages : 363
    Points : 79
    Points
    79
    Par défaut
    Egalement : la dernière ligne apparait en rouge ?

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    Sheets("ECM").Cells(3, 2).Resize(UBound(Tab_ID), UBound(Tab_ID, 2)) .value= Tab_ID

  13. #13
    Membre régulier
    Homme Profil pro
    Ingénieur aéronautique
    Inscrit en
    Août 2017
    Messages
    363
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : France, Tarn (Midi Pyrénées)

    Informations professionnelles :
    Activité : Ingénieur aéronautique
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Août 2017
    Messages : 363
    Points : 79
    Points
    79
    Par défaut
    Pourrais-tu expliciter la ligne d'instruction ? Merci. :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    Sheets("ECM").Cells(3, 2).Resize(UBound(Tab_ID), UBound(Tab_ID, 2)) .value= Tab_ID

  14. #14
    Inactif  

    Homme Profil pro
    cuisiniste
    Inscrit en
    Avril 2009
    Messages
    15 379
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Var (Provence Alpes Côte d'Azur)

    Informations professionnelles :
    Activité : cuisiniste
    Secteur : Bâtiment

    Informations forums :
    Inscription : Avril 2009
    Messages : 15 379
    Points : 12 073
    Points
    12 073
    Billets dans le blog
    8
    Par défaut
    Citation Envoyé par licpegpon Voir le message
    Pourrais-tu expliciter la ligne d'instruction ? Merci. :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    Sheets("ECM").Cells(3, 2).Resize(UBound(Tab_ID), UBound(Tab_ID, 2)) .value= Tab_ID
    re
    oui en rouge car il y a un espace avant le point devant ".Value" ca se produit quand je copie/colle le code demon classeur au wysiwyg de dvp c'est pas la première fois que ca arrive
    j'ignore pourquoi il faut enlever cet espace bien sur

    pour l'explication
    toi tu rempli ligne par ligne avec les ligne de ta variable TAB_ID
    alors que tu peux transférer tout d'un coup
    traduction
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    Sheets("ECM").Cells(ligne3, colonne2).redimentionnée au (nombre de ligne de (Tab_ID) et nombre de colonne de (Tab_ID, 2)).value= tout le Tab_ID
    mes fichiers dans les contributions:
    mail avec CDO en vba et mail avec CDO en vbs dans un HTA
    survol des bouton dans userform
    prendre un cliché d'un range

    si ton problème est résolu n'oublie pas de pointer : : ça peut servir aux autres
    et n'oublie pas de voter

  15. #15
    Membre régulier
    Homme Profil pro
    Ingénieur aéronautique
    Inscrit en
    Août 2017
    Messages
    363
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : France, Tarn (Midi Pyrénées)

    Informations professionnelles :
    Activité : Ingénieur aéronautique
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Août 2017
    Messages : 363
    Points : 79
    Points
    79
    Par défaut
    Merci pour tes éclaircissements !!

    A l'exécution j'ai une erreur de compilation : Sub ou fonction non définie.

    Erreur à la ligne :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    Tab_ID(i, 1) = ExtraireID(str)
    De plus j'ai collé le code dans "Thisworkbook", est-ce le bon endroit ?

  16. #16
    Inactif  

    Homme Profil pro
    cuisiniste
    Inscrit en
    Avril 2009
    Messages
    15 379
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Var (Provence Alpes Côte d'Azur)

    Informations professionnelles :
    Activité : cuisiniste
    Secteur : Bâtiment

    Informations forums :
    Inscription : Avril 2009
    Messages : 15 379
    Points : 12 073
    Points
    12 073
    Billets dans le blog
    8
    Par défaut re
    re non pas trop le mieux serait dans un module standard
    après j'ai pas tout ton code chez moi j'ai testé et ca fonctionne
    ton tab_scheme est en base 1 puisque récupérer avec un range
    je redim donc tab_id au meme nombre de ligne en base 1, 11 colonne
    si tu a un soucis avec ca alors il y a du code qui fou le boxon avec tes variable soit tableau soit variables d'incrémentation
    mes fichiers dans les contributions:
    mail avec CDO en vba et mail avec CDO en vbs dans un HTA
    survol des bouton dans userform
    prendre un cliché d'un range

    si ton problème est résolu n'oublie pas de pointer : : ça peut servir aux autres
    et n'oublie pas de voter

  17. #17
    Membre régulier
    Homme Profil pro
    Ingénieur aéronautique
    Inscrit en
    Août 2017
    Messages
    363
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : France, Tarn (Midi Pyrénées)

    Informations professionnelles :
    Activité : Ingénieur aéronautique
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Août 2017
    Messages : 363
    Points : 79
    Points
    79
    Par défaut
    Re,

    J'ai déplacé la fonction dans le même module que la procédure et depuis je n'ai plus de message d'erreur de compilation (message : fonction non définie). Le fait de mettre la fonction dans thisworkbook visiblement ne fonctionne pas. Voila pour ça.

    Le tableau TAB_ID() fait 10 colonnes et non 11. J'ai donc modifié l'instruction Redim....
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    ReDim Tab_ID(1 To UBound(Tab_SCHEMA), 10)
    J'ai dû rajouter une phase de "nettoyage" du fichier "schema.xml_temporary.xlsx" car celui-ci contient des bugs dans quelques cellules (il y a des formules à certains endroits donc des "=" et cela plante la macro. Pour contourner le pb j'ai préalablement remplacé les "=" par des "-". A partir de là plus de pb.

    Dans la boucle j'ai supprimé les lignes où il était question de la colonne 11 pour Tab_ID (en effet TAB_ID ne compte que 10 colonnes).

    J'ai mis en commentaire les lignes suivantes car elles ralentissent énormément le calcul :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    'statusBarInitial = Application.DisplayStatusBar
    'Application.DisplayStatusBar = True
    et
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    'Application.StatusBar = "Calcul en cours... " & i & " / " & derniere_ligne - 1
    Voici la version actuelle du code :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    Sub ECM()
    '
    'Déclaration des variables
    '
    Dim derniere_ligne As Long
    Dim Tab_SCHEMA() As Variant
    Dim Tab_ID() As Variant
    Dim str As String
    Dim i As Long
    Dim classeur As String
    Dim statusBarInitial As Long
    '
    '
    'La data base ECM a t-elle déja été nettoyée ?
    '
    If MsgBox("Has the ECM data base already been cleaned ?", vbYesNo, "Confirmation Request") = vbNo Then
    '
    classeur = Application.GetOpenFilename(, 1, "Select 'schema.xml_temporary.xlsx' file", , False)
    Workbooks.Open classeur
    Sheets("schema.xml_temporary").Activate
    '
    MsgBox ("WARNING : The cleaning of the file will start" & Chr(10) & Chr(10) & "Thank you for waiting")
    '
    'Recherche du numéro de la dernière ligne
    '
    derniere_ligne = Range("A" & Rows.Count).End(xlUp).Row
    MsgBox ("Derniere ligne = ") & derniere_ligne
    '
    'Suppression des formules éventuelles contenues dans ce fichier (on remplace les "=" par des "-")
    '
    Range("A2:AY" & derniere_ligne).Select
        Selection.Replace What:="=", Replacement:="-", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    '
    Range("A2").Select
    '
    MsgBox ("The ECM Data base has been cleaned" & Chr(10) & Chr(10) & "WARNING : The initial file will be updated !!")
    '
    'Enregistrement de la data base ECM (ATTENTION : l'ancienne version est écrasée)
    '
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:="schema.xml_temporary.xlsx"
    Application.DisplayAlerts = True 'Remettre absolument ensuite
     
    MsgBox ("The ECM Data base has been cleaned and saved (overwritten file)" & Chr(10) & Chr(10) & "Data extraction will begin")
     
    Else
     
    classeur = Application.GetOpenFilename(, 1, "Select 'schema.xml_temporary.xlsx' file", , False)
    Workbooks.Open classeur
    Sheets("schema.xml_temporary").Activate
    derniere_ligne = Range("A" & Rows.Count).End(xlUp).Row
    MsgBox ("Derniere ligne = ") & derniere_ligne
    MsgBox ("Data extraction will begin")
     
    End If
     
    '
    'La ligne d'instruction ci-dessous suffit à elle seule pour remplir le tableau !!
    'La zone mise en mémoire part de la 2ème ligne --> Range("A2") jusqu'à la ligne "derniere_ligne - 1"
    'Le tableau contient 51 colonnes et "derniere_ligne - 1" lignes
    '
    Tab_SCHEMA = Range("A2").Resize(derniere_ligne - 1, 51).Value
    '
    MsgBox ("Data storage of 'schema.xml_temporary.xlsx' file is complete.")
    '
    'Pour debugage uniquement
    '
    'MsgBox ("1  2 = ") & Tab_SCHEMA(1, 2)
    MsgBox ("1  51 = ") & Tab_SCHEMA(1, 51)
    'MsgBox ("399458  2 = ") & Tab_SCHEMA(399458, 2)
    MsgBox ("399458  51 = ") & Tab_SCHEMA(399458, 51)
    'MsgBox ("399458  49 = ") & Tab_SCHEMA(399458, 49)
    '
    'Fermer le classeur actif
    '
    ActiveWorkbook.Close SaveChanges:=False
    '
    'Activation du fichier "FOLLOW_UP_TEST.xlsm", on se place dans l'onglet "ECM"
    '
    Windows("FOLLOW_UP_TEST.xlsm").Activate
    Sheets("ECM").Activate
    '
    'statusBarInitial = Application.DisplayStatusBar
    'Application.DisplayStatusBar = True
    '
    'Extraction de l'ID de tous les "Document title"
    '
    ReDim Tab_ID(1 To UBound(Tab_SCHEMA), 10)
    For i = 1 To derniere_ligne - 1 'meme si c'est cohérent pourquoi ne boucle tu pas sur TAB_SCHEMA plutôt ?????????
     
    'Application.StatusBar = "Calcul en cours... " & i & " / " & derniere_ligne - 1
     str = Tab_SCHEMA(i, 2)
    Tab_ID(i, 1) = ExtraireID(str)
    Tab_ID(i, 2) = Tab_SCHEMA(i, 2)
    Tab_ID(i, 3) = Tab_SCHEMA(i, 3)
    Tab_ID(i, 4) = Tab_SCHEMA(i, 4)
    Tab_ID(i, 5) = Tab_SCHEMA(i, 5)
    Tab_ID(i, 6) = Tab_SCHEMA(i, 22)
    Tab_ID(i, 7) = Tab_SCHEMA(i, 23)
    Tab_ID(i, 8) = Tab_SCHEMA(i, 24)
    Tab_ID(i, 9) = Tab_SCHEMA(i, 25)
    Tab_ID(i, 10) = Tab_SCHEMA(i, 36)
     
    Next
    '
    '
    'Ecriture des résultats dans l'onglet "ECM"
    '
    'For i = 1 To derniere_ligne - 1
     
    'Cells(i + 2, 2) = Tab_ID(i, 1)
    'Cells(i + 2, 3) = Tab_ID(i, 2)
    'Cells(i + 2, 4) = Tab_ID(i, 3)
    'Cells(i + 2, 5) = Tab_ID(i, 4)
    'Cells(i + 2, 6) = Tab_ID(i, 5)
    'Cells(i + 2, 7) = Tab_ID(i, 6)
    'Cells(i + 2, 8) = Tab_ID(i, 7)
    'Cells(i + 2, 9) = Tab_ID(i, 8)
    'Cells(i + 2, 10) = Tab_ID(i, 9)
    'Cells(i + 2, 11) = Tab_ID(i, 10)
     
    'Next
    '
    'Explication de la ligne d'instruction plus bas
    'Sheets("ECM").Cells(ligne3, col2).redimensionnée au (nombre de lignes de (Tab_ID) et nombre de col de (Tab_ID, 2)).value= tout le Tab_ID
    '
    Sheets("ECM").Cells(3, 2).Resize(UBound(Tab_ID), UBound(Tab_ID, 2)).Value = Tab_ID
    '
    End Sub
     
    Function ExtraireID(s As String) As String
    Dim id As String
      id = Mid("IDxxxx" & s, InStrRev("IDxxxx" & s, "ID") + 2, 4)  'si pas d'ID on obtient xxxx
      If Format(Val(id), "0000") = id Then ExtraireID = id Else ExtraireID = ""
    End Function

  18. #18
    Membre régulier
    Homme Profil pro
    Ingénieur aéronautique
    Inscrit en
    Août 2017
    Messages
    363
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : France, Tarn (Midi Pyrénées)

    Informations professionnelles :
    Activité : Ingénieur aéronautique
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Août 2017
    Messages : 363
    Points : 79
    Points
    79
    Par défaut
    Je viens de lancer la macro et cela semble fonctionner sauf qu'il me décale les résultats d'une colonne vers la droite. Il doit y avoir un pb de base. Quelle est l'instruction pour régler ce pb ?
    Par exemple les "document title" se trouvent dans la colonne "reference"....

    Merci encore.

  19. #19
    Membre régulier
    Homme Profil pro
    Ingénieur aéronautique
    Inscrit en
    Août 2017
    Messages
    363
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : France, Tarn (Midi Pyrénées)

    Informations professionnelles :
    Activité : Ingénieur aéronautique
    Secteur : Aéronautique - Marine - Espace - Armement

    Informations forums :
    Inscription : Août 2017
    Messages : 363
    Points : 79
    Points
    79
    Par défaut
    Bonjour,

    Voici la version finale de la procédure. Celle-ci fonctionne parfaitement. MERCI !!

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    Option Base 1
    Option Explicit
    Sub ECM()
    '
    'Déclaration des variables
    '
    Dim derniere_ligne As Long
    Dim Tab_SCHEMA() As Variant
    Dim Tab_ID() As Variant
    Dim str As String
    Dim i As Long
    Dim classeur As String
    Dim statusBarInitial As Long
    '
    'Enlever le filtre des cellules B2 à K2
    'Le fichier doit impérativement disposer des filtres à l'ouverture.
    '
    Range("B2:K2").Select
    Selection.AutoFilter
    '
    'Effacer la zone B3 à K (dernière ligne colonne C : valeur se trouvant en A1)
    '
    Range("B3:K" & [A1]).ClearContents
    '
    'Dans l'onglet "ECM" effacer le contenu de la cellule A7
    '
    Range("A7").Select
    Selection.ClearContents
    '
    'Ecrire dans la cellule A7 la date du jour. Ceci permettra de garder une trace de
    'la date de mise à jour du fichier
    '
    ThisWorkbook.Worksheets("ECM").Range("A7").Value = Now()
    '
    Range("A2").Select
    '
    MsgBox ("Previous values cleared")
    '
    'La data base ECM a t-elle déja été nettoyée ?
    '
    If MsgBox("Has the ECM data base already been cleaned ?", vbYesNo, "Confirmation Request") = vbNo Then
    '
    classeur = Application.GetOpenFilename(, 1, "Select 'schema.xml_temporary.xlsx' file", , False)
    Workbooks.Open classeur
    Sheets("schema.xml_temporary").Activate
    '
    MsgBox ("WARNING : The cleaning of the file will start" & Chr(10) & Chr(10) & "Thank you for waiting")
    '
    'Recherche du numéro de la dernière ligne
    '
    derniere_ligne = Range("A" & Rows.Count).End(xlUp).Row
    MsgBox ("Derniere ligne = ") & derniere_ligne
    '
    'Suppression des formules éventuelles contenues dans ce fichier (on remplace les "=" par des "-")
    '
    Range("A2:AY" & derniere_ligne).Select
        Selection.Replace What:="=", Replacement:="-", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    '
    Range("A2").Select
    '
    MsgBox ("The ECM Data base has been cleaned" & Chr(10) & Chr(10) & "WARNING : The initial file will be updated !!")
    '
    'Enregistrement de la data base ECM (ATTENTION : l'ancienne version est écrasée)
    '
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:="schema.xml_temporary.xlsx"
    Application.DisplayAlerts = True 'Remettre absolument ensuite
     
    MsgBox ("The ECM Data base has been cleaned and saved (overwritten file)" & Chr(10) & Chr(10) & "The storage of data will begin")
     
    Else
     
    classeur = Application.GetOpenFilename(, 1, "Select 'schema.xml_temporary.xlsx' file", , False)
    Workbooks.Open classeur
    Sheets("schema.xml_temporary").Activate
    derniere_ligne = Range("A" & Rows.Count).End(xlUp).Row
    MsgBox ("Derniere ligne = ") & derniere_ligne
    MsgBox ("The storage of data will begin")
     
    End If
     
    '
    'La ligne d'instruction ci-dessous suffit à elle seule pour remplir le tableau !!
    'La zone mise en mémoire part de la 2ème ligne --> Range("A2") jusqu'à la ligne "derniere_ligne - 1"
    'Le tableau contient 51 colonnes et "derniere_ligne - 1" lignes
    '
    Tab_SCHEMA = Range("A2").Resize(derniere_ligne - 1, 51).Value
    '
    MsgBox ("Data storage of 'schema.xml_temporary.xlsx' file is complete.")
    '
    'Pour debugage uniquement
    '
    'MsgBox ("1  2 = ") & Tab_SCHEMA(1, 2)
    'MsgBox ("1  51 = ") & Tab_SCHEMA(1, 51)
    'MsgBox ("399458  2 = ") & Tab_SCHEMA(399458, 2)
    'MsgBox ("399458  51 = ") & Tab_SCHEMA(399458, 51)
    'MsgBox ("399458  49 = ") & Tab_SCHEMA(399458, 49)
    '
    'Fermer le classeur actif
    '
    ActiveWorkbook.Close SaveChanges:=False
    '
    'Activation du fichier "FOLLOW_UP_TEST.xlsm", on se place dans l'onglet "ECM"
    '
    Windows("FOLLOW_UP_TEST.xlsm").Activate
    Sheets("ECM").Activate
    '
    MsgBox ("Extraction of ID from 'Document title' will begin")
    '
    'Ci-dessous, mis en commentaire car ralentit beaucoup trop le processus
    'statusBarInitial = Application.DisplayStatusBar
    'Application.DisplayStatusBar = True
    '
    'Extraction de l'ID de tous les "Document title"
    '
    ReDim Tab_ID(1 To UBound(Tab_SCHEMA), 10)
    For i = 1 To derniere_ligne - 1 'meme si c'est cohérent pourquoi ne boucle tu pas sur TAB_SCHEMA plutôt ?????????
    '
    'Ci-dessous, mis en commentaire car ralentit beaucoup trop le processus
    'Application.StatusBar = "Calcul en cours... " & i & " / " & derniere_ligne - 1
    '
     str = Tab_SCHEMA(i, 2)
    Tab_ID(i, 1) = ExtraireID(str)
    Tab_ID(i, 2) = Tab_SCHEMA(i, 2)
    Tab_ID(i, 3) = Tab_SCHEMA(i, 3)
    Tab_ID(i, 4) = Tab_SCHEMA(i, 4)
    Tab_ID(i, 5) = Tab_SCHEMA(i, 5)
    Tab_ID(i, 6) = Tab_SCHEMA(i, 22)
    Tab_ID(i, 7) = Tab_SCHEMA(i, 23)
    Tab_ID(i, 8) = Tab_SCHEMA(i, 24)
    Tab_ID(i, 9) = Tab_SCHEMA(i, 25)
    Tab_ID(i, 10) = Tab_SCHEMA(i, 36)
     
    Next
    '
    '
    'Ecriture des résultats dans l'onglet "ECM"
    '
    'For i = 1 To derniere_ligne - 1
     
    'Cells(i + 2, 2) = Tab_ID(i, 1)
    'Cells(i + 2, 3) = Tab_ID(i, 2)
    'Cells(i + 2, 4) = Tab_ID(i, 3)
    'Cells(i + 2, 5) = Tab_ID(i, 4)
    'Cells(i + 2, 6) = Tab_ID(i, 5)
    'Cells(i + 2, 7) = Tab_ID(i, 6)
    'Cells(i + 2, 8) = Tab_ID(i, 7)
    'Cells(i + 2, 9) = Tab_ID(i, 8)
    'Cells(i + 2, 10) = Tab_ID(i, 9)
    'Cells(i + 2, 11) = Tab_ID(i, 10)
     
    'Next
    '
    'Explication de la ligne d'instruction plus bas (remplace la boucle juste au dessus):
    'Sheets("ECM").Cells(ligne3, col2).redimensionnée au (nombre de lignes de (Tab_ID) et nombre de col de (Tab_ID, 2)).value= tout le Tab_ID
    '
    Sheets("ECM").Cells(3, 2).Resize(UBound(Tab_ID), UBound(Tab_ID, 2)).Value = Tab_ID
    '
    Range("A2").Select
    '
    'Ajustement automatique de la largeur des colonnes (colonnes B à K)
    '
    Columns("B:K").Select
    Columns("B:K").EntireColumn.AutoFit
    '
    'Création d'un filtre de la cellule B2 à K2
    '
    Range("B2:K2").Select
    Selection.AutoFilter
    '
    'Affichage de tous les ID sauf si la cellule de la colonne B est vide
    '
    ActiveWorkbook.Worksheets("ECM").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ECM").AutoFilter.Sort.SortFields.Add Key:=Range( _
    "B2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
    xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("ECM").AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
    '
    'Cette ligne d'instruction supprime les données pour lesquelles la colonne B est vide
    '
    ActiveSheet.Range("$B$2:$K$" & [A1]).AutoFilter Field:=1, Criteria1:="<>"
    '
    Range("A2").Select
    '
    MsgBox ("Process completed")
    '
    End Sub
     
    Function ExtraireID(s As String) As String
    Dim id As String
      id = Mid("IDxxxx" & s, InStrRev("IDxxxx" & s, "ID") + 2, 4)  'si pas d'ID on obtient xxxx
      If Format(Val(id), "0000") = id Then ExtraireID = id Else ExtraireID = ""
    End Function
    Cdlt.
    Jérôme

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. Réponses: 3
    Dernier message: 25/08/2011, 11h26
  2. Adapter le format d'une cellule en texte
    Par francky74 dans le forum Macros et VBA Excel
    Réponses: 2
    Dernier message: 22/04/2011, 16h37
  3. Réponses: 2
    Dernier message: 23/11/2010, 21h48
  4. Extraire une partie du texte d'une cellule.
    Par arnold95 dans le forum Macros et VBA Excel
    Réponses: 16
    Dernier message: 28/04/2009, 12h02
  5. extraire un mois d'une cellule texte
    Par plume14600 dans le forum Excel
    Réponses: 3
    Dernier message: 02/11/2008, 15h50

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo