|
とまとさんありがとうございました。
"Sheet2"のE13が書き換わるのは問題ないのでこのソースで解決しました。
どうもありがとうございました!!
しかし、また問題が出てきてしまいました。(*_ _)人
0件の場合に以下のエラーが出てきました。
頼りっぱなしで大変申し訳ないのですが何かいい処理は
あるでしょうか?お教え願います。(_ _(--;(_ _(--; ペコペコ
実行時エラー'1004'
このコマンドにはデータソースが2行以上必要です。選択したセル範囲に1行しか含まれていない場合はこのコマンドを実行できません。次のいずれかの操作を行ってください。
・フィルタオプションを使用している場合、2行以上のデータで構成されるセル範囲を選択し、[フィルタオプションの設定]コマンドを再度クリックします。
・ピボットテーブルを使用している場合は、セル参照を入力するか、または2行以上の・・・
Sub test_2()
Dim Ws As Worksheet, Fi As Range, R As Range, C As Range, Ad As String
Set Ws = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
※ .Range("A1", .Range("A65536").End(xlUp)).AdvancedFilter _
※ xlFilterCopy, , Ws.Range("E13"), True
Set R = Ws.Range("E14", Ws.Range("E65536").End(xlUp))
For Each C In R
Set Fi = .Columns(1).Find(C.Value, , xlValues, xlWhole)
If Not Fi Is Nothing Then
Ad = Fi.Address
Do
Set Fi = .Columns(1).FindNext(Fi)
Fi.Offset(, 1).Resize(, 4).Copy
C.Offset(, 1).PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
Loop Until Ad = Fi.Address
End If
Set Fi = Nothing
Next C
Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
Set R = Nothing: Set Ws = Nothing
End Sub
|
|