Вы можете попробовать:
Option Explicit
Sub test()
Dim LastRowA As Long, LastRowC As Long, i As Long, y As Long
Dim strCountry As String
With ThisWorkbook.Worksheets("Sheet2")
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowA Step 10
strCountry = Mid(.Range("A" & i).Value, InStr(1, .Range("A" & i).Value, ":") + 2, Len(.Range("A" & i).Value) - (InStr(1, .Range("A" & i).Value, ":") + 1))
For y = 2 To LastRowA Step 2
LastRowC = .Cells(.Rows.Count, "C").End(xlUp).Row
If .Range("A" & y).Value <> "" Then
.Range("C" & LastRowC + 1).Value = strCountry
.Range("D" & LastRowC + 1).Value = "Object" & Mid(.Range("A" & y).Value, InStr(1, .Range("A" & y).Value, "te") + 2, Len(.Range("A" & y).Value) - (InStr(1, .Range("A" & y).Value, "te") + 1))
.Range("E" & LastRowC + 1).Value = Mid(.Range("A" & y + 1).Value, InStr(1, .Range("A" & y + 1).Value, ":") + 2, Len(.Range("A" & y + 1).Value) - (InStr(1, .Range("A" & y + 1).Value, ":") + 1))
Else
Exit For
End If
Next y
Next i
End With
End Sub
Изображение:
![enter image description here](https://i.stack.imgur.com/nW8BA.png)