' ============================================================' 辅助函数：将“中文 拉丁”格式拆分为中文和拉丁两部分' 如果字符串中没有空格，则中文=原字符串，拉丁=""' ============================================================Private Function SplitTaxon(str As String) As Variant    Dim result(1) As String    Dim spacePos As Integer    spacePos = InStr(str, " ")    If spacePos > 0 Then        result(0) = Left(str, spacePos - 1)        result(1) = Mid(str, spacePos + 1)    Else        result(0) = str        result(1) = ""    End If    SplitTaxon = resultEnd Function' ============================================================' 主程序：获取植物分类信息，拆分为中英文，写入指定列' 列布局：A=植物名(输入)，B=属中，C=属拉，D=种中，E=种拉，'         F=门中，G=门拉，H=纲中，I=纲拉，J=目中，K=目拉，'         L=科中，M=科拉' ============================================================Sub GetPlantInfo_Final()    Dim ws As Worksheet    Dim lastRow As Long    Dim i As Long    Dim plantName As String    Dim ie As Object    Dim htmlDoc As Object    Dim treeElement As Object    Dim treeText As String    Dim taxonDict As Object    Dim timeout As Date    Dim allEls As Object, el As Object    Dim words() As String    Dim j As Long, k As Long    Dim rankMap As Object    Dim titleText As String    Dim headers As Object, hdr As Object    Dim currentRank As String    Dim word As String    Dim nextWord As String    Dim latinPart As String    Dim rankPositions As Object    Dim arr As Variant    ' ---------- 用户可修改门名显示格式 ----------    Const FIXED_PHYLUM As String = "被子 Angiospermae"   ' 如需改为“被子植物门 Angiospermae”，修改此行    Set ws = ThisWorkbook.Sheets("Sheet1")    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row    On Error Resume Next    Set ie = CreateObject("InternetExplorer.Application")    If ie Is Nothing Then        MsgBox "无法创建 Internet Explorer 对象，请检查系统设置。"        Exit Sub    End If    On Error GoTo 0    ie.Visible = False    ie.Silent = True    For i = 1 To lastRow        plantName = Trim(ws.Cells(i, 1).Value)        If plantName = "" Then GoTo SkipLine        Dim url As String        url = "https://www.iplant.cn/info/" & plantName        ie.Navigate url        timeout = Now + TimeValue("0:00:40")        Do While ie.Busy Or ie.readyState <> 4            DoEvents            If Now > timeout Then                ws.Cells(i, 2).Value = "页面加载超时"                GoTo SkipLine            End If        Loop        Application.Wait (Now + TimeValue("0:00:03"))        Set htmlDoc = ie.Document        ' 检查页面有效性        If InStr(htmlDoc.body.innerText, "没有找到") > 0 Or InStr(htmlDoc.Title, "搜索") > 0 Then            ws.Cells(i, 2).Value = "未找到该植物"            GoTo SkipLine        End If        ' ---------- 定位分类树容器 ----------        Set treeElement = Nothing        On Error Resume Next        Set treeElement = htmlDoc.querySelector(".tree")        If treeElement Is Nothing Then Set treeElement = htmlDoc.querySelector(".classification")        If treeElement Is Nothing Then Set treeElement = htmlDoc.querySelector("#taxon-tree")        If treeElement Is Nothing Then Set treeElement = htmlDoc.querySelector(".taxon-tree")        If treeElement Is Nothing Then            Set headers = htmlDoc.getElementsByTagName("*")            For Each hdr In headers                If InStr(hdr.innerText, "分类树") > 0 And hdr.innerText <> "分类树" Then                    Set treeElement = hdr.parentElement                    If Not treeElement Is Nothing Then                        If InStr(treeElement.innerText, "植物界") > 0 And InStr(treeElement.innerText, "纲") > 0 Then                            Exit For                        End If                    End If                End If            Next hdr        End If        On Error GoTo 0        If treeElement Is Nothing Then            Set allEls = htmlDoc.getElementsByTagName("*")            For Each el In allEls                Dim txt As String                txt = el.innerText                If InStr(txt, "植物界") > 0 And InStr(txt, "纲") > 0 And InStr(txt, "科") > 0 Then                    Set treeElement = el                    Exit For                End If            Next el        End If        ' 初始化字典        Set taxonDict = CreateObject("Scripting.Dictionary")        taxonDict.Add "门", ""        taxonDict.Add "纲", ""        taxonDict.Add "目", ""        taxonDict.Add "科", ""        taxonDict.Add "属", ""        If Not treeElement Is Nothing Then            treeText = treeElement.innerText            ' 清理分隔符            treeText = Replace(treeText, "→", " ")            treeText = Replace(treeText, ">", " ")            treeText = Replace(treeText, "、", " ")            treeText = Replace(treeText, vbCrLf, " ")            treeText = Replace(treeText, vbTab, " ")            Do While InStr(treeText, "  ") > 0                treeText = Replace(treeText, "  ", " ")            Loop            treeText = Trim(treeText)            ' 按空格分割            words = Split(treeText, " ")            Dim wordCount As Long            wordCount = UBound(words) - LBound(words) + 1            ' 第一遍扫描：找出所有阶元的位置和类型            Set rankPositions = CreateObject("Scripting.Dictionary")            rankPositions.Add "门", -1            rankPositions.Add "纲", -1            rankPositions.Add "目", -1            rankPositions.Add "科", -1            rankPositions.Add "属", -1            Dim pos As Long            For pos = LBound(words) To UBound(words)                word = Trim(words(pos))                If Right(word, 1) = "纲" And rankPositions("纲") = -1 Then                    rankPositions("纲") = pos                ElseIf Right(word, 1) = "目" And rankPositions("目") = -1 Then                    rankPositions("目") = pos                ElseIf Right(word, 1) = "科" And rankPositions("科") = -1 Then                    rankPositions("科") = pos                ElseIf Right(word, 1) = "属" And rankPositions("属") = -1 Then                    rankPositions("属") = pos                ElseIf Right(word, 1) = "门" And rankPositions("门") = -1 Then                    rankPositions("门") = pos                End If            Next pos            ' 处理属：若未找到"属"后缀，取位于"科"之后的下一个词（若有），但排除明显不是属名的词（如"Plant"）            If rankPositions("属") = -1 And rankPositions("科") <> -1 Then                Dim startSearch As Long                startSearch = rankPositions("科") + 1                For pos = startSearch To UBound(words)                    word = Trim(words(pos))                    If Not (Right(word, 1) = "纲" Or Right(word, 1) = "目" Or Right(word, 1) = "科" Or Right(word, 1) = "门") Then                        If InStr(word, "Plant") = 0 And Not (word Like "*(*" Or word Like "*)*" Or word Like "【*" Or word Like "*】") Then                            rankPositions("属") = pos                            Exit For                        End If                    End If                Next pos            End If            ' 按顺序解析每个阶元（跳过门，因为使用固定值）            Dim rankNames As Variant            rankNames = Array("纲", "目", "科", "属")            Dim rankIdx As Long            For rankIdx = LBound(rankNames) To UBound(rankNames)                currentRank = rankNames(rankIdx)                pos = rankPositions(currentRank)                If pos >= LBound(words) Then                    Dim term As String                    term = Trim(words(pos))                    ' 如果当前阶元是属且没有"属"字，补上"属"                    If currentRank = "属" And Right(term, 1) <> "属" Then                        term = term & "属"                    End If                    ' 收集后续的拉丁词（最多2个）                    Dim latinCount As Integer                    latinCount = 0                    Dim nextPos As Long                    nextPos = pos + 1                    Do While nextPos <= UBound(words) And latinCount < 2                        nextWord = Trim(words(nextPos))                        If Not (Right(nextWord, 1) = "纲" Or Right(nextWord, 1) = "目" Or Right(nextWord, 1) = "科" Or Right(nextWord, 1) = "属" Or Right(nextWord, 1) = "门") Then                            If nextWord Like "*[A-Za-z]*" Or InStr(nextWord, ".") > 0 Then                                If Not (nextWord Like "*(*" Or nextWord Like "*)*" Or nextWord Like "【*" Or nextWord Like "*】" Or nextWord Like "*（*" Or nextWord Like "*）*") Then                                    term = term & " " & nextWord                                    latinCount = latinCount + 1                                    nextPos = nextPos + 1                                Else                                    Exit Do                                End If                            Else                                Exit Do                            End If                        Else                            Exit Do                        End If                    Loop                    taxonDict(currentRank) = term                End If            Next rankIdx        End If        ' ---------- 补充种名（从页面标题） ----------        titleText = htmlDoc.Title        If InStr(titleText, "|") > 0 Then            titleText = Trim(Split(titleText, "|")(0))        End If        taxonDict("种") = titleText        ' ---------- 强制门名为固定值 ----------        taxonDict("门") = FIXED_PHYLUM        ' ---------- 拆分并写入各列 ----------        ' 属        arr = SplitTaxon(taxonDict("属"))        ws.Cells(i, 2).Value = arr(0)   ' 属中文        ws.Cells(i, 3).Value = arr(1)   ' 属拉丁        ' 种        arr = SplitTaxon(taxonDict("种"))        ws.Cells(i, 4).Value = arr(0)   ' 种中文        ws.Cells(i, 5).Value = arr(1)   ' 种拉丁        ' 门        arr = SplitTaxon(taxonDict("门"))        ws.Cells(i, 6).Value = arr(0)   ' 门中文        ws.Cells(i, 7).Value = arr(1)   ' 门拉丁        ' 纲        arr = SplitTaxon(taxonDict("纲"))        ws.Cells(i, 8).Value = arr(0)   ' 纲中文        ws.Cells(i, 9).Value = arr(1)   ' 纲拉丁        ' 目        arr = SplitTaxon(taxonDict("目"))        ws.Cells(i, 10).Value = arr(0)  ' 目中文        ws.Cells(i, 11).Value = arr(1)  ' 目拉丁        ' 科        arr = SplitTaxon(taxonDict("科"))        ws.Cells(i, 12).Value = arr(0)  ' 科中文        ws.Cells(i, 13).Value = arr(1)  ' 科拉丁SkipLine:        Application.Wait (Now + TimeValue("0:00:02"))    Next i    ie.Quit    Set ie = Nothing    MsgBox "处理完成！"End Sub