您可以按如下方式创建自己的查找:
Option Explicit
Public outputRow As Long
'VBE > Tools > references > tick MS HTML Object Library, MS XML
Public Sub Main()
outputRow = 0
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Output") ''change as appropriate
ws.Cells.ClearContents
GetTables ws
AddKeys ws, 1
ws.Cells.Columns.AutoFit
ws.Columns("A:G").NumberFormat = "@"
End Sub
Public Sub GetTables(ByVal ws As Worksheet)
Dim http As New XMLHTTP60, html As New HTMLDocument, arr() As Variant 'XMLHTTP60 This will vary according to your Excel version
arr = Array("Currency", "Armor", "Selling Treasure", "Armor", "Weapons", _
"Adventuring Gear", "Tools", "Mounts and Vehicles", "Trade Goods", "Expenses")
Dim i As Long
For i = LBound(arr) To UBound(arr)
DoEvents
With http
.Open "GET", ConstructURL(LCase$(arr(i))), False
.send
html.body.innerHTML = .responseText
End With
PrintTables html, ws
Next i
End Sub
Public Sub PrintTables(ByVal html As HTMLDocument, ByVal ws As Worksheet)
Dim rng As Range, tbl As HTMLTable, currentRow As Object, currentColumn As Object, i As Long, counter As Long
For Each tbl In html.getElementsByTagName("Table")
counter = counter + 1
outputRow = outputRow + 1
Set rng = ws.Range("B" & outputRow)
rng.Offset(, -1) = "Table " & counter
For Each currentRow In tbl.Rows
For Each currentColumn In currentRow.Cells
rng.Value = currentColumn.outerText
Set rng = rng.Offset(, 1)
i = i + 1
Next currentColumn
outputRow = outputRow + 1
Set rng = rng.Offset(1, -i)
i = 0
Next currentRow
Next tbl
End Sub
Public Function ConstructURL(ByVal item As String) As String
ConstructURL = "https://dnd5e.info/equipment/" & item
End Function
Public Sub AddKeys(ByVal ws As Worksheet, Optional ByVal targetColumn As Long = 1)
Dim loopColumn As Range, rng As Range
Set loopColumn = ws.UsedRange.Columns(targetColumn)
Dim cat As String
For Each rng In loopColumn.Cells
If InStr(1, rng.Text, "Table") > 0 Then
cat = rng.Offset(, 1)
End If
If Not IsEmpty(rng.Offset(, 1)) And Not IsEmpty(rng.Offset(, 2)) Then
If IsEmpty(rng) And Not IsEmpty(rng.Offset(, 2)) Then
rng = cat & rng.Offset(, 1)
End If
If IsEmpty(rng) And IsEmpty(rng.Offset(, 2)) Then
rng = cat & rng.Offset(, 1)
End If
End If
Next rng
End Sub
Output:
NoteA 列有一个唯一的键,您可以使用它来查找项目。然而,您需要知道您感兴趣的列,尽管您可以再次匹配列标题。您可以对其进行整理,但已经适合对给定项目进行唯一查找。