教えて★ExcelでVBのマクロについて

以前ここで質問させていただきました。
http://okwave.jp/qa3029622.html

上の内容のとおり教えていただきました。
マクロにさらにタイトルを追加したいのですが可能でしょうか？

ファイルAのタイトルは5行目から始まり8行目まであります。
ファイルBのタイトルは2行目から始まり6行目まであります。

★ファイルAのタイトルにファイルBのタイトルをつけ加えたい！
以下のソースに付け加えるとしたら、どこにどのように追加すればよいですか？

以上ですがよろしくお願いいたします。

Sub findJoin()

On Error GoTo err

Dim st1 As Worksheet
Dim st2 As Worksheet

Set st1 = ActiveSheet

Workbooks.Open ("870xtd.xls")
Set st2 = Workbooks("870xtd.xls").Sheets(1)

Dim st1MaxRow As Long
Dim st2Maxrow As Long

st1MaxRow = st1.Cells(st1.Rows.Count, "A").End(xlUp).Row
st2Maxrow = st2.Cells(st2.Rows.Count, "AB").End(xlUp).Row

Dim R As Long
For R = 2 To st1MaxRow

Dim nmRng As Range
Set nmRng = st2.Range("AB2:AP" & st2Maxrow).Find(st1.Cells(R, "A").Value, LookIn:=xlValues)

If Not nmRng Is Nothing Then
'発見した。
st2.Range("A" & nmRng.Row & ":AP" & nmRng.Row).Copy Destination:=st1.Range("DQ" & R)
End If

Next
st1.Activate

Set st1 = Nothing
Set st2 = Nothing

Exit Sub

err:
MsgBox Error
End Sub

No.1 ベストアンサー 回答者： x0000x 回答日時： 2007/05/29 10:57

こんにちは。

以前、私が回答した件でしたね。

ご質問のタイトルは
>ファイルAのタイトルは5行目から始まり8行目
>ファイルBのタイトルは2行目から始まり6行目
であり、

(1)ファイルAとファイルBで行数が異なります。検索する？
(2)ファイルAタイトルはＡ列に入力されていますか？
(3)ファイルBのタイトルはA列に入力されていますか？
(4)どのように結合しますか？
　たとえば、
　　ファイルＡのＡ５＋ファイルＢのＢ２をファイルＡのＤＱ５に
　　ファイルＡのＡ６＋ファイルＢのＢ３をファイルＡのＤＱ６に
　　…　格納？

この回答への補足

大変お世話になっております。
前回に引き続きありがとうございます。

行のところは自力でどうにか、新しいマクロをつけることで
可能になりました。お手数おかけいたします。

また、質問があるのですが、お教えいただければ幸いです。
IF関数の条件にさらに、始のIF関数の結果であまったファイルBの
【taro】という文字を含むもの(例taroYamadaやtaroAbe等)を
ファイルAのシート2に同じく行ごとコピーするなどできますか？
Elseで、できるっぽいんですが良くわかりません。

また、ファイルBに同じ名前が2つ以上登録されていた場合
ファイルAへコピーするときに上書きされてしまう恐れがあるので
万が一ファイルBに同じ名前が2つ以上登録されていた場合
ファイルAへコピーされる時に行を追加、すぐ下の行にその内容を追加などできますか？

説明がわかり辛いかとおもいますが、ご了承ください。

補足日時：2007/05/29 14:25

No.3 回答者： x0000x 回答日時： 2007/06/03 00:26

こんばんは。

すみません。
回答するのが遅くなりました。
シート１のA列で途中に空白セルがある場合に、不正な動作を起こします。
以下の「★★」の２行を追加ください。


If st1.Cells(R, "A").Value <> Empty Then '★★
Set nmRng = st2.Range("AB2:AP" & st2maxRow).Find(st1.Cells(R, "A").Value, LookIn:=xlValues)

If Not nmRng Is Nothing Then
'発見した。
InsertRow = findLoop(st1, st2, R, st2maxRow, nmRng) '★
st1maxRow = st1maxRow + InsertRow - 1 '終了行数を補正 '★
R = R + InsertRow - 1 '検索位置補正 '★
Else '★
Set nmRng = st2.Range("AB2:AP" & st2maxRow).Find("taro", LookIn:=xlValues) '★

If Not nmRng Is Nothing Then '★
'taroを発見 '★
InsertRow = findLoop(st1, st2, R, st2maxRow, nmRng) '★
st1maxRow = st1maxRow + InsertRow - 1 '終了行数を補正 '★
R = R + InsertRow - 1 '検索位置補正 '★
End If

