XL 2019 Formule qui disparaît

[telemarrk]

Bonjour,

Je vous sollicite de nouveau car je bloque sur une formule.

Il y a quelques semaines le membre JOB75 ainsique d'autres (Hasco, Deadpool-CC et chris) m'ont aidé sur la réalisation d'un tableau avec du code vba.

J'ai ajouté une formule en C2 "=GAUCHE(A2;TROUVE("-";A2)-1)" étiré sur d'autres lignes, mais quand je ferme mon fichier et que je l'ouvre à nouveau la formule a disparue.

Pourquoi ? est-ce le code VBA qui fait ça ?

Merci

 

[sousou]

Bonjour telemark
essaie comme-ceci
If .Rows.Count > 1 Then .Rows(1).Resize(.Rows.Count - 1).Delete xlUp 'RAZ

 

[job75]

Bonjour telemarrk, sousou,

J'ai ajouté une formule en C2 "=GAUCHE(A2;TROUVE("-";A2)-1)" étiré sur d'autres lignes, mais quand je ferme mon fichier et que je l'ouvre à nouveau la formule a disparue.

Pourquoi ? est-ce le code VBA qui fait ça ?

Bien sûr puisqu'on efface la 1ère ligne de Tableau1 et supprime les autres.

Mais il suffit de faire créer la formule en C2 par la macro :

Private Sub Workbook_Activate()
Dim chemin$, fichier$, lig&
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.pdf")
Application.ScreenUpdating = False
With [Tableau1] 'tableau structuré
    .Cells(1).Hyperlinks.Delete
    .Rows(1).ClearContents 'RAZ
    .Cells(1, 3) = "=LEFT(RC[-2],FIND(""-"",RC[-2])-1)" 'crée la formule
    If .Rows.Count > 1 Then .Rows(2).Resize(.Rows.Count - 1).Delete xlUp 'RAZ
    While fichier <> ""
        lig = lig + 1
        .Cells(lig, 1) = fichier
        .Cells(lig, 2) = CDate(Format(FileDateTime(chemin & fichier), "dd/mm/yyyy"))
        .Hyperlinks.Add .Cells(lig, 1), Address:=chemin & fichier
        fichier = Dir
    Wend
End With
End Sub

A+

 

[job75]

On peut aussi ne pas toucher à la formule en C2 et n'effacer que A2 et B2 :

Private Sub Workbook_Activate()
Dim chemin$, fichier$, lig&
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.pdf")
Application.ScreenUpdating = False
With [Tableau1] 'tableau structuré
    .Cells(1).Hyperlinks.Delete
    .Cells(1).Resize(, 2).ClearContents 'RAZ de 2 cellules
    .Rows(1).VerticalAlignment = xlCenter
    If .Rows.Count > 1 Then .Rows(2).Resize(.Rows.Count - 1).Delete xlUp 'RAZ
    While fichier <> ""
        lig = lig + 1
        .Cells(lig, 1) = fichier
        .Cells(lig, 2) = CDate(Format(FileDateTime(chemin & fichier), "dd/mm/yyyy"))
        .Hyperlinks.Add .Cells(lig, 1), Address:=chemin & fichier
        fichier = Dir
    Wend
End With
End Sub

 

[telemarrk]

Merci à vous.

Cela fonctionne. Par contre, je viens de le modifier en y ajoutant deux colonnes.
Lorsque je quitte après avoir mis des "OK" dans ses deux colonnes, il ne garde que la première ligne.

Je suis désolé de vous embêter avec cela mais je suis nulle en VBA.

 

[telemarrk]

OK, c'est ce que j'avais fait au départ.

Merci pour ta patience et ton aide

 

[job75]

J'ai supprimé mon message. il ne réglait pas le problème.

Les choses se compliquent mais on y arrive, voici la nouvelle macro :

Private Sub Workbook_Activate()
Dim chemin$, fichier$, col1%, col2%, P As Range, lig&, v As Variant
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.pdf") '1er fichier du dossier
col1 = 4 'colonne des ok
col2 = 5 'colonne des ok
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'pour la suppression de feuille
With [Tableau1] 'tableau structuré
    Worksheets.Add Before:=Me.Sheets(1) 'nouvelle feuille auxiliaire
    .Copy ActiveSheet.[A1] 'copie-colle le tableau
    Set P = ActiveSheet.UsedRange
    .Cells(1).Hyperlinks.Delete
    Union(.Cells(1).Resize(, 2), .Cells(1, col1), .Cells(1, col2)).ClearContents 'RAZ de 4 cellules
    .Rows(1).VerticalAlignment = xlCenter
    If .Rows.Count > 1 Then .Rows(2).Resize(.Rows.Count - 1).Delete xlUp 'RAZ
    While fichier <> ""
        lig = lig + 1
        .Cells(lig, 1) = fichier
        .Cells(lig, 2) = CDate(Format(FileDateTime(chemin & fichier), "dd/mm/yyyy"))
        v = Application.VLookup(fichier, P, col1, 0) 'RECHERCHEV
        If Not IsError(v) Then .Cells(lig, col1) = v
        v = Application.VLookup(fichier, P, col2, 0) 'RECHERCHEV
        If Not IsError(v) Then .Cells(lig, col2) = v
        .Hyperlinks.Add .Cells(lig, 1), Address:=chemin & fichier
        fichier = Dir 'fichier suivant
    Wend
    Me.Sheets(1).Delete 'supprime la feuille auxiliaire
End With
End Sub

 

[telemarrk]

Bonjour JOB75,

Superbe

Une dernière question, sur la feuille "Accueil" j'ai mis les mentions (Factures à traiter et transmises), peut-on en cliquant sur "factures à traiter" avoir que les factures sur la feuille "factures" qui concernent le service cité en F18 sur la page d'accueil.

Merci

 

[job75]

Bonjour telemarrk,

Voyez ce fichier (2) et la macro dans le code de la feuille "Accueil" :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [E20]) Is Nothing Then Exit Sub
Dim critere$, i&
Cancel = True
critere = UCase([F18])
With [Tableau1]
    .Rows.Hidden = False 'affiche toutes les lignes
    If critere <> "" Then
        For i = 1 To .Rows.Count
            If UCase(CStr(.Cells(i, 3))) <> critere Then .Rows(i).Hidden = True 'masque la ligne
        Next
    End If
End With
End Sub

Les lignes de Tableau1 ne sont pas supprimées mais seulement masquées pour conserver les "ok".

A+

 

[telemarrk]

Bonjour Job75

Merci c'est parfait

Je te souhaite un joyeux noël à toi et ta famille

@+