Excel VBAに翻訳して頂けませんか？？

ChromeのブックマークをHTMLにエクスポートし、それをExcelへコピペし、本物のブックマークのような項目別に折りたたみができるようなHTMLにいつでも改良してくれるマクロを作っています。以下の処理をVBAで表していただけませんでしょうか？


①先ず「<DT><A HREF=」を検索して、
②その行(※０)から１つ上の行(※１)が「<DL><p>」であり、
③その更に１つ上の行(※２)に「§」の文字が無い場合、
④その行(※２)の文字列の先頭に「<div onclick="obj=document.getElementById('折畳中').style; obj.display=(obj.display=='none')?'block':'none';"><a style="cursor:pointer;">」を追記し、
⑤語尾に「</a></div><div id="折畳中" style="display:none;clear:both;">」を追加する。
⑥更に最初に検索した行(※０)から下方向に1段ずつ「</DL><p>」を検索していき、
⑦該当文字列が見つかった場合、その列の文字列を「</div></DL><p>」にする(置換でも追記でもどっちでもいい)。
⑧この一連の処理をA列又は全てのセル(どちらでもいい)で連続処理する。

⑨次に「▼」を検索して、
⑩その行の文字列の先頭に「<div onclick="obj=document.getElementById('折畳大').style; obj.display=(obj.display=='none')?'block':'none';"><a style="cursor:pointer;">」を追記し、
⑪語尾に「</a></div><div id="折畳大" style="display:none;clear:both;">」を追加する。
⑫更にその行から下方向に1段ずつ「▼」を検索していき、見つかったら
⑬見つかった列の１つ上の文字列が必ず</DL><p>なので「</div></DL><p>」にする(置換でも追記でもどっちでもいい)。

⑭次に「§1」を最上部より検索して、
⑮該当列から２つ上の列内の文字列の先頭に「<div onclick="obj=document.getElementById('折畳小').style; obj.display=(obj.display=='none')?'block':'none';"><a style="cursor:pointer;">」を追記し
⑯語尾に「</a></div><div id="折畳小" style="display:none;clear:both;">」を追加する。
⑰「§1」を最下部より検索して、
⑱見つかった列から１つ上の文字列が必ず</DL><p>なので「</div></DL><p>」にする(置換でも追記でもどっちでもいい)。

⑲最後にA列又は全てのセル(どちらでもいい)の内、「'折畳中'」という文字列をTOP（最上部）から順に「'折畳中1'」「'折畳中2'」「'折畳中3'」・・・と連番付けしていく（置換でも追記でもどっちでもいい)。
⑳また「"折畳中"」という文字列も同じようにTOPから順に連番付けしていく。
21,最後にA列又は全てのセル(どちらでもいい)の内、「'折畳大'」という文字列をTOPから順に「'折畳大1'」「'折畳大2'」「'折22,また「"折畳大"」という文字列も同じようにTOPから順に連番付けしていく。
23,最後にA列又は全てのセル(どちらでもいい)の内、「'折畳小'」という文字列をTOPから順に「'折畳小1'」「'折畳小2'」「'折畳小3'」・・・と連番付けしていく（置換でも追記でもどっちでもいい)。
24,また「"折畳小"」という文字列も同じようにTOPから順に連番付けしていく。


何卒よろしくお願いします。

No.3 ベストアンサー 回答者： ママチャリ 回答日時： 2016/07/04 02:54

ママチャリです。

申し訳ありません。私が書いたサンプルに漏れがあったようです。
FindNextを書き忘れたため、最初に見つかったもののみの処理となっていました。
修正してみたので、こちらでお試しください。

Sub sample①から⑧まで()
Dim c As Range
Dim firstAddress As String
Dim r As Range
With Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set c = .Find("<DT><A HREF=", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
If Not c Is Nothing Then
firstAddress = c.Address
Do
If c.Offset(-1).Value Like "<DL><p>" And _
Not c.Offset(-2).Value Like "*§*" Then
c.Offset(-2).Value = "<div onclick=""obj=document.getElementById('折畳中')" _
& ".style; obj.display=(obj.display=='none')?'block':'none';"">" _
& "<a style=""cursor:pointer;"">" _
& c.Offset(-2).Value _
& "</a></div><div id=""折畳中"" style=""display:none;clear:both;"">"
For Each r In Range(c, Cells(Rows.Count, "A").End(xlUp))
r.Value = Replace(r.Value, "</DL><p>", "</div></DL><p>")
Next
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub

この回答へのお礼

できました！ありがとうございました！！

お礼日時：2016/07/10 19:17

No.2 回答者： ママチャリ 回答日時： 2016/07/03 23:47

Doの位置を変えているようですが、これだと最初に見つかった行しか処理されません。

なぜ、このような作り直しになったのでしょうか？

No.1 回答者： ママチャリ 回答日時： 2016/07/02 10:10

強烈なご質問ですね？とりあえず、仕様通りに①～⑧までのコードを書いてみました。

⑨以降も同じような内容なので、あとはご自分でお願いします。

Sub sample①から⑧まで()
Dim c As Range
Dim firstAddress As String
With Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set c = .Find("<DT><A HREF=", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
If Not c Is Nothing Then
firstAddress = c.Address
Do
If c.Offset(-1).Value Like "「<DL><p>」" And _
Not c.Offset(-2).Value Like "*§*" Then
c.Offset(-2).Value = "<div onclick=""obj=document.getElementById('折畳中')" _
& ".style; obj.display=(obj.display=='none')?'block':'none';"">" _
& "<a style=""cursor:pointer;"">" _
& c.Offset(-2).Value _
& "</a></div><div id=""折畳中"" style=""display:none;clear:both;"">"
Range(c, Cells(Rows.Count, "A").End(xlUp)).Replace What:="</DL><p>", _
Replacement:="</div></DL><p>", LookAt:=xlPart, MatchCase:=True
End If
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub

この回答へのお礼

自分なりに作り直してみた。しかし、追記（又は置換）してほしい文字列は数多くに上りますが、どうしても最上文しか追記処理をしてくれません。御指南頂けると幸いです。

Dim c As Range
Dim firstAddress As String
With Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Do
Set c = .Find("<DT><A HREF=", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
firstAddress = c.Address
If Not c Is Nothing Then
If c.Offset(-1).Value Like " <DL><p>" And _
Not c.Offset(-2).Value Like "*§*" Then
c.Offset(-2).Value = "<div onclick=""obj=document.getElementById('折畳中')" _
& ".style; obj.display=(obj.display=='none')?'block':'none';"">" _
& "<a style=""cursor:pointer;"">" _
& c.Offset(-2).Value _
& "</a></div><div id=""折畳中"" style=""display:none;clear:both;"">"
Range(c, Cells(Rows.Count, "A").End(xlUp)).Replace What:="</DL><p>", _
Replacement:="</div></DL><p>", LookAt:=xlPart, MatchCase:=True
End If
End If
Loop While Not c Is Nothing And c.Address <> firstAddress
End With

お礼日時：2016/07/03 23:12