Copy data from xlsx to txt (ansi)

[adamasmay]

Hello,
I have 5 excel file in folder ( some file have 2 sheet , some file have 4 Sheet)

I want copy data from xlsx to new txt (Encode ANSI)
1 Sheet Excel to 1 file txt

Delimited in textfile =!

Please guide me about it.
remark : input file = 200,000 row

​

 

[sijpie]

In the below code there are a few comments starting with <<<<
These will need your attention.

Option Explicit
    Dim bOneTxtperWB As Boolean, bOneTxt4All As Boolean

Sub ExportAll2ANSI()
    Dim sPath As String, sDirDilimiter As String, sTxtFName As String
    
    
    'Set up path where files are held
    sPath = ThisWorkbook.Path   '<<<< If the files are held in another directory, _
                                      replace 'ThisWorkbook.Path' with "C:\YourDirectoryPath"
    If sPath Like "*/*" Then
        sDirDilimiter = "/"
    Else
        sDirDilimiter = "\"
    End If
    
    If Right(sPath, 1) <> sDirDilimiter Then
        sPath = sPath & sDirDilimiter
    End If
    
    'If all the sheets of all the workbooks need to be exported to ONE textfile then set following to True
    bOneTxt4All = False     'False = each workbook at least in its own textfile
    
    'if all sheets of one workbook are to be exported to one textfile, then set following to True
    bOneTxtperWB = False    'False = each sheet to its own textfile
    'The above gets ignored if  bOneTxt4All =True
    
    If bOneTxt4All Then
        sTxtFName = "AllExport.txt"
    End If
    
    LoopAllExcelFilesInFolder sPath, sTxtFName
End Sub

Sub LoopAllExcelFilesInFolder(sMyPath As String, sTxtFName As String)
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: adopted from code on www.TheSpreadsheetGuru.com

    Dim wbWB As Workbook
    Dim sMyFile As String
    Dim sMyExtension As String
    Dim wsWS As Worksheet
    'Dim FldrPicker As FileDialog
    
    'Optimize Macro Speed
      Application.ScreenUpdating = False
      Application.EnableEvents = False
      Application.Calculation = xlCalculationManual
    
    
    'Target File Extension (must include wildcard "*")
      sMyExtension = "*.xlsx"
    
    'Target Path with Ending Extention
      sMyFile = Dir(sMyPath & sMyExtension)
    
    'Loop through each Excel file in folder
      Do While sMyFile <> ""
        'Set variable equal to opened workbook
          Set wbWB = Workbooks.Open(Filename:=sMyPath & sMyFile)
        
        'Ensure Workbook has opened before moving on to next line of code
          DoEvents
        
        If bOneTxt4All = False Then
            sTxtFName = Replace(sMyFile, ".xlsx", "")
        End If
        'Loop through the sheets
          For Each wsWS In wbWB.Sheets
            ExportSheet wsWS, sTxtFName, sMyPath
          Next wsWS
        
        'Close Workbook without save
          wbWB.Close SaveChanges:=False
          
        'Ensure Workbook has closed before moving on to next line of code
          DoEvents
    
        'Get next file name
          sMyFile = Dir
      Loop
    
    'Message Box when tasks are completed
      MsgBox "Task Complete!"
    
ResetSettings:
    'Reset Macro Optimization Settings
      Application.EnableEvents = True
      Application.Calculation = xlCalculationAutomatic
      Application.ScreenUpdating = True

End Sub

