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: