Macro for Import Text file and convert it in Excel

[AVG123]

Today i am facing a problem...........i want to make many macro and try it on my Text file but nothing is going to right........

Below code i got from Recording Macro.........Below code including Text File opening + Set Break Line + Sort on COL-A and more more more................

i am looking for a solution, i want to make it dynamically......means that when i click on Commandbutton1, a open dialog box should be open like CTRL+O, where i choose my TextFile from my Desktop and it convert in Excel.........
Please see the excel file's Sheet Deletion

I am attaching 2files i.e. 1. TextFile and 2. Excel File, please see

Sub Macro4()
'
' Macro4 Macro
'

'
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\Gyan Verma\Desktop\July-2018 Advance\slgt0718.prn", Destination _
        :=Range("$A$1"))
        .CommandType = 0
        .Name = "slgt0718"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(8, 10, 8, 20, 25, 7)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Cells.Select
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add Key:=Range("A1:A122") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet4").Sort
        .SetRange Range("A1:G122")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWindow.SmallScroll Down:=48
    Rows("50:50").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    Selection.End(xlUp).Select
    Selection.End(xlUp).Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "S.No."
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Sheet_Code"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "E_Code"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "E_Name"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Designation"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "AMT"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Department"
    Selection.End(xlToLeft).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Font.Bold = True
    Cells.Select
    Cells.EntireColumn.AutoFit
    Selection.End(xlToLeft).Select
    Selection.End(xlUp).Select
    Sheets("Sheet4").Select
    Sheets("Sheet4").Name = "Deletion"
End Sub

[AVG123]

After some amendments the below code is working for me but some bugs in it.......i want anyone can help to correct below mentioned code, please see:-

1. We are in Sheet1, When i click on Commandbutton1_Click(), a open dialog box will be open, if i click on Cancel Button it automatically import and convert the text file which you will see in the "TEXT;C:\Users\Gyan Verma\Desktop\July-2018 Advance\slgb0718.prn"

I want it should be worked on my choice of Text File and convert it in excel, so i want to correct this command line

by default it is always convert slgb0718.prn file

2. We are also in Sheet1, Click on Commandbutton1_Click(), now it create a sheet namely "Deletion" in existing workbook and data of Textfile should be in this "Deletion" Sheet.

Private Sub CommandButton1_Click()
' Macro1 Macro
'

fname1 = Application.GetOpenFilename()
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\Gyan Verma\Desktop\July-2018 Advance\slgb0718.prn", _
        Destination:=Range("$A$1"))
        '.CommandType = 0
        .Name = "fname1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(8, 10, 8, 20, 25, 7)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

Please correct it

[AVG123]

please see the below code it gives me error on .Refresh BackgroundQuery:=False

Private Sub CommandButton1_Click()
' Macro1 Macro
'
'ChDir "C:\Users\Gyan Verma\Desktop\"
fname2 = Application.GetOpenFilename()
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\Gyan Verma\Desktop\July-2018 Advance", _
        Destination:=Range("$A$1"))
        '.CommandType = 0
        .Name = "fname2"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(8, 10, 8, 20, 25, 7)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
        
    End With
End Sub

[Alf]

I found this code at "StackOverflow" made by a person named "Omar" so all credit goes to him. It seems that you can use multi selection in his macro.

I've added some bits and pieces at the end to organize the data to get the same result in your uploaded file. The problem I had was if the persons name was 15 characters long. That made part of the name spill over from the D column to the E column so the macro checks for this and writes a warning on the same row but in the G column.

Sub Import()
    
    Dim nRow            As Long
    Dim sExtension      As String
    Dim oFolder         As FileDialog
    Dim vSelectedItem   As Variant
    Dim cell As Range
    Dim i As Integer
    Dim j As Integer
    
    
    Application.ScreenUpdating = False

    Set oFolder = Application.FileDialog(msoFileDialogOpen)

    
    With oFolder
       
        .AllowMultiSelect = True
       
        If .Show = -1 Then

    sExtension = Dir("*.txt")

   Range("B3").Activate
 
    For Each vSelectedItem In .SelectedItems

        nRow = Range("A1").End(xlUp).Offset(1, 0).Row

        With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;" & sExtension, Destination:=Range("$A$" & nRow))
            .Name = sExtension
            .FieldNames = True
            .RowNumbers = False
             .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 850
            .TextFileStartRow = 1
            .TextFileParseType = xlFixedWidth
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
            .TextFileFixedColumnWidths = Array(7, 9, 8, 17, 24, 7, 5, 26)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
            sExtension = Dir
    Next
           
            Else
            End If
    End With

    Application.ScreenUpdating = True

    Set oFolder = Nothing
    
   i = Range("A" & Rows.Count).End(xlUp).Row

For j = i To 2 Step -1

If IsNumeric(Cells(j, 1).Value) Then
  Else
       Rows(j).EntireRow.Delete
End If

If Cells(j, 1) = "" Then
    Rows(j).EntireRow.Delete
End If

Next

Columns(6).Delete
     
Range("A1") = "S.No."
Range("B1") = "Sheet_Code"
Range("C1") = "E_Code"
Range("D1") = "E_Name"
Range("E1") = "Designation"
Range("F1") = "AMT"
Range("G1") = "Department"

Range("A1:G1").Font.Bold = True

For Each cell In Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row)

If Len(cell) >= 15 Then
    cell.Offset(0, 5) = "Check name in D column, could be cut off!"
End If

Next
     
End Sub

Alf

[AVG123]

Thankyou sir it is working flawless

[Alf]

You are welcome and thanks for feedback. As this seems to have solved your problem could you please mark thread "Solved" as per forum rules.

Alf

To mark your thread solved do the following:
-Go to the top of the first post
-Select Thread Tools
-Select Mark thread as Solved

[AVG123]

Thanks for help...........
Sir it is working fine but some issue are not solved in this code:-
my folder have "slgb0818.prn", "slgb1217.prn"
and it is always working on "slgb0818.prn" file because it have slgb0...prn in file name (Please see bold part is 0), if i will change my second file name from "slgb1217.prn" to "slgb0217.prn" then code is working. if file name contain 5th character 0 then it is working otherwise not working..........
and same case in .TXT file

2. i want to work on multiple extensions i.e. ".TXT",".PRN" how to add second extension in the code

[Alf]

Ok I've changed the code a bit and now you see both ".txt" and ".prn" files and macro runs without problems. But as you have not uploaded your "slgb0718.png" file I've renamed the "slgt718.txt" you uploaded to a number of different name vise that is png files.

Sub Import()
    
    Dim nRow            As Long
    Dim sExtension      As String
    Dim oFolder         As FileDialog
    Dim vSelectedItem   As Variant
    Dim cell As Range
    Dim i As Integer
    Dim j As Integer
    
    
    Application.ScreenUpdating = False

    Set oFolder = Application.FileDialog(msoFileDialogOpen)

    
    With oFolder
       
        .AllowMultiSelect = True
       
        If .Show = -1 Then

    sExtension = Dir("*.txt, *.prn")

   Range("B3").Activate
 
    For Each vSelectedItem In .SelectedItems

        nRow = Range("A1").End(xlUp).Offset(1, 0).Row

        With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;" & vSelectedItem, Destination:=Range("$A$" & nRow))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(7, 9, 8, 21, 21, 6, 5, 26)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False

    End With
         
          vSelectedItem = Dir("*.txt, *.prn")
        
    Next

            Else
            
            End If
            
    End With

    Application.ScreenUpdating = True

    Set oFolder = Nothing
    
   i = Range("A" & Rows.Count).End(xlUp).Row

For j = i To 2 Step -1

If IsNumeric(Cells(j, 1).Value) Then
  Else
       Rows(j).EntireRow.Delete
End If

If Cells(j, 1) = "" Then
    Rows(j).EntireRow.Delete
End If

Next

Columns(6).Delete
     
Range("A1") = "S.No."
Range("B1") = "Sheet_Code"
Range("C1") = "E_Code"
Range("D1") = "E_Name"
Range("E1") = "Designation"
Range("F1") = "AMT"
Range("G1") = "Department"

Range("A1:G1").Font.Bold = True

For Each cell In Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row)

If Len(cell) >= 18 Then
    cell.Offset(0, 5) = "Check name in D column, could be cut off!"
End If

Next
     
End Sub

Alf