Batch converting text file into Excel files

demo · 发表于 2013-11-22 15:58:40

It's a pretty simple function but with little complecated description.

Like there are around 10 branches with balance data from 2002 to 2013. history data only need annual and 2013 need ytd monthly based files.

File name as Belance_sheet_Branch_month_day_Year.text, and to be converted to the same name but put into respected folders.

Here is what has done.

'**************************
'*Code By: John Z
'*Function: Batch converting text files into Excel files with sepecific format regulated
'*Email: cq_box#163.com
'*Date: November 11, 2013
'**************************
Sub BatchConvertFiles()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim ws As Worksheet
Dim SourceRoot, DestRoot As String, mArr As Variant
Dim ExtFile, Basepath, Branch, DateStr, BaseFile, NewFile, sYear, m_text As String
SourceRoot = "X:\Source\balance_convert\all"
DestRoot = "X:\ARCHIVE\balance_sheet"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = ActiveSheet
'Set ws = Worksheets.Add --Debug use
'Get the folder object associated with the directory
Set objFolder = objFSO.GetFolder(SourceRoot)
'ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & " are:"
'Loop through the Files collection
For Each objFile In objFolder.Files
'ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name
m_text = objFile.Name
mArr = Split(m_text, ".")
ExtFile = mArr(1)
BaseFile = mArr(0)
NewFile = mArr(0) & ".xlsx"
mArr = Split(mArr(0), "_")
Basepath = mArr(0) & "_" & mArr(1)
Branch = mArr(2): DateStr = mArr(3)
sYear = "20" & Split(mArr(3), "-")(2)
NewFile = DestRoot & "" & Branch & "" & sYear & "" & NewFile
'"TEXT;X:\ARCHIVE\balance_sheet\kam\2002\balance_sheet_B01_12-31-02.txt", --- File Name example
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & SourceRoot & "" & objFile.Name, _
Destination:=Range("$A$1"))
.Name = BaseFile 'Name the sheet tag with file name "balance_sheet_B01_12-31-02"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 1, 1)
.TextFileFixedColumnWidths = Array(12, 42, 16) 'Data fields delimilite
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ChDir DestRoot & "" & Branch & "" & sYear
'"X:\ARCHIVE\balance_sheet\B01\2002" --sample of destination folder location
ActiveWorkbook.SaveAs Filename:= _
NewFile, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'"X:\ARCHIVE\balance_sheet\B01\2002\balance_sheet_B01_12-31-02.xlsx", _ --another data example format
'ws.Cells(ws.UsedRange.Rows.Count, 2).Value = NewFile
'MsgBox ("Destnation: " & DestRoot & "" & Branch & "" & sYear & "" & NewFile)
Call clearall
Next
'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Sub
'**************************
'*Code By: John Z
'*Function: Another sample module to list out all the files required. this one cannot go succeed in new version of excel after 2007
'*Email: cq_box#163.com
'*Date: November 11, 2013
'**************************
Sub ListAllFiles()
Dim fs As FileSearch, ws As Worksheet, i As Long
Set fs = Application.FileSearch
With fs
.SearchSubFolders = False ' set to true if you want sub-folders included
.FileType = msoFileTypeAllFiles 'can modify to just Excel files eg with msoFileTypeExcelWorkbooks
.LookIn = "X:\jzx\balance_convert\all" 'modify this to where you want to serach
If .Execute > 0 Then
Set ws = Worksheets.Add
For i = 1 To .FoundFiles.Count
ws.Cells(i, 1) = .FoundFiles(i)
Next
Else
MsgBox "No files found"
End If
End With
End Sub
'**************************
'*Code By: John Z
'*Function: list out files with short file name
'*Email: cq_box#163.com
'*Date: November 11, 2013
'**************************
Sub ListAllFilesShort()
Dim fs As FileSearch, ws As Worksheet, i As Long
Set fs = Application.FileSearch
With fs
.SearchSubFolders = False ' set to true if you want sub-folders included
.FileType = msoFileTypeAllFiles 'can modify to just Excel files eg with msoFileTypeExcelWorkbooks
.LookIn = "C:" 'modify this to where you want to serach
If .Execute > 0 Then
Set ws = Worksheets.Add
For i = 1 To .FoundFiles.Count
ws.Cells(i, 1) = Mid$(.FoundFiles(i), InStrRev(.FoundFiles(i), "") + 1)
Next
Else
MsgBox "No files found"
End If
End With
End Sub
Sub clearall()
'**************************
'*Module name: clearall
*Code By: John Z
'*Function: clear specific area for sheet reuse.
'*Email: cq_box#163.com
'*Date: November 11, 2013
'**************************'
'
Range("A:D").Select
Selection.ClearContents
Range("A1").Select
End Sub

