Identify it then Move It (Macro) - vba

Question

I had this project in Chemistry to supply a list of Compound elements
now I had found a website where it gives me a very long list of elements:
I had made this Code but it Doesn't Work
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
Can you make it run for me? you can have your own algorithm ofc.

Answer 1

Assuming the list is constantly in the same format (i.e. Compound name, empty line, Compound Symbols, empty line) this quick code will work:
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
After running you can then just sort columns A:B to remove the blanks.
After trying your original code I realised the problem was with the .regular property value. I've not seen .regular before, so swapped it to NOT .bold instead, and to ignore blank entries, then added the line for clearing the contents of the cell copied. This is most like the original code for reference:
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 it's a list of compounds, not elements, there's only about 120 elements in the periodic table! ;)

Answer 2

Another way to retrieve the data you need via XHR and 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
Gives output (663 rows total):