cend = 1500 '(最終値：1500はデバック用)

'-----------------------------------------------------
'デバッグ用タイミング（実際はここに実行マクロを入れる）　|
          For j = 1 To 5000: Next '                 |
'-----------------------------------------------------

cend = 50 '(最終値：50はデバック用)

'-----------------------------------------------------
'実際はここに実行マクロを入れる
'（実際のマクロとは、変数"i"を使用し処理するマクロの事)
'例：
     For j = 1 To 26
        Cells(i, j) = Int((99 - 1 + 1) * Rnd + 1)
        Cells(i, j).Interior.ColorIndex = Cells(i, j) Mod 10
     Next
'-----------------------------------------------------

Sub find()
Dim actv As Object
Dim i As Integer, endr1 As Integer, endr2 As Integer
Dim keym As String

Application.ScreenUpdating = False
 Sheets("Sheet1").Select
 Selection.SpecialCells(xlCellTypeLastCell).Select
 endr1 = ActiveCell.Row
 
 Sheets("Sheet2").Select
 Selection.SpecialCells(xlCellTypeLastCell).Select
 endr2 = ActiveCell.Row
 
    c1 = 1: c2 = 1
For i = 1 To endr1
Sheets("Sheet1").Select
    keym = Cells(i, 1)
    Sheets("Sheet2").Select

    Set actv = Range(Cells(1, 1), Cells(endr2, 1)) _
     .find(keym, , , xlWhole, xlByColumns, xlNext, False)
    If actv Is Nothing Then
          Cells(c2, 5) = keym
          c2 = c2 + 1
    Else
          Cells(c1, 3) = keym
          c1 = c1 + 1
    End If
Next
End Sub

Sub Macro1()
' グラフ名
   On Error Resume Next
   ggg1 = ActiveChart.Name
   ggg2 = Mid(ggg1, InStr(1, ggg1, "グ", 1))
   If Err > 0 Then
       MsgBox "グラフを選んでから実行して下さい"
       On Error GoTo 0
       Exit Sub
    End If
       On Error GoTo 0

'現在のサイズ
   hei = ActiveSheet.ChartObjects(ggg2).Chart.ChartArea.Height
   wid = ActiveSheet.ChartObjects(ggg2).Chart.ChartArea.Width
                 
 msg = "現在のサイズは、縦:" & hei & "  横幅:" & wid & "です" & Chr$(10) _
    & " 拡大する倍率を入力して下さい"
  bai = Application.InputBox(msg, "グラフを指定", "1", Type:=1)
    If bai = "" Then
        MsgBox "拡大倍率が力されていません"
        Exit Sub
    End If
'サイズ変更
ActiveSheet.ChartObjects(ggg2).Activate
    ActiveChart.ChartArea.Select
    ActiveSheet.Shapes(ggg2).ScaleWidth bai, msoFalse, msoScaleFromTopLeft
    ActiveSheet.Shapes(ggg2).ScaleHeight bai, msoFalse, msoScaleFromTopLeft

    Range("A2").Select
End Sub

[2003/07/19 (土) 16:41 H.Sさんからの質問]
５００連発の２９４番を参考にして、シート（以下では「入力シート」、 「参照シート」と称しています）を合成したいのですが、入力シート（ＡからＥ 列）、参照シート（ＡからＨ列）で両方のＡ列にキーであって、キーが一致するもの は、入力シート（最後列）のＦ列からL列に、参照シートのＢからＨ列を貼り付ける ようにしたいのですが、修正箇所、修正方法がなかなか難しくてうまくいきません。 （なお、マッチしないものは何も処理しません。）
　大変厚かましいお願いなのですが、できましたらアドバイスを頂けないでしょう か。サンプルデータもお送りしますので、なにとぞよろしくお願いします。

---

５００連発の２９４番は私の出したマクロサンプルでないので その詳細については回答出来ません。
但し、２個のシートのキーワード検索は、HPの１０−2項に 紹介してある方法で簡単に出来るので紹介します。
また、AdvancedFilterで時間が掛かる場合は、tst2のFindで 行なって下さい
（2年程前に同じような質問があったのを忘れており14項とダブリ掲載）
※　使用結果のメールを頂きましたがtst1：４分、tst2：3分50秒との事だった。（結論：時間は同じくらい）

Dim myrang1 As Range
Dim myrang2 As Range
Sub tst1()
Application.ScreenUpdating = False
'入力シートの最終セル
    Sheets("入力シート").Select
    Range("A1").Select
        Selection.CurrentRegion.Select
        cen1 = Selection.Rows.Count
    Range("A1").Select
'ファイル２の最終セル
  Sheets("参照シート").Select
  Range("A1").Select
    Selection.CurrentRegion.Select
    cen2 = Selection.Rows.Count
  Range("A1").Select

' 検索条件セット/出力箇所
    Sheets("参照シート").Select
        Cells(1, 11) = "番号1"   '検索アイテム
        
        Range("B1:H1").Select   '検索結果
        Selection.Copy
        Cells(5, 11).Select
        ActiveSheet.Paste
        Range("I10").Select
    Set myrang1 = Range(Cells(5, 11), Cells(6, 17))
    Set myrang2 = Range(Cells(6, 11), Cells(6, 17))

For i = 2 To cen1
     Application.StatusBar = "検索中---" & i & " / " & cen2
'審判番号を変数へ
      Sheets("入力シート").Select
        bangou = Cells(i, 1)

' データ検索スタ−ト
       Sheets("参照シート").Select
'前データクリアー
           Cells(6, 11) = ""
'検索デ−タセット
        Cells(2, 11) = bangou
'抽出実行
       Range(Cells(1, 1), Cells(cen2, 8)).AdvancedFilter Action:=xlFilterCopy, _
       CriteriaRange:=Range("K1:K2"), _
       CopyToRange:=myrang1, Unique:=False
'貼り付けデ−タを変数へ
    If Cells(6, 11) <> "" Then
       myrang2.Select
       Selection.Copy
       Range("a1").Select

'デ−タ貼り付け
     Sheets("入力シート").Select
        Cells(i, 6).Select
        ActiveSheet.Paste
    End If
Next
'終了処理
Application.ScreenUpdating = True
Sheets("参照シート").Select
    Columns("K:Q").Select
    Selection.Delete Shift:=xlToLeft
    Range("a1").Select
    
    Sheets("入力シート").Select
    Range("a1").Select
End Sub

' -----------------------------------------------------------
Dim dat() As String
Dim myrang1 As Range
Sub tst2()
Application.ScreenUpdating = False
'入力シートの最終セル
    Sheets("入力シート").Select
    Range("A1").Select
        Selection.CurrentRegion.Select
        cen1 = Selection.Rows.Count
    Range("A1").Select
    Set myrang1 = Range(Cells(1, 1), Cells(cen1, 1))
'参照シート最終セル
  Sheets("参照シート").Select
  Range("A1").Select
    Selection.CurrentRegion.Select
    cen2 = Selection.Rows.Count
  Range("A1").Select
  
'キーワードを配列に代入
ReDim dat(cen2)
   For i = 2 To cen2
       dat(i) = Cells(i, 1)
   Next
'キーワードチェック
Sheets("入力シート").Select
For i = 2 To cen2
    Application.StatusBar = msg & "---- " & i & "/" & cen2
    
    Set actv = myrang1.Find(dat(i), , , xlWhole, xlByColumns, xlNext, False)
        If actv Is Nothing Then
               'データ無しを処理する場合ここに記述
        Else
            actv.Select
            ra = ActiveCell.Row
            Cells(ra, 6) = Sheets("参照シート").Cells(i, 2)
            Cells(ra, 7) = Sheets("参照シート").Cells(i, 3)
            Cells(ra, 8) = Sheets("参照シート").Cells(i, 4)
            Cells(ra, 9) = Sheets("参照シート").Cells(i, 5)
            Cells(ra, 10) = Sheets("参照シート").Cells(i, 6)
            Cells(ra, 11) = Sheets("参照シート").Cells(i, 7)
            Cells(ra, 12) = Sheets("参照シート").Cells(i, 8)
        End If
Next

Application.ScreenUpdating = True
End Sub