VBAでセルの文字列を移動させるプログラム

質問

お世話になります。どうかお力をお貸ししていただけると幸いです。

添付の図のようにセルAに英単語が入っており、続けて英単語のセルの下に和訳が入っているエクセルシートがございます

このシートにおける和訳部分を、英単語が存在するセルの右のセルに自動で移動させるマクロを作成したいのですが実力不足で思いつきません。

単語と和訳のまとまりの間には1～3行ほどの空欄がございます(空欄の数に規則性はございません)。よってこの空欄を目印にして、
A列を上から下へと見ていき、最初に空欄以外のセルを発見し場合は、そのままにする。そして空欄以外のセルにあたった次に下のセルを参照し空欄にあたるまではA列に存在する文字を移動させるというようなプログラムを組めばできそうということはわかるのですが・・・

どうか、どのようにプログラムを書けばよろしいか教えていただけませんでしょうか。
よろしくお願いいたします。

回答No.2

tom04 · ベストアンサー

No.1です。

＞英単語のしたに英語で当該単語の解説がある場合は・・・
となると結局「空白セル」で判断するしかないようですね。

Sub Sample2()
Dim i As Long, k As Long
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "A") <> "" Then
k = i + 1
Do While Cells(k, "A") <> ""
Cells(k, "A").Cut Cells(i, Columns.Count).End(xlToLeft).Offset(, 1)
k = k + 1
Loop
i = k
End If
Next i
End Sub

今度はどうでしょうか？m(_ _)m

お礼

tomo04さん

お世話になっております。
完璧に動作いたしました。

この度はご丁寧に教えていただきありがとうございました。
本当に助かりました!

回答No.1

tom04

こんばんは！

＞よってこの空欄を目印にして・・・

空白を「目印」ではなく、バイト数で判断してみました。

「英単語」→すべて半角文字のはずなので文字数とバイト数が同じ数になる
「和訳」→全角1文字は2バイトとなるので文字数とバイト数は異なる
を利用した方法の一例です。

Sub Sample1()
Dim i As Long, k As Long
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
'▼文字数とバイト数が同じ場合は、単語を判断
If Len(Cells(i, "A")) = LenB(StrConv(Cells(i, "A"), vbFromUnicode)) Then
k = i + 1
'▼文字数とバイト数が異なるセルをi行の右隣りのセルはカット＆コピー
Do While Len(Cells(k, "A")) <> LenB(StrConv(Cells(k, "A"), vbFromUnicode))
Cells(k, "A").Cut Cells(i, Columns.Count).End(xlToLeft).Offset(, 1)
k = k + 1
Loop
i = k
End If
Next i
ActiveSheet.Columns.AutoFit
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

お世話になっております。

早速のご回答を下さりありがとうございます!
非常に助かりました。

さらに教えていただけるととてもありがたいのですが、今回のケースのような場合で、英英辞典のように、英単語のしたに英語で当該単語の解説がある場合はどのようにすればよいかもご教授願えませんでしょうか。

質問に挙げた例は英和辞典のようなケースのデータであったのですが、実は英英辞典のようなケースのデータも処理がしたく、もしも処理をすることができればさらにありがたい限りです。

もしもご存知でしたらどうかよろしくお願いいたします。