Sub ExportSheet(wsWS As Worksheet, sTxtFName As String, sPath As String)
    Dim objFSO As Variant, objTF As Variant, vInp As Variant
    Dim lRow As Long, lCol As Long, lFnum As Long
    Dim strTmp As String, sFilePath As String
    Dim Rng1 As Range
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
    Const strDelim As String = "!" '<<<<<<<< Change this to the delimiter you require <<<<<<


    Set objFSO = CreateObject("scripting.filesystemobject")
    If bOneTxtperWB = False Then 'Each ws gets its own output file. Named as WorkbkName_SheetName.txt
        sFilePath = sPath & sTxtFName & "_" & wsWS.Name & ".txt"
        Set objTF = objFSO.CreateTextFile(sFilePath, True, False)
    Else
        sFilePath = sTxtFName & ".txt"
        Set objTF = objFSO.OpenTextFile(sFilePath, ForAppending, True, TristateFalse)
    End If
    
    'test that sheet has been used
    Set Rng1 = wsWS.UsedRange
    If Not Rng1 Is Nothing Then
        'only multi-cell ranges can be written to a 2D array
        If Rng1.Cells.Count > 1 Then
            vInp = wsWS.UsedRange.Value2
            'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column
            For lCol = 1 To UBound(vInp, 2)
                'write initial value outside the loop
                strTmp = IIf(InStr(vInp(1, lCol), strDelim) > 0, """" & vInp(1, lCol) & """", vInp(1, lCol))
                For lRow = 2 To UBound(vInp, 1)
                    'concatenate long string & (short string with short string)
                    strTmp = strTmp & (strDelim & IIf(InStr(vInp(lRow, lCol), strDelim) > 0, """" & vInp(lRow, lCol) & """", vInp(lRow, lCol)))
                Next lRow
                'write each line to CSV
                objTF.WriteLine strTmp
            Next lCol
        Else
            objTF.WriteLine IIf(InStr(wsWS.UsedRange.Value, strDelim) > 0, """" & wsWS.UsedRange.Value & """", wsWS.UsedRange.Value)
        End If
    End If

    objTF.Close
    Set objFSO = Nothing

End Sub

 

[adamasmay]

In the below code there are a few comments starting with <<<<
These will need your attention.

Option Explicit
    Dim bOneTxtperWB As Boolean, bOneTxt4All As Boolean

Sub ExportAll2ANSI()
    Dim sPath As String, sDirDilimiter As String, sTxtFName As String
   
   
    'Set up path where files are held
    sPath = ThisWorkbook.Path   '<<<< If the files are held in another directory, _
                                      replace 'ThisWorkbook.Path' with "C:\YourDirectoryPath"
    If sPath Like "*/*" Then
        sDirDilimiter = "/"
    Else
        sDirDilimiter = "\"
    End If
   
    If Right(sPath, 1) <> sDirDilimiter Then
        sPath = sPath & sDirDilimiter
    End If
   
    'If all the sheets of all the workbooks need to be exported to ONE textfile then set following to True
    bOneTxt4All = False     'False = each workbook at least in its own textfile
   
    'if all sheets of one workbook are to be exported to one textfile, then set following to True
    bOneTxtperWB = False    'False = each sheet to its own textfile
    'The above gets ignored if  bOneTxt4All =True
   
    If bOneTxt4All Then
        sTxtFName = "AllExport.txt"
    End If
   
    LoopAllExcelFilesInFolder sPath, sTxtFName
End Sub

Sub LoopAllExcelFilesInFolder(sMyPath As String, sTxtFName As String)
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: adopted from code on www.TheSpreadsheetGuru.com

    Dim wbWB As Workbook
    Dim sMyFile As String
    Dim sMyExtension As String
    Dim wsWS As Worksheet
    'Dim FldrPicker As FileDialog
   
    'Optimize Macro Speed
      Application.ScreenUpdating = False
      Application.EnableEvents = False
      Application.Calculation = xlCalculationManual
   
   
    'Target File Extension (must include wildcard "*")
      sMyExtension = "*.xlsx"
   
    'Target Path with Ending Extention
      sMyFile = Dir(sMyPath & sMyExtension)
   
    'Loop through each Excel file in folder
      Do While sMyFile <> ""
        'Set variable equal to opened workbook
          Set wbWB = Workbooks.Open(Filename:=sMyPath & sMyFile)
       
        'Ensure Workbook has opened before moving on to next line of code
          DoEvents
       
        If bOneTxt4All = False Then
            sTxtFName = Replace(sMyFile, ".xlsx", "")
        End If
        'Loop through the sheets
          For Each wsWS In wbWB.Sheets
            ExportSheet wsWS, sTxtFName, sMyPath
          Next wsWS
       
        'Close Workbook without save
          wbWB.Close SaveChanges:=False
         
        'Ensure Workbook has closed before moving on to next line of code
          DoEvents
   
        'Get next file name
          sMyFile = Dir
      Loop
   
    'Message Box when tasks are completed
      MsgBox "Task Complete!"
   
ResetSettings:
    'Reset Macro Optimization Settings
      Application.EnableEvents = True
      Application.Calculation = xlCalculationAutomatic
      Application.ScreenUpdating = True

End Sub

Sub ExportSheet(wsWS As Worksheet, sTxtFName As String, sPath As String)
    Dim objFSO As Variant, objTF As Variant, vInp As Variant
    Dim lRow As Long, lCol As Long, lFnum As Long
    Dim strTmp As String, sFilePath As String
    Dim Rng1 As Range
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
    Const strDelim As String = "!" '<<<<<<<< Change this to the delimiter you require <<<<<<


    Set objFSO = CreateObject("scripting.filesystemobject")
    If bOneTxtperWB = False Then 'Each ws gets its own output file. Named as WorkbkName_SheetName.txt
        sFilePath = sPath & sTxtFName & "_" & wsWS.Name & ".txt"
        Set objTF = objFSO.CreateTextFile(sFilePath, True, False)
    Else
        sFilePath = sTxtFName & ".txt"
        Set objTF = objFSO.OpenTextFile(sFilePath, ForAppending, True, TristateFalse)
    End If
   
    'test that sheet has been used
    Set Rng1 = wsWS.UsedRange
    If Not Rng1 Is Nothing Then
        'only multi-cell ranges can be written to a 2D array
        If Rng1.Cells.Count > 1 Then
            vInp = wsWS.UsedRange.Value2
            'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column
            For lCol = 1 To UBound(vInp, 2)
                'write initial value outside the loop
                strTmp = IIf(InStr(vInp(1, lCol), strDelim) > 0, """" & vInp(1, lCol) & """", vInp(1, lCol))
                For lRow = 2 To UBound(vInp, 1)
                    'concatenate long string & (short string with short string)
                    strTmp = strTmp & (strDelim & IIf(InStr(vInp(lRow, lCol), strDelim) > 0, """" & vInp(lRow, lCol) & """", vInp(lRow, lCol)))
                Next lRow
                'write each line to CSV
                objTF.WriteLine strTmp
            Next lCol
        Else
            objTF.WriteLine IIf(InStr(wsWS.UsedRange.Value, strDelim) > 0, """" & wsWS.UsedRange.Value & """", wsWS.UsedRange.Value)
        End If
    End If

    objTF.Close
    Set objFSO = Nothing

End Sub

Thank you.