Consulting

Results 1 to 3 of 3

Thread: Acceleration of working Script. Ideas?

  1. #1
    VBAX Newbie
    Joined
    Sep 2016
    Posts
    1
    Location

    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!

    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

  2. #2
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    A suggestion

            If ErrorCheck > 0 Then GoTo NextFile
                Dim r As Long, LastRow As Long, LastColumn As Long 'Always use Longs for Row and Column Counters
                 
                 ReDim Fields: Redim Fields2 'Clear the Arrays 'Declare Fields2 as  Variant above!
                 
                    Fields = Columns(3).Value 
                    Answers = Columns(4).Value 
                 
                ActiveWorkbook.Close SaveChanges:=False 'closes XFDF           
                 
                 
                With Workbooks(DatasetsFilename).Sheets("datasets") 
                    LastRow = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 
                     
                    .Cells(LastRow, 1).Value = Date 
                     Fields2 = Range(.Range("B2"), .Cells(2, Columns.Count).End(xlToLeft)).Value 
                     
                    For r = LBound (Fields) to Ubound(Fields) 
                       If  Fields(r)  = Fields2(r) Then  .Cells(LastRow, r + 2) = Answers(r) 'Check Column assignment math
                    Next r 
                End With 
                 
            'End If 
    NextFile:
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  3. #3
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,814
    Location
    A slightly faster version
    Dim NextAnswers As Range
    
    With Workbooks(DatasetsFilename).Sheets("datasets") 
        LastRow = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 
        LastColumn = .UsedRange.SpecialCells(xlCellTypeLastCell).Column 
    
       Set NextAnswers = Range(.Range("B" & LastRow), .Cells(LastRow, LastColumn))  
        NextAnswers(r) = Answers(r)
        .Cells(LastRow, 1).Value = Date 
        Fields2 = Range(.Range("B2"), .Cells(2, LastColumn).End(xlToLeft)).Value 
         
       
     For r = LBound (Fields) To Ubound(Fields) 
            If  Fields(r) <> Fields2(r) Then  NextAnswers(r) = ""
        Next r 
    End With
    The absolute fastest way is the lessor of Question matches and mismatches. Which one accesses the Sheet less often.

    Fastest yet will be when someone else gets the data without opening the book. My suggestions will only speed up the read/write operation.
    Last edited by SamT; 09-24-2016 at 12:24 PM.
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •