如何用Excel VBA按姓名新建工作表并批量添加URL数据查询？

我来帮你搞定这个批量处理球员数据的VBA需求！你的核心问题是要自动为每个唯一球员创建工作表，并将对应年份的数据查询统一存入对应表中，下面是修改后的完整代码，以及关键逻辑的解释：

完整修改后的VBA代码 #

Sub BatchPlayerDataQuery()
    Dim wsSource As Worksheet
    Dim cell As Range
    Dim fullName As String, firstName As String, lastName As String, yearStr As String
    Dim targetWs As Worksheet
    Dim existingSheets As Object
    Dim nextEmptyRow As Long
    
    ' 初始化字典，用于记录已创建的球员工作表
    Set existingSheets = CreateObject("Scripting.Dictionary")
    
    ' 设置数据源工作表（假设你的姓名年份列表在名为"URL列表"的工作表里，可自行修改）
    Set wsSource = ThisWorkbook.Worksheets("URL列表")
    
    ' 遍历数据源的每一行（自动识别A列最后一行有数据的位置）
    For Each cell In wsSource.Range("A2:A" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row)
        ' 拆分单元格内容为姓名和年份
        Dim parts() As String
        parts = Split(cell.Value, " ")
        yearStr = parts(UBound(parts)) ' 最后一个元素是年份
        fullName = Left(cell.Value, Len(cell.Value) - Len(yearStr) - 1) ' 提取完整姓名
        ' 拆分姓名为名字和姓氏（假设姓名是"名 姓"格式）
        Dim nameParts() As String
        nameParts = Split(fullName, " ")
        firstName = nameParts(0)
        lastName = nameParts(1)
        
        ' 检查是否已存在该球员的工作表
        If Not existingSheets.Exists(fullName) Then
            ' 新建工作表并命名为球员姓名
            Set targetWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            targetWs.Name = fullName
            existingSheets.Add fullName, targetWs ' 存入字典标记已创建
        Else
            ' 切换到已存在的工作表
            Set targetWs = ThisWorkbook.Worksheets(fullName)
        End If
        
        ' 找到工作表中第一个空行（从A列开始找）
        nextEmptyRow = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row + 1
        If nextEmptyRow = 2 Then nextEmptyRow = 5 ' 保持和你原代码一致，新表从第5行开始
        
        ' 构建正确的查询URL（修复了原代码缺少?的问题）
        Dim queryURL As String
        queryURL = "URL;http://www.fanfooty.com.au/players/year.php?firstname=" & firstName & "&surname=" & lastName & "&year=" & yearStr
        
        ' 添加查询表到目标工作表
        With targetWs.QueryTables.Add(Connection:=queryURL, Destination:=targetWs.Range("A" & nextEmptyRow))
            .Name = fullName & "_" & yearStr ' 给查询表命名，避免重复冲突
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebTables = "1"
            .WebFormatting = xlWebFormattingNone
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
        
        ' 在当前查询数据后插入R:S列（和你原代码逻辑一致）
        targetWs.Range("R:S").EntireColumn.Insert
    Next cell
    
    MsgBox "所有球员数据查询已完成！", vbInformation
End Sub

关键逻辑解释 #

• 用字典跟踪已创建的工作表：Scripting.Dictionary可以快速判断某个球员的工作表是否已经存在，避免重复创建，提升运行效率。
• 动态拆分单元格内容：通过Split函数把每行的"姓名 年份"拆分成单独的姓名和年份，再进一步拆分名字和姓氏，用于拼接正确的查询URL。
• 自动定位插入位置：每次查询前找到工作表的下一个空行，确保不同年份的数据不会覆盖之前的内容，保持数据的连贯性。
• 修复URL格式错误：原代码中URL缺少了关键的?（正确格式应为year.php?firstname=...），这个问题已经修复，保证查询链接可以正常访问。
• 自适应数据源范围：代码会自动读取数据源表中A列从第2行到最后一行的所有数据，不需要手动指定固定范围（比如原代码的a200:a211）。

使用注意事项 #

1. 确保你的数据源工作表命名为URL列表，如果不是，修改代码中Set wsSource = ThisWorkbook.Worksheets("URL列表")这一行的工作表名称。
2. 假设你的姓名格式是"名 姓"（比如Dan Butler），如果有中间名的情况，需要调整姓名拆分的逻辑。
3. 如果运行时提示"找不到Scripting.Dictionary"，需要在VBA编辑器中添加引用：打开工具→引用，勾选"Microsoft Scripting Runtime"。

内容的提问来源于stack exchange，提问作者user9198458