Discussion :

[Camil95Rob]

Bonjour à tous,

je souhaiterais améliorer un code que j'ai mis au point en compilant des morceaux trouvés sur internet.
Actuellement, ce code permet d'ouvrir une boîte de dialogue, de sélectionner un fichier PDF, de l'ouvrir, de copier son contenu dans un nouvel onglet et de le fermer.

Aujourd'hui, j'aimerais que ce code permette de sélectionner plusieurs fichier PDF en même temps, et de copier le contenu dans un nouvelle onglet pour chaque PDF (un PDF sélectionné = un nouvel onglet et son contenu).

Pour vous donner du contexte, tous les jours, je dois traiter une quinzaine de comptes-rendus d'analyses sanguines. Une fois que le contenu des PDF est copié dans ce fichier Excel, je mettrai en place des formules pour récupérer les données et repérer les anomalies.

Pour info :
Le fichier Excel et les PDF se situent à chaque fois dans le même dossier.
La multi-sélection est actuellement désactivée en bas de code.
Ce code désactive mon clavier numérique pour une raison que j'ignore...

Savez-vous s'il est possible de réaliser cette manip ?

Merci par avance pour votre aide, et pour vos conseils.

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
 
Sub test()
Dim CheminEtTypeFichier As String, Fichier As String
Dim sFichier As String
Dim sAcro As String
Dim ong As String
 
    With Sheets("Param")
        .Activate
        .Cells.Clear
    End With
 
'Variable à définir : Le chemin par défaut
CheminEtTypeFichier = "C:\Users\...\Desktop\...\Analyses sanguines"
 
Fichier = BrowseFile(CheminEtTypeFichier)
 
    If Fichier <> "" Then
        'MsgBox "Nom du fichier sélectionné : """
        sFichier = Split(Fichier, "")(UBound(Split(Fichier, "")))
        sAcro = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
 
        Shell sAcro, vbNormalFocus
 
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys "^o"
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys sFichier
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys "{ENTER}"
        Application.Wait (Now + TimeValue("0:00:01"))
 
        SendKeys "^a"
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys "^c"
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys "^q"
        Application.Wait (Now + TimeValue("0:00:01"))
 
        DoEvents
 
        Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count) 'créer un nouvel onglet en dernière position
        ong = (Sheets.Count) - 1
        ActiveSheet.Name = "0" & ong
 
        With ActiveSheet
            .Range("A1").Select
            .Activate
            .Paste
 
        End With
    Else
        MsgBox "Aucune sélection a été effectuée."
    End If
End Sub
 
Function BrowseFile(CheminEtTypeFichier) As String
    With Application.FileDialog(msoFileDialogFilePicker)
        'Définit un titre pour la boîte de dialogue
        .Title = "Choisir le fichier"
        'Empêcher la multi-sélection
        .AllowMultiSelect = False
        'Répertoire par défaut suivi du type de fichier par défaut
        .InitialFileName = CheminEtTypeFichier
        'Efface les filtres existants.
        .Filters.Clear
        'Indique le type d'affichage dans la boîte de dialogue
        '(exemple visualisation des propriétés)
        .InitialView = msoFileDialogViewProperties
        'Affiche la boîte de dialogue
        .Show
        If .SelectedItems.Count > 0 Then
            BrowseFile = .SelectedItems(1)
        Else
            BrowseFile = ""
        End If
    End With
End Function

[ChristianBosch]

Salut si j'ai bien compris :

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
Function ListeFichiers(repertoire As String) As Variant
                '!!!!!!!!!!!!Nécessite d'activer la référence "Microsoft Scripting RunTime"!!!!!!!!!!
 
'déclaration des variables
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim MyTab() As Variant
Dim i As Long
 
i = 0
 
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(repertoire)
 
    For Each FileItem In SourceFolder.Files
        If UCase(Right(FileItem.Name, 3)) = UCase("pdf") Then
            i = i + 1
            ReDim Preserve MyTab(1 To i)
            MyTab(i) = FileItem.Path
        End If
    Next FileItem
ListeFichiers = MyTab
End Function
 
Sub Main()
Dim MyTab() As Variant
Dim Sh As Worksheet
Dim PDFpath As String
Dim i As Integer
 
MyTab=ListeFichiers("le chemin du repertoire")
 
For i = LBound(MyTab) To UBound(MyTab)
    PDFpath = MyTab(i)
    Set Sh = ThisWorkbook.Worksheets.Add
    'ici la séquence d'ouverture et de copie des donnees su pdf avec les sendkeys
    With Sh
        .Range("A1").Select
        .Activate
        .Paste
    End With
Next i
End Sub

A adapter en fonction de tes besoins, n'oublie pas d'activer la reference indiquée dans la fonction.

CB

[Camil95Rob]

Bonsoir, merci beaucoup pour votre retour !
Cela fonctionne parfaitement, et me permettra de gagner beaucoup de temps dans l'année

Voici le code tel que je vais l'utiliser pour ceux qui en auraient besoin un jour :

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
 
Function ListeFichiers(repertoire As String) As Variant
                '!!!!!!!!!!!!Nécessite d'activer la référence "Microsoft Scripting RunTime"!!!!!!!!!!
 
'déclaration des variables
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim sAcro As String
Dim MyTab() As Variant
Dim i As Long
 
i = 0
 
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(repertoire)
 
    For Each FileItem In SourceFolder.Files
        If UCase(Right(FileItem.Name, 3)) = UCase("pdf") Then
            i = i + 1
            ReDim Preserve MyTab(1 To i)
            MyTab(i) = FileItem.Path
        End If
    Next FileItem
ListeFichiers = MyTab
End Function
 
Sub Main()
Dim MyTab() As Variant
Dim Sh As Worksheet
Dim PDFpath As String
Dim i As Integer
 
MyTab = ListeFichiers("C:\Users\crobert\Desktop\Test FJ\Analyses sanguines - 2")
 
For i = LBound(MyTab) To UBound(MyTab)
    PDFpath = MyTab(i)
    Set Sh = ThisWorkbook.Worksheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
    ActiveSheet.Name = "0" & i
 
 
    'ici la séquence d'ouverture et de copie des donnees du pdf avec les sendkeys
    sAcro = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
 
        Shell sAcro, vbNormalFocus
 
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys "^o"
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys PDFpath
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys "{ENTER}"
        Application.Wait (Now + TimeValue("0:00:01"))
 
        SendKeys "^a"
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys "^c"
        Application.Wait (Now + TimeValue("0:00:01"))
        SendKeys "^q"
        Application.Wait (Now + TimeValue("0:00:01"))
 
        DoEvents
 
    With Sh
        .Range("A1").Select
        .Activate
        .Paste
    End With
Next i
End Sub

Merci beaucoup !