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