复制代码

来自圈子: Demo俱乐部

demo · 发表于 2013-11-27 14:06:53

An update version used as above.
Even the source data is all sitted in different folders.

Sub clearall()
'
' clearall Macro
'
'
Range("A:K").Select
Selection.ClearContents
Range("A1").Select
End Sub
Sub ConvertAll_Income()
'
'John Z
'Description:
'example for executing the function ListFilesInFolder
Dim SourceRoot As String
Workbooks.Add
SourceRoot = "X:\ARCHIVE\income_statement"
ListFilesInFolder SourceRoot, True
MsgBox ("Done!")
End Sub
Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
'
' John Z
' http://www.bcmorning.com/forum.php?mod=forumdisplay&fid=109
' description:
' lists information about the files in SourceFolder, and convert all text files into excel files.
' example: ListFilesInFolder "C:\FolderName", True
'
Dim FSO As Object
Dim SourceFolder As Object
Dim SubFolder As Object
Dim FileItem As Object
Dim ExtFile, m_text As String ', BasePath, Branch, DateStr, BaseFile, NewFile, sYear
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'r = Range("A65536").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
'display file properties
m_text = FileItem.Name
mArr = Split(m_text, ".")
ExtFile = mArr(1)
If ExtFile = "txt" And FileItem.Size > 0 Then
ConvertToExcel FileItem.Path ', NewFile
End If
'X = SourceFolder.Path
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
'***** Remove the single ' character in the below lines to adjust the column windths
'Columns("A:G").ColumnWidth = 4
'Columns("H:I").AutoFit
'Columns("J:L").ColumnWidth = 12
'Columns("M:P").ColumnWidth = 8
Set FileItem = Nothing
Set SourceFolder = Nothing: Set SubFolder = Nothing
Set FSO = Nothing
'ActiveWorkbook.Saved = True
End Sub
Function ConvertToExcel(ByVal SourceFile As String) ', ByVal DestFileName As String)
Dim myFSO, myFile As Object
Dim mArr As Variant
Dim m_text, m_path, ExtFile, BaseFile, NewFile, DateStr, Branch, BasePath, sYear As String
Set myFSO = CreateObject("Scripting.FileSystemObject")
Set myFile = myFSO.GetFile(SourceFile)
m_text = myFile.Name
m_path = myFile.Path
mArr = Split(m_text, ".")
BaseFile = mArr(0)
ExtFile = mArr(1)
mArr = Split(m_path, ".")
NewFile = mArr(0) & ".xlsx"
'mArr = Split(mArr(0), "_")
'BasePath = mArr(0) & "_" & mArr(1)
'Branch = mArr(2): DateStr = mArr(3)
'sYear = "20" & Split(mArr(3), "-")(2)
'NewFile = DestFileName 'DestFolder & "" & Branch & "" & sYear & "" & NewFile
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & SourceFile, _
Destination:=Range("$A$1"))
'"TEXT;" & SourceRoot & "" & objFile.Name,
.Name = BaseFile
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileFixedColumnWidths = Array(14, 44, 12, 8, 14, 8, 14, 8, 14, 8)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'ChDir DestRoot & "" & Branch & "" & sYear
'"X:\ARCHIVE\balance_sheet\b01\2002"
ActiveWorkbook.SaveAs FileName:= _
NewFile, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'"X:\ARCHIVE\balance_sheet\b01\2002\balance_sheet_b01_12-31-02.xlsx", _
'ws.Cells(ws.UsedRange.Rows.Count, 2).Value = NewFile
'MsgBox ("Destnation: " & DestRoot & "" & Branch & "" & sYear & "" & NewFile)
Call clearall
End Function
Function GetFileOwner(ByVal FilePath As String, ByVal FileName As String)
Dim objFolder As Object
Dim objFolderItem As Object
Dim objShell As Object
FileName = StrConv(FileName, vbUnicode)
FilePath = StrConv(FilePath, vbUnicode)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(StrConv(FilePath, vbFromUnicode))
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
End If
If Not objFolderItem Is Nothing Then
GetFileOwner = objFolder.GetDetailsOf(objFolderItem, 8)
Else
GetFileOwner = ""
End If
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function

复制代码

Any suggests are welcomed.

账号		自动登录	找回密码
密码			注册

Batch converting text file into Excel files

Batch converting text file in tree dictories into Excel files