Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
8086 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【35195】値を検索で行ごとコピー Help me!! 06/2/23(木) 16:05 質問[未読]
【35199】Re:値を検索で行ごとコピー Kein 06/2/23(木) 17:02 回答[未読]
【35203】Re:値を検索で行ごとコピー Help me!! 06/2/23(木) 17:37 質問[未読]
【35204】Re:値を検索で行ごとコピー Kein 06/2/23(木) 17:54 回答[未読]
【35195】値を検索で行ごとコピー
質問  Help me!!  - 06/2/23(木) 16:05 -
引用なし
パスワード
   ここの過去の記事を参考に自分なりにマクロを作って見ました。
でもうまくいきません。

下の表の様に、表１でC列に1162という番号がある行を丸ごと表2に順番にコピーしていきたいのです。

表１（シート名 2006.2)

　　　A　　　B　　　C　　　D　　・・・
１　　2月　 1日　　1162　　立替金
２　　　　　4日　　1162　　立替金
３　　　　　7日　　1180　　その他
４　　　　　8日　　1180　　その他
５　　　　　12日　 1162　　立替金

表２（シート名　立替金）

　　　A　　　B　　　C　　　D　　・・・
１　　2月　 1日　　1162　　立替金
２　　　　　4日　　1162　　立替金
３　　　　　12日　 1162　　立替金

私が作ったVBAは

Sub 検索()
　Dim b As Range

　Dim FirstAddress As String
　Dim RowNo As Integer

　RowNo = 2
　
　'Sheet"2006.2"のC3からC140に
　With Worksheets("2006.2").Range("C3:C140")
　　'「1162」という値を部分一致で検索する。
　　Set b = .Find("1162", LookIn:=xlValues, LookAt:=xlPart)
　　If Not b Is Nothing Then
　　　FirstAddress = b.Address
　　　Do
　　　　'検索値が見つかったらSheet"立替金"の2列目に順番にコピーする

　　　　b.Copy Destination:=Sheets("立替金").Cells(RowNo, 2)
　　　　
　　　　RowNo = RowNo + 1
　　　　'次を検索する。
　　　　Set b = .FindNext(b)
　　　Loop While Not b Is Nothing And b.Address <> FirstAddress
　　End If
　End With
End Sub

です。


ご指導よろしくお願い致します。
【35199】Re:値を検索で行ごとコピー
回答  Kein  - 06/2/23(木) 17:02 -
引用なし
パスワード
   2006.2シートのAC列を作業列として数式を埋め込み、その結果から1162の入力された
行とB:D列が交差するセル範囲を特定・コピーし、立替金シートのB2以下に"すきまなく"
貼り付ける、というコードです。

Dim Sh As Worksheet

Set Sh = Worksheets("2006.2")
On Error GoTo ELine
With Sh.Range("AC3:AC140")
　 .Formula = "=IF(ISERR(SEARCH(1162,$C3)),"""",1)"
　 Intersect(.SpecialCells(3, 1).EntireRow, Sh.Range("B:D")) _
　 .Copy Worksheets("立替金").Range("B2")
End With
ELine:
Set Sh = Nothing
【35203】Re:値を検索で行ごとコピー
質問  Help me!!  - 06/2/23(木) 17:37 -
引用なし
パスワード
   ▼Kein さん：

これで完璧！！と言いたいのですが、
言い忘れてしまった事が一つあります。
ごめんなさい。

それは、シートが2005.4,2005.5,2005.6,・・・2006.2
といった感じに複数存在していて、最終的には立替金シートにすべて集約したいのです。
ですから、作っていただいたマクロをどうにかデータが無い行に貼り付けていくことは出来ませんか？
今のだとセルB2から上書きしてしまいます。

Intersect(.SpecialCells(3, 1).EntireRow, Sh.Range("A:I")).Copy Worksheets("立替金").Range("B2")
　　　　　　　　　↑
どうにか空欄かどうかチェックしてから空欄行に貼り付ける事は出来ませんか？


よろしくお願い致します。
【35204】Re:値を検索で行ごとコピー
回答  Kein  - 06/2/23(木) 17:54 -
引用なし
パスワード
   んー・・そうするとコピー元シートを特定してしまうようなコードも、マズイという
ことでしょーか ? ならば「アクティブシートの名前の文字、左3文字が 200 である
ことを確認し」立替金シートのB2以下、B列の最終入力行 + 1 へ追加貼り付けする。
というコードに改造するとして・・

Sub Test_Data_Copy()
　 Dim TgR As Range

　 If Left$(ActiveSheet.Name, 3) <> "200" Then
　　　MsgBox "シート名が年月になっているシートを開いて下さい", 48
　　　Exit Sub
　 End If
　 With Worksheets("立替金")
　　　If IsEmpty(.Range("B2").Value) Then
　　　　 Set TgR = .Range("B2")
　　　Else
　　　　 Set TgR = .Range("B65536").End(xlUp).Offset(1)
　　　End If
　 End With
　 On Error GoTo ELine
　 With Range("AC3:AC140")
　　　.Formula = "=IF(ISERR(SEARCH(1162,$C3)),"""",1)"
　　　Intersect(.SpecialCells(3, 1).EntireRow, Range("B:D")) _
　　　.Copy TgR
　　　.ClearContents
　 End With
ELine:
　 If Err.Number <> 0 Then
　　　MsgBox "C列に 1162 が入力されたセルはありません", 48
　 End If
　 Set TgR = Nothing
End Sub
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
8086 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free