identifizieren sie es dann verschieben (Makro)

Question

Ich hatte dieses Projekt in der Chemie eine Liste der Verbundelemente liefern jetzt ich eine Website gefunden hatte, wo es mir eine sehr lange Liste von Elementen gibt:

ich hatte diesen Kodex, aber es funktioniert nicht

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 

können Sie es für mich laufen zu lassen? Sie können Ihren eigenen Algorithmus vonc haben.

Answer 1

die Liste Unter der Annahme, ist ständig im gleichen Format (dh Verbindung Namen, leere Zeile, Verbindung Symbole, leere Zeile) dieser schnelle Code funktioniert:

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 

Sie nach dem Ausführen kann dann sortieren nur die Spalten A: B, um die Lücken zu entfernen.

Nachdem ich den ursprünglichen Code ausprobiert hatte, erkannte ich, dass das Problem mit dem Wert der .regulären Eigenschaft auftrat. Ich habe .regular vorher nicht gesehen, also statt NOT .bold getauscht und leere Einträge ignoriert, dann die Zeile hinzugefügt, um den Inhalt der kopierten Zelle zu löschen. Dies ist vor allem, wie der Original-Code als Referenz:

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 es ist eine Liste von Verbindungen, keine Elemente gibt es nur etwa 120 Elemente im Periodensystem! ;)

Answer 2

Eine weitere Möglichkeit, die benötigten Daten über XHR und RegEx abzurufen:

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 

Gibt Ausgang (663 Zeilen gesamt):