Acceleration of working Script. Ideas?
Hi all,
I would like to share a script of mine with you. It handles .xfdf files, which are the export of PDF forms. Intention was to merge all exports in one excel sheet. This works fine, but ...
... the process of opening such a file is pretty time costing. I have to proceed about 300 files and running the script takes more than 30 minutes.
I hope someone does have an idea, how I can speed things up. Thanks in advance!
Code:
Option Explicit
Dim DatasetsFilename As String 'variables for opening the .xfdf
Dim Path As String, Filename As String, iRow As Long
Dim AppShell As Object 'variables for choosing the folder-path
Dim BrowseDir As Variant
Dim strQuelle As String 'variables for moving the used files
Dim strZiel As String
Dim objFSO As Object
Dim i, c As Integer
Sub Dataset_import_v2()
Application.ScreenUpdating = False
'Filedialogue where you can choose the folder of your files
On Error GoTo ErrorHandler_NoFolderSelected
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
Path = BrowseDir.items().Item().Path & "\" 'path of .xfdf which you've choosen before
Filename = Dir(Path & "*.xfdf") 'all files in respective path of type .xfdf independent from name
DatasetsFilename = ActiveWorkbook.Name
Dim Fields(), Answers() As String
Dim xfdfcounter As Integer
xfdfcounter = 0
'Open each XFDF and extract Answers
Do While Filename <> ""
Dim ErrorCheck As Integer
ErrorCheck = 0
On Error GoTo ErrorHandler_OpenXML
'opens one workbook in respective path and copies the respective range
Workbooks.OpenXML Filename:=Path & Filename, LoadOption:=xlXmlLoadImportToList
If ErrorCheck < 1 Then
Dim r, c, LastRow, LastColumn As Integer
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
ReDim Fields(1 To LastRow - 1), Answers(1 To LastRow - 1) As String
For r = 2 To LastRow
Fields(r - 1) = Cells(r, 3).Value
Answers(r - 1) = Cells(r, 4).Value
Next r
ActiveWorkbook.Close SaveChanges:=False 'closes XFDF
With Workbooks(DatasetsFilename).Sheets("datasets")
LastRow = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
LastColumn = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
.Cells(LastRow, 1).Value = Date
For c = 2 To LastColumn
For r = 1 To UBound(Fields)
If .Cells(2, c).Value = Fields(r) Then
.Cells(LastRow, c).Value = Answers(r)
End If
Next r
Next c
End With
End If
Filename = Dir()
xfdfcounter = xfdfcounter + 1
Debug.Print xfdfcounter
Loop
Debug.Print xfdfcounter
'moves all XFDF files to a seperate folder
strQuelle = Path & "*.xfdf"
If Dir(strQuelle) = "" Then MsgBox "No XFDF file to proceed in this folder.": Exit Sub
strZiel = Path & "\collected\" 'folder where the files are copied to
'creates the destination folder if it doesn't exist
On Error Resume Next
MkDir strZiel
On Error GoTo 0
'moving the files to the folder
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.MoveFile strQuelle, strZiel
Set objFSO = Nothing
Application.ScreenUpdating = True
ErrorHandler_NoFolderSelected:
Exit Sub
ErrorHandler_OpenXML:
ErrorCheck = 1
Resume Next
End Sub
Sub Folder_v2()
Dim AppShell As Object
Dim BrowseDir As Variant
Dim Pfad As String
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
On Error Resume Next
Pfad = BrowseDir.items().Item().Path
If Pfad = "" Then Exit Sub
On Error GoTo 0
End Sub