End If
End If '★★

※すでに、解決していましたら無視してください。

この回答への補足

すみません。
お礼のところの
>ファイルBの内容が丸ごとファイルAの行にコピーされてしまいます。
は条件でそう出ていたみたいです。私の勘違いです。申し訳ないです。
本当に色々とありがとうございました。
まだマクロのことがまったくわからないので質問することがあるかもしれませんがそのときはよろしくお願いいたします。

補足日時：2007/06/04 10:30

この回答へのお礼

ご回答ありがとうございます。
エラーが表示させず、条件通り表示ができるようになりました。

ただ、マクロを実行するとファイルBの内容が丸ごとファイルAの行にコピーされてしまいます。
やりたいことは、きるようになったので不要な行は削除すれば問題ないのでいいのですが、もしお分かりになるようでしたら教えていただけると幸いです。
本当に色々とありがとうございます。

お礼日時：2007/06/04 09:57

No.2 回答者： x0000x 回答日時： 2007/05/29 18:00

こんにちは。

こんな感じでどうでしょうか？

(1)見つからない場合に【taro】という文字を検索。
(2)複数見つかった場合は、下に行追加する。
'★のコメントは変更部分です。

Sub findJoin()

On Error GoTo err

Dim st1 As Worksheet
Dim st2 As Worksheet

Set st1 = ActiveSheet

Workbooks.Open ("870xtd.xls")
Set st2 = Workbooks("870xtd.xls").Sheets(1)

Dim st1maxRow As Long
Dim st2maxRow As Long

st1maxRow = st1.Cells(st1.Rows.Count, "A").End(xlUp).Row
st2maxRow = st2.Cells(st2.Rows.Count, "AB").End(xlUp).Row

Dim InsertRow As Long
Dim R As Long
R = 2 '★
While R <= st1maxRow '★

Dim nmRng As Range
Set nmRng = st2.Range("AB2:AP" & st2maxRow).Find(st1.Cells(R, "A").Value, LookIn:=xlValues)

If Not nmRng Is Nothing Then
'発見した。
InsertRow = findLoop(st1, st2, R, st2maxRow, nmRng) '★
st1maxRow = st1maxRow + InsertRow - 1 '終了行数を補正 '★
R = R + InsertRow - 1 '検索位置補正 '★
Else '★
Set nmRng = st2.Range("AB2:AP" & st2maxRow).Find("taro", LookIn:=xlValues) '★

If Not nmRng Is Nothing Then '★
'taroを発見 '★
InsertRow = findLoop(st1, st2, R, st2maxRow, nmRng) '★
st1maxRow = st1maxRow + InsertRow - 1 '終了行数を補正 '★
R = R + InsertRow - 1 '検索位置補正 '★
End If

End If

R = R + 1 '繰り返し回数を更新 '★

Wend

st1.Activate

Set st1 = Nothing
Set st2 = Nothing

Exit Sub

err:
MsgBox Error
End Sub
'★ 以下追加
Function findLoop(ByVal st1 As Worksheet _
, ByVal st2 As Worksheet _
, ByVal R As Long _
, ByVal st2maxRow As Long _
, ByVal nmRng As Range) As Long

On Error GoTo err

findLoop = 0 '追加行数を初期化

Dim stopAddr As String
stopAddr = nmRng.Address 'Findの終了判定アドレス

Do
findLoop = findLoop + 1 '発見回数をカウント

If findLoop > 1 Then
'複数発見した場合に行を追加
st1.Rows(R + 1).Insert Shift:=xlShiftDown
R = R + 1 'ファイルAの格納位置は追加行へ
End If

'発見した行をCopy
st2.Range("A" & nmRng.Row & ":AP" & nmRng.Row).Copy Destination:=st1.Range("DQ" & R)

'次を検索
Set nmRng = st2.Range("AB2:AP" & st2maxRow).FindNext(nmRng)

If nmRng Is Nothing Then
'発見できないので終了
Exit Do
End If


Loop While nmRng.Address <> stopAddr

Exit Function
err:
MsgBox Error

End Function

この回答への補足

いつも、ご回答ありがとうございます。
エラーはでないのですが、このマクロを実行するとCPUの使用が50％以上になりグルグルとパソコンが回りマクロが、いつまでも修了しません。
もし、なにかお分かりになりましたら教えていただけたら幸いです。

補足日時：2007/06/01 12:03