Bonjour à tous!
*Attention Erreur, il ne s'agit pas de l'erreur n°9 mais n°5 ... sorry*
Un macro très intéressante permettant de fouiller un PDF me renvoit l'erreur n°5 : Arugement ou appel de procédure incorrect.
Vous trouverez ci-dessous le code qui permet d'extraire/importer les données depuis le PDF.
Merci beaucoup pour votre aide 😉
Private Sub Extraction()
Dim MaPlage As Range
Dim Macellule As Range
Dim DateActivation As Date
Dim VAL01 As String
Dim PremiereAdresse As String
Dim i As Long
On Error GoTo Erreur
ActiveSheet.Range("1:6").EntireColumn.NumberFormat = "@"
ActiveSheet.Columns(7).EntireColumn.NumberFormat = "m/d/yyyy"
i = 1
Set MaPlage = Worksheets("Feuil2").UsedRange
DateActivation = ExtraireDATE(MaPlage.Find("EDITE LE").Value)
VAL01 = ExtraireVAL01(MaPlage.Find("point :").Value)
With MaPlage
Set Macellule = .Find(What:="appel :", After:=.Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Cells(i, 2) = "VAL00"
Cells(i, 3) = "VAL02"
Cells(i, 4) = "VAL03"
Cells(i, 5) = "VAL04"
Cells(i, 6) = "VAL05"
Cells(i, 7) = "Date Activation"
Cells(i, 8) = "VAL06"
Cells(i, 9) = "VAL07"
Cells(i, 10) = "VAL01"
Cells(i, 11) = "VAL08"
If Not Macellule Is Nothing Then
PremiereAdresse = Macellule.Address
Do
i = i + 1
Cells(i, 2) = ExtraireVAL00(Macellule.Value)
Cells(i, 3) = ExtraireVAL02(Macellule.Offset(7).Value)
Cells(i, 4) = ExtraireVAL03(Macellule.Offset(4).Value)
Cells(i, 5) = ExtraireVAL04(Macellule.Offset(5).Value)
Cells(i, 6) = ExtraireVAL05(Macellule.Offset(6).Value)
Cells(i, 7) = DateActivation
Cells(i, 8) = ExtraireVAL06(Macellule.Value)
Cells(i, 9) = ExtraireVAL07(Macellule.Offset(1).Value)
Cells(i, 10) = VAL01
Cells(i, 11) = ExtraireVAL08(Macellule.Offset(7).Value)
Set Macellule = .FindNext(Macellule)
Loop While Not Macellule Is Nothing And Macellule.Address <> PremiereAdresse
End If
End With
'Nettoyage
Range("A1").EntireColumn.Delete
Set MaPlage = Range("A1").CurrentRegion
MaPlage.Sort "VAL00", , , , , , , xlYes
For Each Macellule In MaPlage.Columns(1).Cells
With Macellule
If .Value = .Offset(1).Value Then
.Offset(1).EntireRow.Delete
.Offset(1).EntireRow.Delete
End If
End With
Next
Range("A1").Select
ActiveSheet.Columns.AutoFit
ActiveWorkbook.Save
Exit Sub
Erreur:
MsgBox Err.Description, vbCritical, "Erreur n° " & Err.Number, Err.HelpFile, Err.HelpContext
End Sub
Function ExtraireDATE(chaine As String) As Date
Dim Jour As String
Dim Mois As String
Dim An As String
Jour = Mid(chaine, InStr(chaine, "/") - 2, 2)
Mois = Mid(chaine, InStr(chaine, "/") + 1, 2)
An = Mid(chaine, InStr(chaine, "/") + 4, 4)
ExtraireDATE = CDate(Jour & "/" & Mois & "/" & An)
End Function
Function ExtraireVAL01(chaine As String) As String
ExtraireVAL01 = Mid(chaine, InStr(chaine, "Liste") + 24, 9)
End Function
Function ExtraireVAL00(chaine As String) As String
Dim temp
temp = Mid(chaine, InStr(chaine, "appel") + 6, 14)
ExtraireVAL00 = Replace(temp, ".", "")
End Function
Function ExtraireVAL06(chaine As String) As String
ExtraireVAL06 = Mid(chaine, InStr(chaine, "VAL06") + 10, 9)
End Function
Function ExtraireVAL02(chaine As String) As String
Dim temp
temp = Mid(chaine, InStr(chaine, "VAL02") + 7, 14)
ExtraireVAL02 = Replace(temp, ".", "")
End Function
Function ExtraireVAL04(chaine As String) As String
ExtraireVAL04 = Mid(chaine, InStr(chaine, "VAL04") + 6, 20)
End Function
Function ExtraireVAL03(chaine As String) As String
ExtraireVAL03 = Mid(chaine, InStr(chaine, "VAL03") + 7, 15)
End Function
Function ExtraireVAL05(chaine As String) As String
ExtraireVAL05 = Mid(chaine, InStr(chaine, "VAL05") + 8, 4)
End Function
Function ExtraireVAL07(chaine As String) As String
ExtraireVAL07 = Mid(chaine, InStr(chaine, "VAL07") + 14, 30)
End Function
Function ExtraireVAL08(chaine As String) As String
ExtraireVAL08 = Mid(chaine, InStr(chaine, "VAL08") + 11, 70)
End Function
Sub ImportPDF()
Dim MyAppID As Variant
Dim i As Long
Dim MontableauPDF As Variant
Dim Cellule_Destination As Range
On Error GoTo Erreur
MontableauPDF = Application.GetOpenFilename("Fichiers pdf (*.pdf),*.pdf", , "Selectionner les fichiers de souscription", , True)
Set MaFeuille = ActiveSheet
Sheets("Feuil2").Activate
ActiveSheet.Cells.Delete
Set Cellule_Destination = Range("A1")
For i = 1 To UBound(MontableauPDF)
MyAppID = Shell("C:\Program Files\Adobe\Acrobat 7.0\Reader\AcroRd32.exe " & Chr(34) & MontableauPDF(i) & Chr(34), vbMaximizedFocus)
AppActivate MyAppID
SendKeys "^a"
SendKeys "^c"
SendKeys "%{F4}"
DoEvents
Cellule_Destination.PasteSpecial xlPasteAll
Set Cellule_Destination = Cellule_Destination.End(xlDown).Offset(1)
Next
Extraction
Exit Sub
Erreur:
MsgBox Err.Description, vbCritical, "Erreur n° " & Err.Number, Err.HelpFile, Err.HelpContext
End Sub
et Joyeuses fêtes!
*Attention Erreur, il ne s'agit pas de l'erreur n°9 mais n°5 ... sorry*
Un macro très intéressante permettant de fouiller un PDF me renvoit l'erreur n°5 : Arugement ou appel de procédure incorrect.
Vous trouverez ci-dessous le code qui permet d'extraire/importer les données depuis le PDF.
Merci beaucoup pour votre aide 😉
Private Sub Extraction()
Dim MaPlage As Range
Dim Macellule As Range
Dim DateActivation As Date
Dim VAL01 As String
Dim PremiereAdresse As String
Dim i As Long
On Error GoTo Erreur
ActiveSheet.Range("1:6").EntireColumn.NumberFormat = "@"
ActiveSheet.Columns(7).EntireColumn.NumberFormat = "m/d/yyyy"
i = 1
Set MaPlage = Worksheets("Feuil2").UsedRange
DateActivation = ExtraireDATE(MaPlage.Find("EDITE LE").Value)
VAL01 = ExtraireVAL01(MaPlage.Find("point :").Value)
With MaPlage
Set Macellule = .Find(What:="appel :", After:=.Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Cells(i, 2) = "VAL00"
Cells(i, 3) = "VAL02"
Cells(i, 4) = "VAL03"
Cells(i, 5) = "VAL04"
Cells(i, 6) = "VAL05"
Cells(i, 7) = "Date Activation"
Cells(i, 8) = "VAL06"
Cells(i, 9) = "VAL07"
Cells(i, 10) = "VAL01"
Cells(i, 11) = "VAL08"
If Not Macellule Is Nothing Then
PremiereAdresse = Macellule.Address
Do
i = i + 1
Cells(i, 2) = ExtraireVAL00(Macellule.Value)
Cells(i, 3) = ExtraireVAL02(Macellule.Offset(7).Value)
Cells(i, 4) = ExtraireVAL03(Macellule.Offset(4).Value)
Cells(i, 5) = ExtraireVAL04(Macellule.Offset(5).Value)
Cells(i, 6) = ExtraireVAL05(Macellule.Offset(6).Value)
Cells(i, 7) = DateActivation
Cells(i, 8) = ExtraireVAL06(Macellule.Value)
Cells(i, 9) = ExtraireVAL07(Macellule.Offset(1).Value)
Cells(i, 10) = VAL01
Cells(i, 11) = ExtraireVAL08(Macellule.Offset(7).Value)
Set Macellule = .FindNext(Macellule)
Loop While Not Macellule Is Nothing And Macellule.Address <> PremiereAdresse
End If
End With
'Nettoyage
Range("A1").EntireColumn.Delete
Set MaPlage = Range("A1").CurrentRegion
MaPlage.Sort "VAL00", , , , , , , xlYes
For Each Macellule In MaPlage.Columns(1).Cells
With Macellule
If .Value = .Offset(1).Value Then
.Offset(1).EntireRow.Delete
.Offset(1).EntireRow.Delete
End If
End With
Next
Range("A1").Select
ActiveSheet.Columns.AutoFit
ActiveWorkbook.Save
Exit Sub
Erreur:
MsgBox Err.Description, vbCritical, "Erreur n° " & Err.Number, Err.HelpFile, Err.HelpContext
End Sub
Function ExtraireDATE(chaine As String) As Date
Dim Jour As String
Dim Mois As String
Dim An As String
Jour = Mid(chaine, InStr(chaine, "/") - 2, 2)
Mois = Mid(chaine, InStr(chaine, "/") + 1, 2)
An = Mid(chaine, InStr(chaine, "/") + 4, 4)
ExtraireDATE = CDate(Jour & "/" & Mois & "/" & An)
End Function
Function ExtraireVAL01(chaine As String) As String
ExtraireVAL01 = Mid(chaine, InStr(chaine, "Liste") + 24, 9)
End Function
Function ExtraireVAL00(chaine As String) As String
Dim temp
temp = Mid(chaine, InStr(chaine, "appel") + 6, 14)
ExtraireVAL00 = Replace(temp, ".", "")
End Function
Function ExtraireVAL06(chaine As String) As String
ExtraireVAL06 = Mid(chaine, InStr(chaine, "VAL06") + 10, 9)
End Function
Function ExtraireVAL02(chaine As String) As String
Dim temp
temp = Mid(chaine, InStr(chaine, "VAL02") + 7, 14)
ExtraireVAL02 = Replace(temp, ".", "")
End Function
Function ExtraireVAL04(chaine As String) As String
ExtraireVAL04 = Mid(chaine, InStr(chaine, "VAL04") + 6, 20)
End Function
Function ExtraireVAL03(chaine As String) As String
ExtraireVAL03 = Mid(chaine, InStr(chaine, "VAL03") + 7, 15)
End Function
Function ExtraireVAL05(chaine As String) As String
ExtraireVAL05 = Mid(chaine, InStr(chaine, "VAL05") + 8, 4)
End Function
Function ExtraireVAL07(chaine As String) As String
ExtraireVAL07 = Mid(chaine, InStr(chaine, "VAL07") + 14, 30)
End Function
Function ExtraireVAL08(chaine As String) As String
ExtraireVAL08 = Mid(chaine, InStr(chaine, "VAL08") + 11, 70)
End Function
Sub ImportPDF()
Dim MyAppID As Variant
Dim i As Long
Dim MontableauPDF As Variant
Dim Cellule_Destination As Range
On Error GoTo Erreur
MontableauPDF = Application.GetOpenFilename("Fichiers pdf (*.pdf),*.pdf", , "Selectionner les fichiers de souscription", , True)
Set MaFeuille = ActiveSheet
Sheets("Feuil2").Activate
ActiveSheet.Cells.Delete
Set Cellule_Destination = Range("A1")
For i = 1 To UBound(MontableauPDF)
MyAppID = Shell("C:\Program Files\Adobe\Acrobat 7.0\Reader\AcroRd32.exe " & Chr(34) & MontableauPDF(i) & Chr(34), vbMaximizedFocus)
AppActivate MyAppID
SendKeys "^a"
SendKeys "^c"
SendKeys "%{F4}"
DoEvents
Cellule_Destination.PasteSpecial xlPasteAll
Set Cellule_Destination = Cellule_Destination.End(xlDown).Offset(1)
Next
Extraction
Exit Sub
Erreur:
MsgBox Err.Description, vbCritical, "Erreur n° " & Err.Number, Err.HelpFile, Err.HelpContext
End Sub
et Joyeuses fêtes!
Dernière édition: