txt to excel

[Kenneth Hobson]

Sorry, I was overthinking it and did not read close enough. This should suffice.

Of course change paths to suit. If those will change a lot, you might want to add input parameters and pass the changing folder paths as needed dynamically from another Sub.

Sub Main()
  ' constants
  ' declarations
  Dim tPath As String, tFile As String, xPath As String, sName As String
  Dim i As Long, A As String, wb As Workbook, t, r As Range
  Dim ws As Worksheet, fso As Object

  '**************** CHANGE PATHS TO SUIT *****************************
  tPath = ThisWorkbook.Path & "\GEONAMES - FILE TEXT\"
  xPath = ThisWorkbook.Path & "\GEONAMES - FILE EXCEL\"
  '**************** END CHANGES **************************************

  Set fso = CreateObject("Scripting.FileSystemObject")
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  ' Title Array
t = Split("GEONAMEID,NAME,ASCIINAME,ALTERNATENAMES,LATITUDE,LONGITUDE,FEATURE CLASS,FEATURE CODE,COUNTRY CODE,CC2,ADMIN1 CODE,ADMIN2 CODE,ADMIN3 CODE,ADMIN4 CODE,POPULATION,ELEVATION,DEM,TIMEZONE,DATE MODIFICATION", ",")
  tFile = Dir(tPath & "*.txt")
  Do Until tFile = ""
    sName = Left(tFile, InStr(tFile, ".") - 1)
    If fso.FileExists(xPath & sName & ".xlsx") Then
      Set wb = Workbooks.Open(xPath & sName & ".xlsx")
      If Not WorkSheetExists(sName, wb.Name) Then
        wb.Close False
        GoTo Cycle
      End If
      Set ws = wb.Worksheets(sName)
      ws.UsedRange.Clear
      Else
        Set wb = Workbooks.Add(xlWBATWorksheet)
        Set ws = wb.Worksheets(1)
        ws.Name = sName
    End If

    'Let user know what file is being processed.
    Application.ScreenUpdating = True
    Application.StatusBar = "Processing " & sName & "..."
    Application.ScreenUpdating = False
    ' text file
  With ws.QueryTables.Add(Connection:="TEXT;" & tPath & _
      tFile, Destination:=Range("A2"))
      '.Name = ws.Name
      .FieldNames = True
      .RowNumbers = False
      .FillAdjacentFormulas = False
      .PreserveFormatting = True
      .RefreshOnFileOpen = False
      .RefreshStyle = xlInsertDeleteCells
      .SavePassword = False
      .SaveData = True
      .AdjustColumnWidth = True
      .RefreshPeriod = 0
      .TextFilePromptOnRefresh = False
      .TextFilePlatform = 65001
      .TextFileStartRow = 1
      .TextFileParseType = xlDelimited
      .TextFileTextQualifier = xlTextQualifierNone
      .TextFileConsecutiveDelimiter = False
      .TextFileTabDelimiter = True
      .TextFileSemicolonDelimiter = False
      .TextFileCommaDelimiter = False
      .TextFileSpaceDelimiter = False
      .TextFileColumnDataTypes = _
        Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
      .TextFileTrailingMinusNumbers = True
      .Refresh BackgroundQuery:=False
    End With
    With ws.QueryTables
      .Item(.Count).Delete
    End With
  
    With ws.Cells
      .HorizontalAlignment = xlLeft
      .VerticalAlignment = xlBottom
      .WrapText = False
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = False
    End With
  ' titles
  With ws.Range("A1").Resize(, UBound(t) + 1)
      .Value = t
      .AutoFilter  'Turn on autofilter
      .Font.Bold = True
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .EntireColumn.AutoFit
      .Interior.Color = vbYellow
    End With
  
    ' Save and close wb as xlsx
    Application.DisplayAlerts = False 'Need to save over file maybe.
    wb.SaveAs xPath & sName & ".xlsx", xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    wb.Close False
Cycle:
    ' cycle
  tFile = Dir()
  Loop

  ' end
  ThisWorkbook.Worksheets(1).Activate
  Range("A1").Select
  Beep
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  Application.StatusBar = False
  Set fso = Nothing
End Sub

'WorkSheetExists in a workbook:
Function WorkSheetExists(sWorkSheet As String, Optional sWorkbook As String = "") As Boolean
  Dim ws As Worksheet, wb As Workbook
  On Error GoTo notExists
  If sWorkbook = "" Then
    Set wb = ActiveWorkbook
    Else
    Set wb = Workbooks(sWorkbook) 'sWorkbook must be open already.  e.g. ken.xlsm, not x:\ken.xlsm.
  End If
  Set ws = wb.Worksheets(sWorkSheet)
  WorkSheetExists = True
  Exit Function
notExists:
  WorkSheetExists = False
End Function

 

[claudia80]

Thank you mr hobson, is the macro right now? what I was looking for. You are not as distracted as you wrote in previous messages, you are committed to helping as many people as few do.