Question

我想知道如何制作一个宏来读取特定网址变量的列表并进行数据查询和另一个名称的新工作表。

例如，在我的网址标签中，我有这个：

        1
Daniel  Butler      2017    1
Daniel  Butler      2018    1
Jack    Riewoldt    2007    2
Jack    Riewoldt    2008    2
Jack    Riewoldt    2009    2
Jack    Riewoldt    2010    2
Jack    Riewoldt    2011    2
Jack    Riewoldt    2012    2
Jack    Riewoldt    2013    2
Jack    Riewoldt    2014    2
Jack    Riewoldt    2015    2
Jack    Riewoldt    2016    2
Jack    Riewoldt    2017    2
Jack    Riewoldt    2018    2

我想要的是能够为＆＃34; dan butler＆＃34;制作标签。和＆＃34; jack riewoldt＆＃34;在他们的标签中显示每年的统计数据。因此，例如dan butler选项卡将包含2017和2018年的统计数据。从我的网址标签中，您可以看到侧面的数字1和2。我期望的是，宏会读取带有1和2的列，并且如果该数字在循环时发生变化，则只会生成一个新选项卡。

我使用的网址是这个我拥有的网址是：http://www.fanfooty.com.au/players/year.php?firstname=Dylan&surname=Grimes&year=2018

正如您所看到的，唯一的变量是名字和姓氏以及年份。

我现在拥有的是：

Option Explicit

Public Sub GetAllUrls()
Dim wsURL As Worksheet
Set wsURL = ThisWorkbook.Worksheets("URL") 'here we define the urls worksheet

Dim i As Long
For i = 1 To 14 'we assume the data is in A1 to C14 (A=name, B=surname, C=year)
    AddConnection wsURL.Cells(i, 1), wsURL.Cells(i, 2), wsURL.Cells(i, 3)
Next i
End Sub

Public Sub AddConnection(Name, Surname, Year)
Dim ws As Worksheet

Set ws = ThisWorkbook.Worksheets.add(After:=ActiveSheet) 'add a new sheet
ws.Name = Left(Name & " " & Surname & " " & Year, 31) 'rename sheet (sheet names must be max 31 characters)

With ws.QueryTables.add(Connection:= _
    "URL;http://www.fanfooty.com.au/players/year.php?firstname=" & Name & "&surname=" & Surname & "&year=" & Year _
    , Destination:=Range("$A$1"))
    .Name = Name & " " & Surname & " " & Year
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlAllTables
    .WebFormatting = xlWebFormattingNone
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
End With
End Sub

Answer 1

请试一试，看看这是否是您想要实现的目标。

Dim ws As Worksheet
Dim destCell As Range

Public Sub GetAllUrls()
Dim wsURL As Worksheet
Dim i As Long
Dim x, dict
Dim shName As String

For Each ws In ThisWorkbook.Sheets
    Application.DisplayAlerts = False
    If Not LCase(ws.Name) Like "url*" Then ws.Delete
Next ws
Set wsURL = ThisWorkbook.Worksheets("URL") 'here we define the urls worksheet
x = wsURL.Range("A1:C14").Value
Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1) 'we assume the data is in A1 to C14 (A=name, B=surname, C=year)
    shName = x(i, 1) & " " & x(i, 2)
    If Not dict.exists(shName) Then
        dict.Item(shName) = ""
        Set ws = ThisWorkbook.Sheets.Add(after:=ActiveSheet)
        ws.Name = shName
        Set destCell = ws.Range("A1")
        destCell.Interior.Color = vbYellow
    Else
        Set ws = ThisWorkbook.Sheets(shName)
        Set destCell = ws.Cells(ws.UsedRange.Rows.Count + 2, 1)
        destCell.Interior.Color = vbYellow
    End If
    AddConnection ws, x(i, 1), x(i, 2), x(i, 3)
    ws.UsedRange.Columns.AutoFit
Next i

Set dict = Nothing
End Sub

Public Sub AddConnection(ByVal destSheet As Worksheet, Name, Surname, Year)

With ws.QueryTables.Add(Connection:= _
    "URL;http://www.fanfooty.com.au/players/year.php?firstname=" & Name & "&surname=" & Surname & "&year=" & Year _
    , Destination:=destCell)
    .Name = Name & " " & Surname & " " & Year
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlAllTables
    .WebFormatting = xlWebFormattingNone
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
End With
destCell.CurrentRegion.Borders.Color = vbBlack
End Sub

如何根据名称在excel上创建新标签，同时使用查询添加数据？

1 个答案: