Question

有没有一种快速方法可以将多个以制表符分隔的文件（每个）转换为xls格式？任何MATLAB / VBA脚本都会很棒！

非常感谢！

Answer 1

首先制作要打开的文件的文本文件列表。我使用包含以下代码的MS-DOS批处理文件：

:: MSDOS batch file
:: creates a text file listing of all files in the current directory
@ECHO OFF
dir /b > filelist.txt
EXIT

根据需要从文本文件中删除目录和其他废话。

将新模块添加到Excel文档中。插入以下内容

Function GetTextDirect(ByVal sFile As String) As String
'used to get the file list of imports
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetTextDirect = ts.readall
    ts.Close
    'Set fso = Nothing
End Function
Sub get_files()
'MsgBox ("Have you updated the file list?  Create one by saving the following to a text file, then renaming it ""filelist generator.bat""" & _
Chr(10) & Chr(10) & _
":: - MS-DOS batch file" & Chr(10) & _
":: - creates a text file listing of all files in the current directory" & Chr(10) & _
"@ECHO OFF " & Chr(10) & _
"dir /b > filelist.txt" & Chr(10) & _
"EXIT")

'prompt user for the filelist
MsgBox ("Please select the file list at the following dialog box.")
Application.FileDialog(msoFileDialogOpen).InitialFileName = ThisWorkbook.Path & "\"
Application.FileDialog(msoFileDialogOpen).Show
filelist = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)

