VBA宏开发求助：为每个目标网站新建工作表并导入整页内容

你的现有代码是把所有网页内容都塞到同一个shResult工作表的不同位置，完全没实现「为每个网站新建工作表」的需求。下面是修改后的代码，能自动为每个目标URL创建独立工作表，并把对应网页的整页内容导入进去：

Private Sub ImportWebPagesToSheets()
    ' 把所有目标URL存到数组里，后续增删更方便
    Dim urls As Variant
    urls = Array( _
        "https://pt.wikipedia.org/wiki/Cruzeiro_do_Sul_(Acre)", _
        "https://pt.wikipedia.org/wiki/Epitaciolândia", _
        "https://pt.wikipedia.org/wiki/Feijó", _
        "https://pt.wikipedia.org/wiki/Marechal_Thaumaturgo" _
    )
    
    Dim ws As Worksheet
    Dim qt As QueryTable
    Dim url As Variant
    Dim sheetName As String
    
    ' 遍历每个URL
    For Each url In urls
        ' 从URL提取最后一段作为工作表名称（处理特殊字符）
        sheetName = Mid(url, InStrRev(url, "/") + 1)
        ' 替换工作表名不允许的字符
        sheetName = Replace(sheetName, "_", " ")
        sheetName = Replace(sheetName, "(", "")
        sheetName = Replace(sheetName, ")", "")
        
        ' 新建工作表并设置名称（处理重名情况）
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(sheetName)
        If Err.Number <> 0 Then
            Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            ws.Name = sheetName
        End If
        On Error GoTo 0
        
        ' 清除工作表原有内容（避免重复导入）
        ws.Cells.Clear
        
        ' 添加QueryTable导入整页内容
        Set qt = ws.QueryTables.Add( _
            Connection:="URL;" & url, _
            Destination:=ws.Range("A1") _
        )
        
        ' 设置导入参数
        With qt
            .WebSelectionType = xlEntirePage
            .WebFormatting = xlWebFormattingAll
            .Refresh BackgroundQuery:=False ' 等待导入完成再继续
            .Delete ' 导入后删除QueryTable，避免后续刷新干扰
        End With
    Next url
End Sub

关键修改说明： #

• 用数组管理URL：不用一个个定义a1-a4变量，后续要加新网站直接往数组里加就行，维护更简单
• 自动新建工作表：通过Sheets.Add创建新表，从URL提取名称并处理特殊字符（Excel工作表名不能有/\:*?"<>|这些字符），同时加了重名判断——如果同名表已经存在，就直接用现有表
• 独立工作表导入：每个网页的QueryTable都绑定到对应新工作表的A1单元格，确保内容互不干扰
• 清理与优化：导入前清空工作表内容，导入完成后删除QueryTable，避免后续误触发刷新

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