Excel：使用VBA和文件名太长的名称表导入文件
我已经调整了我在这里find的代码，该代码将文本文件拉入并将数据粘贴到新的工作表中。 这个文件应该为表单命名文本文件的名称，但是我的文本文件名太大了。 看来excel表可以是31个字符长。 如何调整此代码以使用文本文件名的前31个字符命名工作表？
我也想要代码来提示我select文件夹的目的地。 我已经尝试了一些东西，但还没有弄明白。
Sub ImportManyTXTs_test() Dim strFile As String Dim ws As Worksheet strFile = Dir("I:\path\*.lev") Do While strFile <> vbNullString Set ws = Sheets.Add With ws.QueryTables.Add(Connection:= _ "TEXT;" & "I:\path\" & strFile, Destination:=Range("$A$1")) .Name = strFile .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 437 .TextFileStartRow = 1 .TextFileParseType = xlFixedWidth .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = False .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(xlYMDFormat, 1, 1) .TextFileFixedColumnWidths = Array(22, 13, 13) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With strFile = Dir Loop End Sub 将.Name = strFile更改为
If Len(strFile) < 31 Then .Name = strFile Else .Name = Mid(strFile, 1, 31) End If
使用LEFT()函数仅获取文件名的前31个字符，如下所示：
Sub ImportManyTXTs_test() Dim strFile As String Dim ws As Worksheet strFile = Dir("I:\path\*.lev") Do While strFile <> vbNullString Set ws = Sheets.Add With ws.QueryTables.Add(Connection:= _ "TEXT;" & "I:\path\" & strFile, Destination:=Range("$A$1")) .Name = LEFT(strFile,31) .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 437 .TextFileStartRow = 1 .TextFileParseType = xlFixedWidth .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = False .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(xlYMDFormat, 1, 1) .TextFileFixedColumnWidths = Array(22, 13, 13) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With strFile = Dir Loop End Sub
我设法弄清楚如何让它提示文件夹的位置，但上述build议都没有奏效。 工作表仍然获取默认标签。
Sub ImportManyTXTs_test() Dim foldername As String With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False .Show On Error Resume Next foldername = .SelectedItems(1) Err.Clear On Error GoTo 0 End With Dim strFile As String Dim ws As Worksheet strFile = Dir(foldername & "\" & "*.lev") Do While strFile <> vbNullString Set ws = Sheets.Add With ws.QueryTables.Add(Connection:= _ "TEXT;" & foldername & "\" & strFile, Destination:=Range("$A$1")) .Name = Left(strFile, 31) .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 437 .TextFileStartRow = 1 .TextFileParseType = xlFixedWidth .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = False .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(xlYMDFormat, 1, 1) .TextFileFixedColumnWidths = Array(22, 13, 13) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With strFile = Dir Loop End Sub
' using for each loop For Each ws In ThisWorkbook.Sheets ws.Rows("1:45").NumberFormat = "@" ws.Rows("1:45").Replace _ What:="=", Replacement:="", _ SearchOrder:=xlByColumns, MatchCase:=True Next For Each ws In ThisWorkbook.Sheets If Not IsEmpty(ws.Cells(16, 2).Value) Then ws.Name = ws.Cells(16, 2).Value End If Next