特定の文字列を検索してその位置情報をもとに文字の切り取りなどをするマクロを教えてください

以下の関数で出来るような内容をマクロに置き換えたいと考えていますが、エラー回避が出来ません。
＞IF(E5="全体",LEFT(F4,FIND(":",F4)-1),IF(D5="","",OFFSET(B5,-A5,0)&D5))

もし、E列のi行目の値が"全体"だったら、F列の(i-1)行目のセルに表示された文字列から
":"を探し、これが頭から数えて何番目から調べ、":"より前の文字列を切り取り、B列のi行目に
切り取った値を入力します。
もし、E列のi行目の値が空白だったら、何も処理はしません。
またもしE列のi行目の値が"全体"＆空白でなければ、B列のi行目の値と、A列のi行目にナンバリングされた値を読み込んで、基準となるB列のi行目から読み込んだ文だけ戻ったところのセルにある文字列と結合したものをB列のi列目に入力します。
上記の状況をマクロで記述したいと思っていますが、エラーが出てなかなか回避できません。
どなたかわかる方がいらっしゃいましたら、教えて頂けますでしょうか。

例）
　　　　　A列　　B列　　　C列　　D列　　E列　　F列
１行目　　　　　　　　　　　　　　　　　　　　　Q1:性別
２行目　　　　　　　　　　　　　　　　　　全体
３行目　　１　　　　　　　　　　　全体
４行目　　２　　　　　　　　　　　男性10代
５行目　　３　　　　　　　　　　　男性20代
６行目　　４　　　　　　　　　　　男性30代
↓
マクロ実行結果
　　　　　A列　　B列　　　C列　　D列　　E列　F列
１行目　　　　　　　　　　　　　　　　　　　　Q1:性別
２行目　　　　　Q1　　　　　　　　　　　全体
３行目　　１　　Q1全体　　　　　　全体　　　
４行目　　２　　Q1男性10代 　　　 男性10代　
５行目　　３　　Q1男性20代　　　 男性20代
６行目　　４　　Q1男性30代　　　 男性30代

ちなみに、私が書いたマクロは↓です。

Sub 設問番号と軸名を結合して入力するマクロ()

Dim maxRow As Integer
Dim i As Integer
Dim moji As String
Dim length As Integer
Dim stringcheck As String
Dim stringmatch As String
Dim Num As Integer


maxRow = Sheets("数表 (2)").Cells(Rows.Count, 4).End(xlUp).Row
MsgBox "このシートの最終行は" & maxRow & "でした"

For i = 1 To maxRow

'もしD列の値が空白なら
If Sheets("数表 (2)").Cells(i, 4) <> "" Then

Sheets("数表 (2)").Cells(i, 2) = ""

Else

If Sheets("数表 (2)").Cells(i, 5) = "全体" Then

length = Cells(i - 1, 6)
stringcheck = Cells(i - 1, 6).Value
stringmatch = ":"
moji = Cells(i - 1, 6).Value
Num = InStrRev(moji, stringmatch) - 1

Sheets("数表 (2)").Cells(i, 2) = Left(moji, Num)

Else
Sheets("数表 (2)").Cells(i, 2) = Offset(Sheets("数表 (2)").Cells(i, 2), Sheets("数表 (2)").Cells(i, 1), 0) & Sheets("数表 (2)").Cells(i, 4)
End If

End If

Next i
End Sub

以上、宜しくお願いします。

No.1 ベストアンサー 回答者： tom04 回答日時： 2015/12/18 19:23

こんばんは！

後半部分がよく判らないのですが、
↓のような感じではどうでしょうか？

Sub Sample1()
Dim i As Long, k As Long, str As String, myRng As Range
With Worksheets("数表(2)")
For i = 1 To .Cells(Rows.Count, "D").End(xlUp).Row
If .Cells(i, "D") = "" Then
.Cells(i, "B").ClearContents
End If
If .Cells(i, "E") = "全体" Then
On Error Resume Next '←念のため//
Set myRng = .Cells(i - 1, "F")
str = Left(myRng, InStr(StrConv(myRng, vbNarrow), ":") - 1)
.Cells(i, "B") = str
k = i
Do
k = k + 1
If .Cells(k, "D") = "" Then Exit Do
.Cells(k, "B") = str & .Cells(k, "D")
Loop
i = k
Else
If Cells(i, "D") <> "" Then
.Cells(i, "B") = .Cells(i, "A") & .Cells(i, "D")
End If
End If
Next i
.Columns.AutoFit
End With
End Sub

※　ご希望通りの動きでなかったら
ごめんなさいね。m(_ _)m

この回答へのお礼

お礼が遅くなりました。
VBAの例を書いて頂きましてありがとうございました。
おかげさまで解決できました！

お礼日時：2016/01/22 09:49