Copy data from xlsx to txt (ansi)

A

adamasmay

New Member
Joined
Dec 30, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
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







​

 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Sort by date Sort by votes
In the below code there are a few comments starting with <<<<
These will need your attention.

VBA Code: 
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
 
Upvote 0
sijpie said:
In the below code there are a few comments starting with <<<<
These will need your attention.

VBA Code: 
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
Click to expand...
Thank you.
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
VBA help to open .txt files and copy into its respective sheet
2
Replies
15
Views
253
ItalianPlatinum
I
R
  • Solved
VBA Queries refresh and Save data as TXT
Replies
2
Views
291
Artik
Artik
M
  • Question Question
Power Query with Dynamic Data Source
Replies
4
Views
1K
Alex Blakenburg
A
C
  • Solved
User Select PDF import to specific Excel sheet
2 3 4
Replies
31
Views
1K
John_w
J
G
  • Question Question
remove columns from multiple Excel-files in a folder
Replies
5
Views
335
gjvv
G

Forum statistics

Threads
1,224,823
Messages
6,181,177
Members
453,021
Latest member
Justyna P

Share this page

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