合并文本文件至Excel

好久没来写博客，刚刚一看上一篇居然还是半年前写的。不久前换了份工作，工作中有了些新的小玩意，决定给记录下来：）

 

以下代码是用于将多个文本文件合并到一个excel内，且每个文本文件单独生成一个sheet。

代码风格其实不是很好，拼凑了一下。因为是日常应用，先能用再说了，也没有继续深入研究。用的是导入文本的方法。其实开始用的打开直接复制。但非常邪门的是就是现显示乱码（已经设定编码为UTF-8），但用导入就没有问题，不知何故。

导入的地方也包括编码参数，65001是UTF-8，如果不是请自行更换。

.TextFilePlatform = 65001

 

保存的Sheet名字和文件名一样，我这里为了自己看得方便删减过了，可以按需定制下面这句

ActiveSheet.Name = Mid(FilenameOnly, 12, Len(FilenameOnly) - 15)

直接改成

ActiveSheet.Name = FilenameOnly

 

完整代码如下：

 1 Sub 批量导入()
 2 Application.DisplayAlerts = False
 3 Application.ScreenUpdating = False
 4 Dim txt, fd As FileDialog
 5 Dim FilePathArray As Variant
 6 Set fd = Application.FileDialog(msoFileDialogFilePicker)
 7      With fd
 8         .AllowMultiSelect = True
 9         Workbooks.Add
10         
11         
12          If .Show = -1 Then
13              For Each txt In .SelectedItems
14          
15         Sheets.Add After:=Sheets(Sheets.Count)
16         
17         FilePathArray = Split(txt, "\")
18         FilenameOnly = FilePathArray(UBound(FilePathArray))
19         ActiveSheet.Name = Mid(FilenameOnly, 12, Len(FilenameOnly) - 15)
20                  
21         With ActiveSheet.QueryTables.Add(Connection:= _
22         "TEXT;" & txt, Destination:=Range( _
23         "$A$1"))
24         .Name = txt
25         .FieldNames = True
26         .RowNumbers = False
27         .FillAdjacentFormulas = False
28         .PreserveFormatting = True
29         .RefreshOnFileOpen = False
30         .RefreshStyle = xlInsertDeleteCells
31         .SavePassword = False
32         .SaveData = True
33         .AdjustColumnWidth = True
34         .RefreshPeriod = 0
35         .TextFilePromptOnRefresh = False
36         .TextFilePlatform = 65001
37         .TextFileStartRow = 1
38         .TextFileParseType = xlDelimited
39         .TextFileTextQualifier = xlTextQualifierDoubleQuote
40         .TextFileConsecutiveDelimiter = False
41         .TextFileTabDelimiter = True
42         .TextFileSemicolonDelimiter = False
43         .TextFileCommaDelimiter = True
44         .TextFileSpaceDelimiter = False
45         .TextFileColumnDataTypes = Array(1, 1)
46         .TextFileTrailingMinusNumbers = True
47         .Refresh BackgroundQuery:=False
48         End With
49                  
50              Next
51              
52             Application.DisplayAlerts = False
53             Sheets("Sheet1").Delete
54             Sheets("Sheet2").Delete
55             Sheets("Sheet3").Delete
56             Application.DisplayAlerts = True
57              
58              ActiveWorkbook.SaveAs Filename:="AllData" & ".xls", FileFormat:=xlExcel8
59              ActiveWorkbook.Close True
60          Else
61              Exit Sub
62          End If
63          
64      End With
65     End Sub

 

posted on 2014-12-21 12:18  银翼飞贼  阅读(1191)  评论(0)  编辑  收藏  举报

导航