Slow running VBA! Help a newbie.

amitkrb

New Member
Joined
Jul 31, 2012
Messages
6
Hi,
I am a newbie to VBA. With the help of this excellent forum; I was able to write a VBA code.
Basically, I have to select a folder which contains only txt files and import all those into one. Further I have to delete all rows which are blank or contain certain data.
I have used the below code.

Code:
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
        (ByVal dwDesiredAccess As Long, _
        ByVal bInheritHandle As Long, _
        ByVal dwProcessId As Long) As Long
    
    Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
        (ByVal hProcess As Long, _
        lpExitCode As Long) As Long
#Else
    Private Declare Function OpenProcess Lib "kernel32" _
        (ByVal dwDesiredAccess As Long, _
        ByVal bInheritHandle As Long, _
        ByVal dwProcessId As Long) As Long
    
    Private Declare Function GetExitCodeProcess Lib "kernel32" _
        (ByVal hProcess As Long, _
        lpExitCode As Long) As Long
#End If


Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103


Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
    Dim hProg As Long
    Dim hProcess As Long, ExitCode As Long
    'fill in the missing parameter and execute the program
    If IsMissing(WindowState) Then WindowState = 1
    hProg = Shell(PathName, WindowState)
    'hProg is a "process ID under Win32. To get the process handle:
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
    Do
        'populate Exitcode variable
        GetExitCodeProcess hProcess, ExitCode
        DoEvents
    Loop While ExitCode = STILL_ACTIVE
End Sub


Sub Merge_txt_Files()
    Dim BatFileName As String
    Dim TXTFileName As String
    Dim XLSFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim DefPath As String
    Dim Wb As Workbook
    Dim oApp As Object
    Dim oFolder
    Dim foldername

    'Create two temporary file names
    BatFileName = Environ("Temp") & _
            "\CollecttxtData" & Format(Now, "dd-mm-yy-h-mm-ss") & ".bat"
    TXTFileName = Environ("Temp") & _
            "\Alltxt" & Format(Now, "dd-mm-yy-h-mm-ss") & ".txt"

    'Folder where you want to save the Excel file
    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    'Set the extension and file format
    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007 or higher
        FileExtStr = ".xlsx": FileFormatNum = 51
        'If you want to save as xls(97-2003 format) in 2007 use
        'FileExtStr = ".xls": FileFormatNum = 56
    End If

    'Name of the Excel file with a date/time stamp
    XLSFileName = DefPath & "Mastertxt " & _
                  Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr

    'Browse to the folder with txt files
    Set oApp = CreateObject("Shell.Application")
    Set oFolder = oApp.BrowseForFolder(0, "Select folder with txt files", 512)
    If Not oFolder Is Nothing Then
        foldername = oFolder.Self.Path
        If Right(foldername, 1) <> "\" Then
            foldername = foldername & "\"
        End If

        'Create the bat file
        Open BatFileName For Output As #1
        Print #1, "Copy " & Chr(34) & foldername & "*.txt" _
                & Chr(34) & " " & TXTFileName
        Close #1

        'Run the Bat file to collect all data from the txt files into a TXT file
        ShellAndWait BatFileName, 0
        If Dir(TXTFileName) = "" Then
            MsgBox "There are no txt files in this folder"
            Kill BatFileName
            Exit Sub
        End If

        'Open the TXT file in Excel
        Application.ScreenUpdating = False
        Workbooks.OpenText Filename:=TXTFileName, Origin:=xlWindows, StartRow _
                :=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, _
                Space:=False, Other:=True, OtherChar:="|"

        'Save text file as a Excel file
        Set Wb = ActiveWorkbook
        



'This line might be very slow
With ActiveSheet.Range("A:A")
    .Value = .Value
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With





With ActiveSheet
    .AutoFilterMode = False
    With Range("a1", Range("a" & Rows.Count).End(xlUp))
        .AutoFilter 1, "*List of daily Imports*"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
End With

With ActiveSheet
    .AutoFilterMode = False
    With Range("a1", Range("a" & Rows.Count).End(xlUp))
        .AutoFilter 1, "*Port or country of origin*"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
End With
        
        
        
        Application.DisplayAlerts = False
        Wb.SaveAs Filename:=XLSFileName, FileFormat:=FileFormatNum
        Application.DisplayAlerts = True

        Wb.Close savechanges:=False
        
       
        
        MsgBox "You find the Excel file here: " & vbNewLine & XLSFileName

        'Delete the bat and text file you temporary used
        Kill BatFileName
        Kill TXTFileName

        Application.ScreenUpdating = True
    End If
End Sub


This code is very slow and is basically a amalgamation of different codes I found on internet.
Probably the code which deletes entire blank rows. That code probably searches through all 1 million rows.
ps: My sheet contains blank rows in plenty in between datas.

Give some tips on improving my code and making me look good in front of my boss!!:cool::)
Please help ! Thanks!!!
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
are you only going to one folder with many text files

are you importing as csvs or plain text files

do you place each such file at for example row 1000, next one row 2000 ?
 
Upvote 0
Yes. Only single folder for all text files. I am importing txt, not csvs.
Also, if txt file n is at row m and contains 100 rows; the next txt file n+1 will start at m+100 and so on. Txt files can have any number of rows.

The code above probably works; only it's slow. Around 250,000 rows are created from extracted txt files. So pretty time consuming. Any way to optimise?
Thanks a lot!!!!
 
Upvote 0

Forum statistics

Threads
1,213,530
Messages
6,114,163
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top