1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  3. When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

txt to excel

Discussion in 'VBA Macros' started by claudia80, Sep 30, 2017.

  1. claudia80

    claudia80 Member

    Messages:
    34
    Hello
    I need your help.
    I would like to include in the excel file "GEONAMES - EXTRACT AND SETTING" a macro that converts the file text contained in the "GEONAMES - FILE TEXT" folder into excel files that will have the same text file names and will be placed in the "GEONAMES - FILE EXCEL ".
    When converting Excel files, i need:
    1) Format columns as text
    2) Provide conversion with character encoding 65001, utf-8;
    3) Foresee the alignment to the left of the data contained in the columns;
    4) Insert the following column headers into the file:

    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

    5) Make sure the Excel excel text does not change the geographic coordinates columns as they are in the text file (I noticed that transformation can turn coordinates into numbers).
    For conversion code and points from number 1 to number 3 you may see the macro contained in the file you see here:
    Code (vb):

    Option Explicit


    Sub ImportTextFileTabSeparatedNewSheets()

      ' constants

      ' declarations

      Dim sPath As String, sFile As String, sName As String

      Dim I As Integer, A As String

      ' start

      sPath = ThisWorkbook.Path

      sFile = Dir(sPath & "\*.txt")

      With ThisWorkbook

      Worksheets(.Worksheets.Count).Activate

      End With

      ' process

      Do Until sFile = ""

      ' worksheet

      ActiveWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)

      On Error Resume Next

      sName = Left(sFile, InStr(sFile, ".") - 1)

      ActiveSheet.Name = sName

      On Error GoTo 0

      ' text file

      With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & sPath & "\" & sFile, Destination:=Range("$A$2"))

      .Name = sName

      .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(1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)

      .TextFileTrailingMinusNumbers = True

      .Refresh BackgroundQuery:=False

      End With

      With ActiveSheet.QueryTables

      .Item(.Count).Delete

      End With

      ' titles

      I = 1

      With ActiveSheet

      Do While Worksheets(1).Cells(2, I + 4) <> ""

      .Cells(1, I) = Worksheets(1).Cells(2, I + 4)

      I = I + 1

      Loop

      End With

      ActiveSheet.Cells.Select

      With Selection

      .HorizontalAlignment = xlLeft

      .VerticalAlignment = xlBottom

      .WrapText = False

      .Orientation = 0

      .AddIndent = False

      .IndentLevel = 0

      .ShrinkToFit = False

      .ReadingOrder = xlContext

      .MergeCells = False

      End With

      ' link

      With Worksheets(1)

      .Activate

      I = .Cells(1, 1).End(xlDown).End(xlDown).End(xlUp).Row + 1

      .Cells(I, 1).Value = sName

      .Cells(I, 2).Select

      .Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & sName & "'!A1", TextToDisplay:=sName

      End With

      ' cycle

      sFile = Dir()

      Loop

      ' end

      ThisWorkbook.Worksheets(1).Activate

      Range("A1").Select

      Beep

    End Sub
     


    The macro must be activated by a button at the highlighted blue "GEONAMES - FILE EXCEL" text of the fiel excel.

    Thank you

    Link of the folder containing the excel file and excel text and text files:https://www.dropbox.com/s/aojqbkwv65enr0d/GEONAMES.7z?dl=0

    MOD EDIT: CODE TAGS ADDED
    Last edited by a moderator: Oct 1, 2017
  2. p45cal

    p45cal Well-Known Member

    Messages:
    923
    For (4) enter those headers in cells E2:W2 of ther EXTRACTIONS sheet, the code already handles this.
    For Text format and coordinates as text change:
    .TextFileColumnDataTypes = Array(1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
    to:
    .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)

    If I get time I'll add converting to excel files in another folder.
  3. p45cal

    p45cal Well-Known Member

    Messages:
    923
    Is this an assignment?
  4. claudia80

    claudia80 Member

    Messages:
    34
    thanks for your intervention, you have settled the question of the coordinates. I would like to include the list of point 4 in the macro and I would not want the macro to create the list of converted text files with its hyperlink.
  5. p45cal

    p45cal Well-Known Member

    Messages:
    923
    Point 4 I've already addressed - you code already handles point 4, you just have to give it something to work with. ('enter those headers in cells E2:W2 of the EXTRACTIONS sheet').


    Again, is this an assignment?
  6. claudia80

    claudia80 Member

    Messages:
    34
    is a help request like the others that are in the forum
  7. claudia80

    claudia80 Member

    Messages:
    34
    is there anyone?
  8. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    189
    p45cal knows more what you are doing than me.

    I added some structure and changed a few things so I could understand it better. It adds a workbook rather than a sheet and saved it for each file. I used an array to add the column titles.

    You will probably want to modify saving the name and link part.

    The xlsm runs from the parent folder where your xlsx file was at.
    Code (vb):

    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

      ' start
     tPath = ThisWorkbook.Path & "\GEONAMES - FILE TEXT\"
      xPath = ThisWorkbook.Path & "\GEONAMES - FILE EXCEL\"
      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 = ""
        Set wb = Workbooks.Add
        On Error Resume Next
        sName = Left(tFile, InStr(tFile, ".") - 1)
        wb.ActiveSheet.Name = sName
        On Error GoTo 0
       
        'Let user know what file is being processed.
       Application.ScreenUpdating = True
        Application.StatusBar = "Processing " & sName & "..."
        Application.ScreenUpdating = False
        ' text file
       With wb.Worksheets(1).QueryTables.Add(Connection:="TEXT;" & tPath & _
          tFile, Destination:=Range("A2"))
          .Name = sName
          .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 wb.Worksheets(1).QueryTables
          .Item(.Count).Delete
        End With
        With wb.Worksheets(1).Cells
          .HorizontalAlignment = xlLeft
          .VerticalAlignment = xlBottom
          .WrapText = False
          .Orientation = 0
          .AddIndent = False
          .IndentLevel = 0
          .ShrinkToFit = False
          .ReadingOrder = xlContext
          .MergeCells = False
        End With
      ' titles
       wb.Worksheets(1).Range("A1").Resize(, UBound(t) + 1).Value = t
        ' link
       With ThisWorkbook.Worksheets(1)
          Set r = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End With
        r.Value = sName
        r.Offset(, 1).Hyperlinks.Add Anchor:=r.Offset(, 1), Address:="", _
          SubAddress:="'" & sName & "'!A1", TextToDisplay:=sName
       
        'Delete xlsx file if it exists
       On Error Resume Next
        Kill xPath & sName & ".xlsx"
        On Error GoTo 0
       
        ' Save and close wb as xlsx
       wb.SaveAs xPath & sName & ".xlsx", xlOpenXMLWorkbook
        wb.Close False
        ' 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
    End Sub
     

    Attached Files:

  9. claudia80

    claudia80 Member

    Messages:
    34
    Thank you very much
  10. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    189
    For the extras that you asked for in a PM, at the end are the modified parts. I changed the alignment to center for the title cells, bolded them, and added the autofilter. I changed the link to link to the xlsx files created in column B.

    As for the the other parts of your project detailed in the PM, most forums discourage off-forum things like that. Feel free to start another thread. You can post a link to this thread if some may relate for an overall picture. Most will not help you with a big project. That is what paid consultants are for. Howsoever, you can be sneaky and post parts of your project. A new concept deserves a new thread. e.g. (1) Importing csv files, massage data and formats, and save as xlsx files. (2) Download csv files from website. (3) etc.

    Code (vb):

      ' titles
       With wb.Worksheets(1).Range("A1").Resize(, UBound(t) + 1)
          .Value = t
          .AutoFilter  'Turn on autofilter
         .Font.Bold = True
          .HorizontalAlignment = xlCenter 'Keep?
         .VerticalAlignment = xlCenter 'Keep?
         .EntireColumn.AutoFit 'Keep? Titles can be bigger than content.
       End With
       
        ' link
       With ThisWorkbook.Worksheets(1)
          Set r = .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
        End With
        r.Hyperlinks.Add Anchor:=r, Address:=xPath & sName & ".xlsx", _
          SubAddress:="'" & sName & "'!A1", TextToDisplay:=sName
    If you need what you sent me in the PM, I can copy and send it back in a PM.
  11. claudia80

    claudia80 Member

    Messages:
    34
    Hello guys
    If I replace the "title" section last attached, within the macro, the results are not the ones you want.
    Why?
  12. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    189
    What I want means nothing. I can post the full sub later tonight or you. Can post an example file for What you want. Note that there are two title sections. The first is names and this latest is for format. Was that not obvious?
  13. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    189
    Code (vb):
    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

      ' start
     tPath = ThisWorkbook.Path & "\GEONAMES - FILE TEXT\"
      xPath = ThisWorkbook.Path & "\GEONAMES - FILE EXCEL\"
     
      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 = ""
        Set wb = Workbooks.Add
        On Error Resume Next
        sName = Left(tFile, InStr(tFile, ".") - 1)
        wb.ActiveSheet.Name = sName
        On Error GoTo 0
       
        'Let user know what file is being processed.
       Application.ScreenUpdating = True
        Application.StatusBar = "Processing " & sName & "..."
        Application.ScreenUpdating = False
     
        ' text file
       With wb.Worksheets(1).QueryTables.Add(Connection:="TEXT;" & tPath & _
          tFile, Destination:=Range("A2"))
          .Name = sName
          .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 wb.Worksheets(1).QueryTables
          .Item(.Count).Delete
        End With
     
        With wb.Worksheets(1).Cells
          .HorizontalAlignment = xlLeft
          .VerticalAlignment = xlBottom
          .WrapText = False
          .Orientation = 0
          .AddIndent = False
          .IndentLevel = 0
          .ShrinkToFit = False
          .ReadingOrder = xlContext
          .MergeCells = False
        End With
     
      ' titles
       With wb.Worksheets(1).Range("A1").Resize(, UBound(t) + 1)
          .Value = t
          .AutoFilter  'Turn on autofilter
         .Font.Bold = True
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          .EntireColumn.AutoFit
        End With
       
        ' link
       With ThisWorkbook.Worksheets(1)
          Set r = .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
        End With
        r.Hyperlinks.Add Anchor:=r, Address:=xPath & sName & ".xlsx", _
          SubAddress:="'" & sName & "'!A1", TextToDisplay:=sName
       
        'Delete xlsx file if it exists
       On Error Resume Next
        Kill xPath & sName & ".xlsx"
        On Error GoTo 0
       
        ' Save and close wb as xlsx
       wb.SaveAs xPath & sName & ".xlsx", xlOpenXMLWorkbook
        wb.Close False
     
        ' 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
    End Sub
  14. claudia80

    claudia80 Member

    Messages:
    34
    Good morning Mr. Hobson.
    I corrected his macro.
    I replaced this part:

    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", ",")

    with this:

    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 ",", ")

    could the titles be highlighted in yellow and not create hyperlinks in the "EXTRACTIONS" sheet?
  15. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    189
    If you want a long line, the t split you posted is fine. I like my code to be readable in a half pane while viewing the Excel file. If you have two monitors, maybe that works for you. Some forums I used in the past made the review block scroll then so I code in blocks by habit for another reason.

    For your sheet command button help, Form and ActiveX controls are used. There are many good tutorials for that. Search for "excel tutorial command buttons".

    For minor changes like those in #14, a recorded macro will show you the syntax. Well, close to it anyway. I tried to set it in title commented block sections so you can see what is happening where. So, we are back to the last two sections towards the end again. Note that even though I commented out the Hyperlink addition, if you just delete a former hyperlink, a text value will still be a hyperlink to nowhere. Use the Clear All to delete formats and values.

    Code (vb):
    ' titles
       With wb.Worksheets(1).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

        ' link
       With ThisWorkbook.Worksheets(1)
          Set r = .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
        End With
        'r.Hyperlinks.Add Anchor:=r, Address:=xPath & sName & ".xlsx", _
          SubAddress:="'" & sName & "'!A1", TextToDisplay:=sName
       r.Value = sName
    Tip: See the tip above a potential reply to see how to type code tags and paste code there. Or more easily, in the 2nd row of the reply menu, click the first icon and paste there. It is a neat feature of this forum.
    Last edited: Oct 12, 2017
  16. claudia80

    claudia80 Member

    Messages:
    34
    Good morning, Mr. Kenneth Hobson.
    I followed her advice and I did it.
    I have been able to insert macros start buttons and removed the "link" part of the code to avoid creating the converted file list with its hyperlink.

    the conversion macro is useful because if you restart the macro to transform updated files, the old files (with the same name) are automatically deleted
    Last edited: Oct 13, 2017
  17. claudia80

    claudia80 Member

    Messages:
    34
    Good morning. Is it possible to modify the code by blocking the first line of excel files as they are created?

    Unlike alternatives if possible I will insert it as another macro:

    Seeing the link for the Italian "IT" situation if the macro is active the excel file "IT" will be deleted and replaced by the new excel file "IT". With the same macro, you can not delete the existing excel files but only the "IT" page inside the "IT" file. This way I can add pages to existing excel files.

    https://www.dropbox.com/s/916d614msocj9up/Kenneth Hobson 4.rar?dl=0
  18. claudia80

    claudia80 Member

    Messages:
    34
    If no one answered me in the forum maybe I did not explain it well.
    after turning the excel text files with its macro, I get the "geonames - excel file" folder with all excel files.
    I would like these files not to be deleted from the macro, but to delete and update the content of the file page that has the same file name.
    I think that to do this just make a change to the previous macro.
    Right?
  19. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    189
    As I explained before, most use ZIP as the compression standard and not RAR. If your ZIP file is too big to attach, you need to make sample files that are smaller in size. e.g. Rather than 1,000 rows of data in each file, make the samples 10 rows in a new file. Files can bloat in size if you just SaveAs.

    I don't know what not delete means. Kill() was used in the macro that I made for you to delete existing files so that SaveAs did not error as one normally wants to overwrite existing files with the same name.

    IF you don't want to overwrite existing files, what do you want to do? You want to remove the existing entry from a previous run? Maybe you would want to just skip doing the SaveAs?

    From what I did for you that you were talking about maybe in post #18.
    Code (vb):
    'https://chandoo.org/forum/threads/txt-to-excel.35952
    Sub Main2()
      ' 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

      ' start
     tPath = ThisWorkbook.Path & "\GEONAMES - FILE TEXT\"
      xPath = ThisWorkbook.Path & "\GEONAMES - FILE EXCEL\"
     
      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 = ""
        Set wb = Workbooks.Add
        On Error Resume Next
        sName = Left(tFile, InStr(tFile, ".") - 1)
        wb.ActiveSheet.Name = sName
        On Error GoTo 0
       
        'Let user know what file is being processed.
       Application.ScreenUpdating = True
        Application.StatusBar = "Processing " & sName & "..."
        Application.ScreenUpdating = False
     
        ' text file
       With wb.Worksheets(1).QueryTables.Add(Connection:="TEXT;" & tPath & _
          tFile, Destination:=Range("A2"))
          .Name = sName
          .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 wb.Worksheets(1).QueryTables
          .Item(.Count).Delete
        End With
     
        With wb.Worksheets(1).Cells
          .HorizontalAlignment = xlLeft
          .VerticalAlignment = xlBottom
          .WrapText = False
          .Orientation = 0
          .AddIndent = False
          .IndentLevel = 0
          .ShrinkToFit = False
          .ReadingOrder = xlContext
          .MergeCells = False
        End With
     
      ' titles
       With wb.Worksheets(1).Range("A1").Resize(, UBound(t) + 1)
          .Value = t
          .AutoFilter  'Turn on autofilter
         .Font.Bold = True
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          .EntireColumn.AutoFit
        End With
       
        ' link
       With ThisWorkbook.Worksheets(1)
          Set r = .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
        End With
        r.Hyperlinks.Add Anchor:=r, Address:=xPath & sName & ".xlsx", _
          SubAddress:="'" & sName & "'!A1", TextToDisplay:=sName
       
        'Delete xlsx file if it exists
       On Error Resume Next
        Kill xPath & sName & ".xlsx"
        On Error GoTo 0
       
        ' Save and close wb as xlsx
       wb.SaveAs xPath & sName & ".xlsx", xlOpenXMLWorkbook
        wb.Close False
     
        ' 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
    End Sub
  20. claudia80

    claudia80 Member

    Messages:
    34
    Good evening, Mr. Hobson.
    It's a pleasure to find her here again.
    I saw that you inserted a piece of code in the macro. What does this part of code do?

    [' link

    With ThisWorkbook.Worksheets(1)

    Set r = .Cells(.Rows.Count, "B").End(xlUp).Offset(1)

    End With

    r.Hyperlinks.Add Anchor:=r, Address:=xPath & sName & ".xlsx", _

    SubAddress:="'" & sName & "'!A1", TextToDisplay:=sName]

    the function of the new macro that I request is to delete the page content of the excel file that was previously created by the macro that you have already created (already in the geonames folder - excel file), then insert the contents of the file corresponding text, located in the "geonames - text file" folder on the page.
  21. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    189
    I don't understand exactly.

    In the macro that I created for you, it takes a txt file, and makes an xlsx but with a header row. So, the two are nearly the same.

    A 2nd run would overwrite the current xlsx file if it exists by deleting it and then creating it again from the txt file.

    Are you wanting:
    1. Archive an xlsx if it exists?
    and
    2. Name the new xlsx the same as the original xlsx but add an incremental suffix number?
    and
    3. Not add a new entry in column B since the original would already exist?

    Of course if (1) is true, one could just create a date named archive folder and keep the same file names. I guess it depends on how often you do reruns.

    You should probably do something similar for the txt files. Once processed, maybe steps 1-3 sort of thing should be done as well.
  22. claudia80

    claudia80 Member

    Messages:
    34
    I sent you to private message. I think you will now understand in the spacific.
  23. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    189
    I think that I see now.

    1. When adding another sName sheet to the existing workbook, should it be added before the 1st sheet or after the last sheet?

    a. What name do you want new sheet called since sName will already exist?

    For 1, if a 3rd run, what would the sheet naming convention be? A suffix naming convention could be like: IT, IT (1), IT (2) or IT, IT-1, IT-2 etc. The first is the normal method.
    Last edited: Oct 29, 2017
  24. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    189
    I used option (2).
    Code (vb):
    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

      ' start
     tPath = ThisWorkbook.Path & "\GEONAMES - FILE TEXT\"
      xPath = ThisWorkbook.Path & "\GEONAMES - FILE EXCEL\"
     
      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")
          Set ws = wb.Worksheets.Add(before:=Worksheets(1))
          ws.Name = NextWSname(sName, wb.Name)
          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
     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

    Function NextWSname(ByVal awsName As String, wbName As String) _
      As String
      Dim i As Integer, s As String
      s = awsName
      If InStr(s, "-") <> 0 Then _
        s = Left(s, InStrRev(s, "-") - 1)
      awsName = s
      Do Until Not WorkSheetExists(awsName, wbName)
        i = i + 1
        awsName = s & "-" & i
      Loop
      NextWSname = awsName
    End Function

    '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
  25. claudia80

    claudia80 Member

    Messages:
    34
    It's almost perfect. These small changes must be made:1) With this macro the reference folder is no longer "GEONAMES - FILE EXCEL" but the folder "MERGED" FILE ";2) the macro does not have to create new pages (IT-1 etc.) but must delete the contents of the "IT" sheet and paste into this page the contents of the text files in the "GEONAMES - FILE TEXT" folder.Specify the details in a private message.

Share This Page