'parse the directory and file name from filelist
For character_place = Len(filelist) To 1 Step -1
    'Find the last ocurrence of "\" in the string
    If InStr(Mid(filelist, character_place, 1), "\") Then Exit For
Next character_place
filelist_name = Right(filelist, Len(filelist) - character_place)
filelist_dir = Left(filelist, Len(filelist) - Len(filelist_name))

'identifying the name of the current workbook
workfile_name = ThisWorkbook.Name

'import directory
import_dir = filelist_dir

'locating the directory of the import file list
importlist = filelist_dir & filelist_name

'reading the import list
'calling the GetTextDirect function
'ensuring importlist is not empty
If Dir(importlist) <> "" Then
    importlist_string = GetTextDirect(importlist)
Else
    importlist_string = ""
End If

'initialize
workstring = importlist_string
delim = Chr(13) & Chr(10)
delim_POS = InStr(workstring, delim)

Dim selected_ARRAY() As String
ReDim selected_ARRAY(1 To 1, 1 To 3)
'selected_ARRAY(i, 1) = file directory
'selected_ARRAY(i, 2) = file name
'selected_ARRAY(i, 3) = distinguishing tab name
selected_ARRAY(1, 1) = "nothing_yet"
selected_ARRAY(1, 2) = "nothing_yet"
selected_ARRAY(1, 3) = "nothing_yet"

'parse workstring into discrete file names
Do While delim_POS > 0
    'filename is the string to the left of the next delimiter
    'reduce workstring accordingly
    selected_filename = Trim(Left(workstring, delim_POS - 1))
    workstring = Mid(workstring, Len(selected_filename) + Len(delim) + 1, Len(workstring) - Len(selected_filename))

    'add selected_filename to selected_ARRAY
    If selected_ARRAY(1, 1) = "nothing_yet" Then
        selected_ARRAY(1, 1) = import_dir
        selected_ARRAY(1, 2) = selected_filename
    Else:
        'add to the array, while preserving existing values
        'create temporary copy of the array
        tempArray = selected_ARRAY
        arraysize = UBound(selected_ARRAY, 1)
        ReDim selected_ARRAY(1 To arraysize + 1, 1 To 3)
        'then reinsert values from tempArray
        For m = 1 To arraysize
              For n = 1 To UBound(selected_ARRAY, 2)
                   selected_ARRAY(m, n) = tempArray(m, n)
              Next n
        Next m
        Set tempArray = Nothing

        'read the new value(s) into the new upper bound of the array
        selected_ARRAY(UBound(selected_ARRAY), 1) = import_dir
        selected_ARRAY(UBound(selected_ARRAY), 2) = selected_filename
    End If

    'reinitializing
    delim_POS = InStr(workstring, delim)
Loop

If selected_ARRAY(1, 1) = "nothing_yet" Then
    'ensuring selected_ARRAY has at least one record
    selected_ARRAY(1, 1) = importlist_string
ElseIf (workstring <> "") And (workstring <> delim) Then
    'capturing the last field in cases where the importlist_string does not end with delim
    'i.e. does not end with with <CR><LF>
    'adding the remaining text in workstring to the selected_ARRAY

    'add to the array, while preserving existing values
    'create temporary copy of the array
    tempArray = selected_ARRAY
    arraysize = UBound(selected_ARRAY, 1)
    ReDim selected_ARRAY(1 To arraysize + 1, 1 To 3)
    'then reinsert values from tempArray
    For m = 1 To arraysize
          For n = 1 To UBound(selected_ARRAY, 2)
               selected_ARRAY(m, n) = tempArray(m, n)
          Next n
    Next m
    Set tempArray = Nothing

    'read the new value(s) into the new upper bound of the array
    selected_ARRAY(UBound(selected_ARRAY), 1) = import_dir
    selected_ARRAY(UBound(selected_ARRAY), 2) = workstring
End If

'initialize temp file variable
'allows html/csv/txt/ect. to be imported to xls, despite Excel 2010
Dim tempWb As Workbook
tempfile_name = "temp.xls"
fulltempfile_name = import_dir & tempfile_name

'determine distinguishing tab name for each file in selected_ARRAY
For i = 1 To UBound(selected_ARRAY, 1)
    'identified by interpreting the file name
    selected_filename = selected_ARRAY(i, 2)

    'identify the length of the file extension
    For character_place = Len(selected_filename) To 1 Step -1
        'Find the last ocurrence of "." in the string
        If InStr(Mid(selected_filename, character_place, 1), ".") Then Exit For
    Next
    File_Ext = Right(selected_filename, Len(selected_filename) - character_place + 1)
    File_Ext_len = Len(File_Ext)

    'identify the new name for the imported tab
    'tab names are limited to 31 characters long
    If Len(Left(selected_filename, Len(selected_filename) - File_Ext_len)) > 31 Then
        'prevents tab name of greater than 31 characters
        'also prevents any file extension artifacts in the tab name
        'i.e. theverybigfilenamethatgoeson.html becomes ...
        '     1234567890123456789012345678901234
        '     theverybigfilenamethatgoeson instead of ...
        '     theverybigfilenamethatgoeson.ht
        tabname = Left(Left(selected_filename, Len(selected_filename) - File_Ext_len), 31)
    Else
        tabname = Left(selected_filename, Len(selected_filename) - File_Ext_len)
    End If

    'record value to array
    selected_ARRAY(i, 3) = tabname
Next i

'import files
For i = 1 To UBound(selected_ARRAY, 1)
    'open incoming html/csv/txt/ect. file
    'add to working file
    selected_filename = selected_ARRAY(i, 2)
    Workbooks.Open Filename:=selected_ARRAY(i, 1) & selected_filename

    'Copy the ActiveSheet to tempWB
    ActiveSheet.Copy
    Set tempWb = ActiveWorkbook

    'preventing saveas alerts
    Application.DisplayAlerts = False

    'use the 2000-2003 format xlWorkbookNormal to save as xls
    tempWb.SaveAs fulltempfile_name, FileFormat:=-4143, CreateBackup:=False
    tempWb.Close SaveChanges:=False

    'restarting saveas alerts
    Application.DisplayAlerts = False

    'releasing resources
    Set tempWb = Nothing

    'close the import file
    Windows(selected_filename).Activate
    Application.CutCopyMode = False
    ActiveWindow.Close SaveChanges:=False

    'open the temporary file, i.e. xls friendly version of the html/csv/txt/ect. file
    Workbooks.Open fulltempfile_name

    ActiveSheet.Copy Before:=Workbooks(workfile_name).Sheets(1)
    ActiveSheet.Move after:=Worksheets(Worksheets.Count)

    'close the temp file
    Windows(tempfile_name).Activate
    ActiveWindow.Close

    'rename tab
    ActiveSheet.Name = selected_ARRAY(i, 3)
Next i

'signal the macro is complete
Sheets(1).Select
MsgBox ("Process complete.")

End Sub

将制表符分隔文件批量转换为xls

1 个答案: