Question

我在Chemistry中有这个项目提供复合元素列表现在我找到了一个网站，它给了我很长的元素列表：

this will be the references

我制作了此代码，但它不起作用

Sub move()
    Dim list As Range
    Set list = Range("A1:A2651")

    For Each Row In list.Rows
            If (Row.Font.Regular) Then
                Row.Cells(1).Offset(-2, 1) = Row.Cells(1)
            End If
    Next Row
End Sub

你可以帮我跑吗？你可以拥有自己的算法。

Answer 1

假设列表始终采用相同的格式（即化合物名称，空行，复合符号，空行），这个快速代码将起作用：

Sub move()
Dim x As Integer
    x = 3
With ActiveSheet
    Do Until x > 2651
        .Cells(x - 2, 2).Value = .Cells(x, 1).Value
        .Cells(x, 1).ClearContents
        x = x + 4
    Loop
End With
End Sub

运行后，您只需对A：B列进行排序即可删除空白。

在尝试原始代码后，我意识到问题在于.regular属性值。我之前没有看过.squale，所以将它换成NOT .bold而忽略空白条目，然后添加清除复制单元格内容的行。这与原始代码最相似：

Sub get_a_move_on()
    Dim list As Range
    Set list = ActiveSheet.Range("A1:A2561")

    For Each Row In list.Rows
            If Row.Font.Bold = False And Row.Value <> "" Then
                Row.Cells(1).Offset(-2, 1) = Row.Cells(1)
                Row.Cells(1).ClearContents
            End If
    Next Row
End Sub

P.S它是化合物的列表，而不是元素，元素周期表中只有大约120个元素！ ;）

Answer 2

通过XHR和RegEx检索所需数据的另一种方法：

Sub GetChemicalCompoundsNames()

    Dim sRespText As String
    Dim aResult() As String
    Dim i As Long

    ' retrieve HTML content
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://quizlet.com/18087424", False
        .Send
        sRespText = .responseText
    End With
    ' regular expression for rows
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = "qWord[^>]*?>([\s\S]*?)<[\s\S]*?qDef[^>]*?>([\s\S]*?)<"
        With .Execute(sRespText)
            ReDim aResult(1 To .Count, 1 To 2)
            For i = 1 To .Count
                With .Item(i - 1)
                    aResult(i, 1) = .SubMatches(0)
                    aResult(i, 2) = .SubMatches(1)
                End With
            Next
        End With
    End With
    ' output to the 1st sheet
    With Sheets(1)
        .Cells.Delete
        Output .Range("A1"), aResult
    End With

End Sub

Sub Output(oDstRng As Range, aCells As Variant)
    With oDstRng
        .Parent.Select
        With .Resize( _
            UBound(aCells, 1) - LBound(aCells, 1) + 1, _
            UBound(aCells, 2) - LBound(aCells, 2) + 1 _
        )
            .NumberFormat = "@"
            .Value = aCells
            .Columns.AutoFit
        End With
    End With
End Sub

提供输出（总共663行）：

识别它然后移动它（宏）

2 个答案: