vba - 根据工作表中包含的数据连接重命名工作表

Question

我有 100 个 .txt 文件。每个 .txt 都连接到工作簿中的不同工作表。我想根据该表中连接的 .txt 文件的名称来命名该表。

这是一些代码。
不幸的是，它们不起作用，因为我收到错误消息:“名称已被占用”

    Sub MultipleTextFilesIntoExcelSheets()
Dim i As Integer 'a counter to loop through the files in the folder
Dim fname As String, FullName As String 'fname is the name of the file, and FullName is the name of its path
Dim ws As Worksheet 'a workbook object for the workbook where the current macro is running


''' Delete existing data connections
''''''''''''''''''''''''''''''''''''
Do While ActiveWorkbook.Connections.Count > 0
ActiveWorkbook.Connections.Item(ActiveWorkbook.Connections.Count).Delete
Loop


''' Rename raw data sheets to default string
''''''''''''''''''''''''''''''''''''''''''''
i = 1

For Each ws In Worksheets
If ws.Name Like "Test1" Or ws.Name Like "Test2*" = True Then
'Do Nothing
ElseIf ws.Name Like "Test1" Or ws.Name Like "Test2*" = False Then
ws.Name = "Sheet" & i
i = i + 1 'get ready for the next iteration
End If
Next ws


''' Import .txt files
'''''''''''''''''''''
i = 0

'get the name of the first text file
fname = Dir("C:\Sample\Test\*txt")

'loop through the text files to put them onto separate sheets in the Excel book
While (Len(fname) > 0)
'get the full path of the text file
FullName = "C:\Sample\Test\" & fname
i = i + 1  'get ready for the next iteration

Set ws = ThisWorkbook.Sheets("Sheet" & i) 'the current sheet

With ws.QueryTables.Add(Connection:="TEXT;" & FullName, Destination:=ws.Range("A1"))
    .Name = fname
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlOverwriteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = True    'we are using a tab-delimited file
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = False
    .TextFileSpaceDelimiter = False
    .TextFileOtherDelimiter = False
    .TextFileColumnDataTypes = Array(1, 1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
    fname = Dir
End With
Wend


''' Rename sheets to new string
'''''''''''''''''''''''''''''''
For Each ws In Worksheets
If ws.Name Like "Test1" Or ws.Name Like "Test2*" = True Then
'Do Nothing

ElseIf (ws.Name Like "Test1" Or ws.Name Like "Test2*" = False) Then
ws.Name = Left(fname, (Len(fname) - 4))
End If

Next ws
End Sub

先感谢您，
费德

Answer 1

您使用 Dir一次将初始值放入 fname但永远不要改变这个初始值。在第二次循环中，您仍然使用相同的 fname，因此 Excel 会提示您使用的名称已被占用。

插入行 fname = Dir 可能会起作用就在 Next ws 之前.这似乎是您想要的，尽管我对您的代码的整体逻辑感到不舒服，因为尚不清楚它如何保证正确的名称与正确的工作表搭配。编写一个从最初为空的工作簿开始并遍历文件夹导入数据并一次性命名工作表的 sub 可能更有意义。

另外——我认为你的逻辑 ElseIf是模糊的。一方面——为什么不简单的Else ?