使用列表中的名称重命名多个新工作表

Question

我有一个宏，可以从工作簿第一张表中的URL列表中创建多个数据表。目前这些工作表以数字命名，1-12（因为我有12个网址创建工作表）。我应该做的是给每个新工作表命名与单元格相邻的单元格中的名称和工作表1中的URL。

我还想确定这些纸张已经被赋予其自己的A1单元格的名称。

网址位于单元格A1：A12中，名称位于B1：B12。

这是宏的副本......

Sub scrape()
    Dim mystr As String

    For Each ws In Sheets
        Application.DisplayAlerts = False
        If ws.Name <> "EDM" Then ws.Delete
    Next
    Application.DisplayAlerts = True

    For x = 1 To 12
        Worksheets("EDM").Select
        Worksheets("EDM").Activate
        mystr = "url;http://www.nhl.com/ice/player.htm?id=8475791"
        mystr = Cells(x, 1)
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = x

        ' Macro1 Macro
        With ActiveSheet.QueryTables.Add(Connection:= _
                                         mystr, Destination:=Range("$B$2"))
            '.CommandType = 0
            .Name = "player.htm?id=8475791"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = "4"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With

    Next x
End Sub

Answer 1

假设：

代码：

Sub go()
    ' variables "ws" and "last" will refer to sheets. 
    Dim ws, last As Worksheet
    Dim r, c As Range
    ' This range is the list of NAMES, in this case in column B
    Set r = Worksheets("Sheet3").Range("B1:B3")

    ' We step over each cell in the list of names
    For Each c In r
        ' The cell contents contain the new sheet name
        Name = c.Value
        ' We determine which sheet is currently the last sheet
        Set last = Worksheets(Worksheets.Count)
        ' We add a new sheet, placing it after the last sheet
        Set ws = Worksheets.Add(After:=last)
        ' Set the name of the new sheet
        ws.Name = Name
        ' Inside the new sheet, write our NAME into cell "A1"
        ws.Range("A1").Value = Name
    Next c
End Sub

产地：

Answer 2

我通常使用offset（x，y）从另一个单元格中获取单元格。然后，您可以使用Range（＆＃34; A1＆＃34;）。offset（x，y）来获取工作簿中的特定单元格。

您的代码应该可以正常工作，只要您替换：

mystr = "url;http://www.nhl.com/ice/player.htm?id=8475791"
 'mystr As String
mystr = Cells(x, 1)
Worksheets.Add(After:=Worksheets(Worksheets.count)).Name = x

使用这些行：

mystr = "url;" & Range("A1").offset(x, 0).Value
myname = Range("A1").offset(x, 1).Value
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = myname

Answer 3

解决了！

Option Explicit
Option Base 0

Sub AddSheets()
Dim element As Variant, aURLs() As Variant, aNames() As Variant
Dim wsName As String, i As Long

 'aURLs() = WorksheetFunction.Transpose(Range("URLs"))
 'aNames() = WorksheetFunction.Transpose(Range("Names"))
aURLs() = WorksheetFunction.Transpose(Range("B2", Range("B2").End(xlDown)))
aNames() = WorksheetFunction.Transpose(Range("A2", Range("A2").End(xlDown)))

Application.DisplayAlerts = False
For i = LBound(aURLs) To UBound(aURLs)
    If WorkSheetExists(CStr(aNames(i))) Then Worksheets(aNames(i)).Delete
    Sheets.Add After:=Sheets(ActiveWorkbook.Sheets.Count)
    ActiveSheet.Name = aNames(i)
    ActiveSheet.Range("A2") = ActiveSheet.Name
    MyQuery CStr(aURLs(i)), CStr(aNames(i))
Next i

Application.DisplayAlerts = True
End Sub

Sub MyQuery(urlString As String, nameString As String)
 'MsgBox urlString
With ActiveSheet.QueryTables.Add(Connection:="URL;" & urlString, _
    Destination:=Range("$B$1"))
    .Name = nameString
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlSpecifiedTables
    .WebFormatting = xlWebFormattingNone
    .WebTables = "4"
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
End With

End Sub

 'WorkSheetExists in activeworkbook:
Function WorkSheetExists(aSheetName As String) As Boolean
Dim ws As Worksheet
On Error GoTo notExists
Set ws = Worksheets(aSheetName)
WorkSheetExists = True
Exit Function
notExists:
WorkSheetExists = False
End Function