好久没来写博客,刚刚一看上一篇居然还是半年前写的。不久前换了份工作,工作中有了些新的小玩意,决定给记录下来:)
以下代码是用于将多个文本文件合并到一个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