16-02_kensaku.htm

タイトル欄のアドレスは、エクセルファンクラブの該当する頁へのリンク先です。
詳しい事は、こちらのお願いをご覧になってください。

項目を見出しにして、見出しを項目として抽出するには？

***** 【Sheet1】 *****
　　　Ａ　　　　　　Ｂ　　　　　Ｃ　　　　　　Ｄ　　　　　Ｅ
1　クラブ名　　生徒名　　生徒名　　生徒名　　生徒名
2　野球部　　　一太郎　　花子　　　黒子　　　二太郎
3　テニス部　　三太郎　　花子
4　水泳部　　　二太郎　　黒子
5　書道部　　　一太郎　　三太郎
6　音楽部　　　花子　　黒子

***** 【Sheet2】 *****
　　　　Ａ　　　　　　Ｂ　　　　　　Ｃ　　　　　　Ｄ
1　生徒名　　　クラブ名　　クラブ名　　クラブ名
2　一太郎　　　野球部　　　書道部
3　花子　　　　野球部　　　テニス部　音楽部
4　黒子　　　　野球部　　　水泳部　　音楽部
5　三太郎　　テニス部　　書道部
6　二太郎　　野球部　　　水泳部

上記の【Sheet1】のデータを、【Sheet2】に抽出します。
シート名は Sheet1 とし、Sheet2 は存在するが使われていないものとします。
元データにはＡ１セルからデータが書かれていて、
Ａ列にはクラブ名、１行目には「生徒名」と書いた見出しがあるものとします。
データは最下行まで空行がないこと、生徒名は左に詰めて書かれていることとします。
　 Sub Narabekae()
    Dim n As Long, m As Integer, k As Long, j As Integer
    Dim res As String, INI As String, Nam As String
    Dim WS2 As Worksheet
    res = MsgBox("Sheet2 の値をクリアしてから転記します。", vbOKCancel + vbInformation, "並べ替え")
    If res = vbCancel Then Exit Sub
    Application.ScreenUpdating = False
    Set WS2 = Worksheets("Sheet2")
    WS2.Cells.ClearContents
    ' 生徒名の転記
    WS2.Cells(1, 1).Value = "生徒名"
    With Worksheets("Sheet1")
      k = 2
      n = 2
      Do Until .Cells(n, 1).Value = ""
        m = 2
        Do Until .Cells(n, m).Value = ""
          WS2.Cells(k, 1).Value = .Cells(n, m).Value
          k = k + 1
          m = m + 1
        Loop
        n = n + 1
      Loop
      With WS2
        .Select
        ' Sort
        .Range("A2").Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin
        ' 重複削除
        INI = .Cells(2, 1).Value ' 生徒名の初期値
        n = 3
        Do Until .Cells(n, 1).Value = ""
          If .Cells(n, 1).Value = INI Then
            Rows(n).Delete shift:=xlUp
          Else
            INI = .Cells(n, 1).Value ' 初期値の更新
            n = n + 1
          End If
        Loop
      End With
      ' 所属クラブ名の転記
      n = 2
      Do Until .Cells(n, 1).Value = ""
        INI = .Cells(n, 1).Value ' Sheet1 からクラブ名を取得
        m = 2
        Do Until .Cells(n, m).Value = ""
          Nam = .Cells(n, m).Value ' Sheet1 から生徒名を取得
          k = 2
          Do Until WS2.Cells(k, 1).Value = ""
            If WS2.Cells(k, 1).Value = Nam Then
              j = 2
              Do
                If WS2.Cells(k, j).Value = "" Then
                  WS2.Cells(k, j).Value = INI
                  If WS2.Cells(1, j).Value = "" Then WS2.Cells(1, j).Value = "クラブ名"
                  Exit Do
                Else
                  j = j + 1
                End If
              Loop
            End If
            k = k + 1
          Loop
          m = m + 1
        Loop
        n = n + 1
      Loop
      .Cells(1, 1).Value = "生徒名"
    End With
    Set WS2 = Nothing
    Application.ScreenUpdating = True
    MsgBox "終わりました。"
End Sub

　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

複数のシートから抽出･集計するには
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200107/01070050.txt
　「特殊な分類集計の方法だと思うんですが」　【編集ラウンジ】

***　Sheet1　***
　　　Ａ　　　　Ｂ　　　Ｃ
1 　品番　サイズ　数量
2　AW-1　　10X50　　5
3　AW-3　　10X60　　2
4　AW-9　　50X60　　9
***　Sheet2　***
　　　Ａ　　　　Ｂ　　　Ｃ
1 　品番　サイズ　数量
2　AW-3　　10X60　　3
3　AW-5　　20X90　　5
4　AW-9　　50X60　　1
***　Sheet3　***
　　　Ａ　　　　Ｂ　　　Ｃ
1 　品番　サイズ　数量
2　AW-5　　20X90　　9
3　AW-7　　10X80　　2

***　Sheet4　***　　
　Ａ　　　　Ｂ　　　Ｃ
1 　品番　サイズ　数量
2　AW-1　　10X50　　　5
3　AW-3　　10X60　　　5
4　AW-5　　20X90　　14
5　AW-7　　10X80　　　2
6　AW-9　　50X60　　10
　

上記の、Sheet1からSheet3を、Sheet4に集計します。
　　Sub test()
　　　Dim WS(1 To 4) As Worksheet
　　　Dim LastRow(1 To 4) As Long
　　　Dim i As Long
　　　'オブジェクト変数を設定
　　　Set WS(1) = Worksheets("Sheet1")
　　　Set WS(2) = Worksheets("Sheet2")
　　　Set WS(3) = Worksheets("Sheet3")
　　　Set WS(4) = Worksheets("Sheet4")
　　　Application.ScreenUpdating = False
　　　With WS(4)
　　　　.Select
　　　　'Sheet4をクリア→見出し記入
　　　　.Cells.ClearContents
　　　　.Cells(1, 1) = "品番"
　　　　.Cells(1, 2) = "サイズ"
　　　　.Cells(1, 3) = "数量"
　　　　'各シートの最終行を取得
　　　　LastRow(1) = WS(1).Range("A65536").End(xlUp).Row
　　　　LastRow(2) = WS(2).Range("A65536").End(xlUp).Row
　　　　LastRow(3) = WS(3).Range("A65536").End(xlUp).Row
　　　　'各シートの内容をSheet4に貼り付ける
　　　　For i = 1 To 3
　　　　　LastRow(4) = .Range("A65536").End(xlUp).Row + 1
　　　　　WS(i).Rows("2:" & LastRow(i)).Copy .Cells(LastRow(4), 1)
　　　　Next i
　　　　'Sheet4の最終行を取得
　　　　LastRow(4) = .Range("A65536").End(xlUp).Row
　　　　'A列を昇順にソート
　　　　.Range("A1").Sort Key1:=.Range("A1"), Header:=xlYes
　　　　'同じ品番の数量を集計する
　　　　For i = LastRow(4) To 3 Step -1
　　　　　If .Cells(i, 1) = .Cells(i - 1, 1) Then
　　　　　　.Cells(i - 1, 3) = .Cells(i - 1, 3) + .Cells(i, 3)
　　　　　　.Rows(i).ClearContents
　　　　　End If
　　　　Next i
　　　　'空白行削除
　　　　.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
　　　End With
　　　'オブジェクト変数を初期化
　　　For i = 1 To 4
　　　　Set WS(i) = Nothing
　　　Next i
　　　Application.ScreenUpdating = True
　End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

同じフォルダ内の別の複数のファイルから抽出･集計するには
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200107/01070050.txt
　「特殊な分類集計の方法だと思うんですが」　【編集ラウンジ】

　data1.xls　***　Sheet1　
　　　Ａ　　　　Ｂ　　　Ｃ
1 　品番　サイズ　数量
2　AW-1　　10X50　　5
3　AW-3　　10X60　　2
4　AW-9　　50X60　　9
　data2.xls　***　Sheet2　
　　　Ａ　　　　Ｂ　　　Ｃ
1 　品番　サイズ　数量
2　AW-3　　10X60　　3
3　AW-5　　20X90　　5
4　AW-9　　50X60　　1
　data3.xls　***　Sheet3　
　　　Ａ　　　　Ｂ　　　Ｃ
1 　品番　サイズ　数量
2　AW-5　　20X90　　9
3　AW-7　　10X80　　2

***　total.xls　***　Sheet4　***　　
　Ａ　　　　Ｂ　　　Ｃ
1 　品番　サイズ　数量
2　AW-1　　10X50　　　5
3　AW-3　　10X60　　　5
4　AW-5　　20X90　　14
5　AW-7　　10X80　　　2
6　AW-9　　50X60　　10
　

上記のような、別々のファイルのＡＢ列に記入された内容を、行数を指定してＡ～Ｆ列に抽出します。
ファイルは全て同じフォルダに入っているものとし、そのフォルダにはそれ以外のファイルは
ないものとします。フォルダの場所は、どこにあっても問題ありません。

Sub test()
　Dim WS(1 To 4) As Worksheet
　Dim LastRow(1 To 4) As Long
　Dim PathName As String
　Dim ArrBook As Variant
　Dim i As Long
　'画面の動きを固定
　Application.ScreenUpdating = False
　'データファイルを開く
　PathName = ThisWorkbook.Path & "\"
　ArrBook = Array("data1.xls", "data2.xls", "data3.xls")
　For i = LBound(ArrBook) To UBound(ArrBook)
　　Workbooks.Open PathName & ArrBook(i)
　Next
　'オブジェクト変数を設定
　Set WS(1) = Workbooks("data1.xls").Worksheets("Sheet1")
　Set WS(2) = Workbooks("data2.xls").Worksheets("Sheet2")
　Set WS(3) = Workbooks("data3.xls").Worksheets("Sheet3")
　Set WS(4) = ThisWorkbook.Worksheets("Sheet4")
　With WS(4)
　　'Sheet4をクリア→見出し記入
　　.Cells.ClearContents
　　.Cells(1, 1) = "品番"
　　.Cells(1, 2) = "サイズ"
　　.Cells(1, 3) = "数量"
　　'各シートの最終行を取得
　　LastRow(1) = WS(1).Range("A65536").End(xlUp).Row
　　LastRow(2) = WS(2).Range("A65536").End(xlUp).Row
　　LastRow(3) = WS(3).Range("A65536").End(xlUp).Row
　　'各シートの内容をSheet4に貼り付ける
　　For i = 1 To 3
　　　LastRow(4) = .Range("A65536").End(xlUp).Row + 1
　　　WS(i).Rows("2:" & LastRow(i)).Copy .Cells(LastRow(4), 1)
　　Next i
　　'Sheet4の最終行を取得
　　LastRow(4) = .Range("A65536").End(xlUp).Row
　　'A列を昇順にソート
　　.Range("A1").Sort Key1:=.Range("A1"), Header:=xlYes
　　'同じ品番の数量を集計する
　　For i = LastRow(4) To 3 Step -1
　　　If .Cells(i, 1) = .Cells(i - 1, 1) Then
　　　　.Cells(i - 1, 3) = .Cells(i - 1, 3) + .Cells(i, 3)
　　　　.Rows(i).ClearContents
　　　End If
　　Next i
　　'空白行削除
　　.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
　End With
　'オブジェクト変数を初期化
　For i = 1 To 4
　　Set WS(i) = Nothing
　Next i
　'データファイルを閉じる
　For i = LBound(ArrBook) To UBound(ArrBook)
　　Workbooks(ArrBook(i)).Close SaveChanges:=False
　Next
　'画面の固定を解除
　Application.ScreenUpdating = True
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。
　　コードはtotal.xlsの標準モジュールに記入してください。

縦長の表を、行数を指定して横の列に抽出するには
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200208/02080079.txt　
　「1万個のデータを1ページに50行×2列で100個ずつ100ページに表示するには？」　【編集コーナー】
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200107/01070039.txt
　「縦長の表を折り返して１表に印刷＆１ページに印刷できる行を指定したい」　【編集コーナー】

***　Sheet1　***
　　　Ａ　　Ｂ
1　101　あああ
2　102　いいい
3　103　ううう
4　104　えええ
5　105　おおお
6　106　かかか

***　Sheet1　***
　　　Ａ　　Ｂ　　　　　C　　D
1　101　あああ　　103　ううう
2　102　いいい　　104　えええ
3　105　おおお　　107　ききき
4　106　かかか　　108　くくく
5　109　けけけ　　111　さささ
6　110　こここ　　　112　ししし

マクロを使わない方法で、上記左のデータを右のように２行づつ、CD列に移動します。
　1.　ＡＢ列をＣＤ列にコピーします。
　2.　Ｃ１～Ｄ２までのセルを選択し【右クリック】【削除】【上方向にシフト】します。
　3.　Ａ列を選択し、【挿入】【列】で１列作業列を設けます。
　4.　挿入したＡ列に、Ａ１～Ａ２に「１」、Ａ３～Ａ４に「２」をオートフィルを使って入力します。
　5.　Ａ１～Ａ４を選択し、Ａ４の右下にカーソルを当てて、Ctrlキーを押しながらＡ列の最後のデータまでドラッグします。
　6.　Ａ～Ｅ列を選択し、【データ】【並び替え】で【列Ａ】を昇順に並び替えます。
　7.　余分な行とA列を削除して、完成！　　

***　Sheet1　***
　　　Ａ　　Ｂ
1　101　あああ
2　102　いいい
3　103　ううう
4　104　えええ
5　105　おおお
6　106　かかか

***　Sheet2　***
　　Ａ　　　Ｂ　　　　Ｃ　　　Ｄ　　Ｅ　　　Ｆ
1　101　あああ　103　ううう　　105　おおお
2　102　いいい　104　えええ　106　かかか
　

上記のような、ＡＢ列に記入された内容を、行数を指定してＡ～Ｆ列に抽出します。
Sub test()
　Dim LastRow As Long, gyou1 As Long, gyou2 As Variant
　Dim WS1 As Worksheet, WS2 As Worksheet
　Dim i As Long, j As Long, k As Long
　Set WS1 = Worksheets("sheet1")
　Set WS2 = Worksheets("sheet2")
　gyou1 = 0
　gyou2 = Application.InputBox(Prompt:="１ページ１列分の行数を入力してください", Type:=1)
　If Not VarType(gyou2) = vbBoolean Then
　　Application.DisplayAlerts = False
　　WS2.Activate
　　Cells.ClearContents
　　With WS1
　　　LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
　　　i = 1
　　　j = 1
　　　Do
　　　　gyou1 = gyou1 + gyou2
　　　　For k = j To gyou1
　　　　　Cells(k, 1) = .Cells(i, 1)
　　　　　Cells(k, 2) = .Cells(i, 2)
　　　　　i = i + 1
　　　　　If i > LastRow Then
　　　　　　Cells(k, 1).Select
　　　　　　Exit Do
　　　　　End If
　　　　Next
　　　　For k = j To gyou1
　　　　　Cells(k, 3) = .Cells(i, 1)
　　　　　Cells(k, 4) = .Cells(i, 2)
　　　　　i = i + 1
　　　　　If i > LastRow Then
　　　　　　Cells(k, 1).Select
　　　　　　Exit Do
　　　　　End If
　　　　Next
　　　　For k = j To gyou1
　　　　　Cells(k, 5) = .Cells(i, 1)
　　　　　Cells(k, 6) = .Cells(i, 2)
　　　　　i = i + 1
　　　　　If i > LastRow Then
　　　　　　Cells(k, 1).Select
　　　　　　Exit Do
　　　　　End If
　　　　Next
　　　　Cells(k, 1).Select
　　　　j = j + gyou2
　　　　gyou2 = Application.InputBox(Prompt:="次頁の１列分の行数を入力してください", _
　　　　Default:=gyou2, Type:=1)
　　　　If VarType(gyou2) = vbBoolean Then Exit Do
　　　　If i > LastRow Then Exit Do
　　　Loop
　　End With
　　Application.DisplayAlerts = True
　　MsgBox "終わりました"
　End If
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

セルに入力された名前のシートに、行ごと抽出するには？
http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200108/01080384.txt
　　「次のデータまで空白セルを上のデータと同じにするには？」　【ＶＢＡラウンジ】

***　Sheet1　***
　　Ａ　　　Ｂ　　　Ｃ
1 種類　名前　　年齢
2 　犬　　ポチ　　1歳
3 　　　　　べる　　2歳
4 　猫　　タイガ　5歳
5 　　　　　ピンコ　 3歳
6 　鳥　　ピヨ　　 2歳

***　犬　***        　 ***　猫　***               ***　鳥　***
　　　Ａ　　　Ｂ　　      　　　Ａ　　   Ｂ　　         　　Ａ　　　Ｂ　　
1 　名前　年齢　　     1 　名前　年齢         1　名前　　年齢
2 　ポチ   1歳　　      2 　タイガ　5歳           2　ピヨ　　 2歳
3 　べる   2歳　        3 　ピンコ　 3歳

Sheet1をアクティブにして実行してください。見出行はあらかじめ記入されているものとします。
Sub Test()
    Dim my種類 As String
    Dim C As Range
    my種類 = Range("A2").Value
    For Each C In Range("B2", Range("B65536").End(xlUp))
        If C.Offset(0, -1).Value <> "" Then my種類 = C.Offset(0, -1).Value
        C.Resize(1, 2).Copy Worksheets(my種類).Range("A65536").End(xlUp).Offset(1)
    Next
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

      ***　犬　***
　　Ａ　　　Ｂ　　　Ｃ
1 種類　名前　　年齢
2 　犬　　ポチ　　1歳
3 　　　　　べる　　2歳
     ***　猫　***
　　Ａ　　　Ｂ　　　Ｃ
1 種類　名前　　年齢
2 　猫　　タイガ　5歳
3 　　　　　ピンコ　 3歳
      ***　鳥　***
　　Ａ　　　Ｂ　　　Ｃ
1 種類　名前　　年齢
2　鳥　　ピヨ　　 2歳

Sheet1以外のシートはいったんクリアしてから抽出しています。
Sub miko_test()
　Dim i As Long, N As String, WS As Worksheet
　Worksheets("Sheet1").Select
　For Each WS In ThisWorkbook.Worksheets
　　If WS.Name <> "Sheet1" Then
　　　WS.Cells.ClearContents
　　　Rows(1).Copy WS.Cells(1, 1)
　　End If
　Next
　For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
　　If Cells(i, 1) <> "" Then N = Cells(i, 1)
　　Rows(i).Copy Worksheets(N).Cells(Rows.Count, 2).End(xlUp).Offset(1, -1)
　Next
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

下２ケタの数字で並べ替えるには

Ａ列の数値を、下２ケタの昇順に並べ替えます。
降順の場合、頭の「'」を昇順のコードに付け替えててください。
Sub miko_test1()
　Dim i As Integer
　Application.ScreenUpdating = False
　Range("B1").EntireColumn.Insert
　For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
　　Cells(i, 2) = Right(Cells(i, 1), 2)　　　　　　　　　　　　　　　'下２桁（右から２文字）の数値を抽出
　Next
　Columns("A:B").Sort Key1:=Range("B1")　　　　　　　　　　　　　　　　'昇順に並べ替え
　'Columns("A:B").Sort Key1:=Range("B1"), Order1:=xlDescending　　'降順の場合、こちらのコード
　Columns("B:B").Delete Shift:=xlToLeft
　Application.ScreenUpdating = True
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

セル内の文字列を逆順に並び替えるには？（「あいうえお」を「おえういあ」に）
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200202/02020076.txt
　「セル内の文字を逆さにするには？」　【編集ラウンジ】

1.　書式設定　配置、折り返して全体を表示をチェック
2.　　　〃　　　方向　縦書きを選択
尚、セルの高さは１文字分にして下さい。

データがＡ列にＡ１から順番に入ってて文字数が２０文字以内であるとして・・・Ｂ１に
=MID(A1,20,1)&MID(A1,19,1)&MID(A1,18,1)&MID(A1,17,1)&MID(A1,16,1)
&MID(A1,15,1)&MID(A1,14,1)&MID(A1,13,1)&MID(A1,12,1)&MID(A1,11,1)
&MID(A1,10,1)&MID(A1,9,1)&MID(A1,8,1)&MID(A1,7,1)&MID(A1,6,1)
&MID(A1,5,1)&MID(A1,4,1)&MID(A1,3,1)&MID(A1,2,1)&MID(A1,1,1)
と入れて下までコピーします。

A1の文字列をB1に並べ替えます。
　Function StrRev(Source As String) As String
　 StrRev = StrReverse(Source)
　End Function
　　このコードの使い方は、マクロの使い方(６)ユーザー定義関数（標準モジュール）にあります。
　コードを記入したら、Ｂ１に =StrRev(A1) と入れて下までコピーする。

重複しない値を抽出するには？
http://cgi.fuji.ne.jp/~fj2094/cgi-bin2/wwwlng.cgi?print+200012/00120032.txt
　「重複リストの削除」　【関数ラウンジ】

【データ】【フィルタオプションの設定】【重複するレコードは無視する】にチェック。

　とまと　　　　　　　　　　　　　　　　　　　とまと
　なす　　　　　　　　　　　　　　　　　　　　なす　
　とまと　　　左のような内容を　　　　　　ねぎ　
　ねぎ　　　　右のように表示　
　なす
　とまと

A列に元データがあるとして、最高100行までに対応
　B1に、=IF(COUNTIF(A$1:A1,A1)=1,ROW(),"")
　C1に、=IF(ISERROR(INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1)),"",
　　　　　　　　　　　　　　　　INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1))　　（一行で記入）
そのままドラッグします。

【解析】

　B1の関数　=IF(COUNTIF(A$1:A1,A1)=1,ROW(),"")
　　A$1:A1範囲の中で、A1の値の数が1の場合、その行番号を返し、1でなければ空白にする

　C1の関数　=IF(ISERROR(INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1)),"",
　　　　　　　　　　　　　　　　INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1))

　　ISERROR(INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1))
　　　(INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1))の値がエラーかどうか判定

　　INDEX($A$1:$A$100,SMALL($B$1:$B$100,ROW()),1)
　　　$A$1:$A$100の範囲で、　SMALL($B$1:$B$100,ROW())　行目、1列目の値を返す

　　SMALL($B$1:$B$100,ROW())
　　　$B$1:$B$100の範囲で、ROW()番目に小さい値を返す。ROW()は、その行の行番号
　

一行のデータを項目ごとに列に振り分けるには

あ	＊＊	＊＊	○○	○○	◎◎
い	◎◎	●●	●●	○○	○○	●●
う	＊＊	○○	○○	○○

上のような表を、新しくシートを挿入して下のように表示します。元のデータシートを sheet1 としています。

あ	＊＊	○○	◎◎
	＊＊	○○
い	◎◎	●●	○○	●●
		●●	○○
う	＊＊	○○
		○○
		○○

Sub miko_test()
　Dim WS1 As Worksheet, WS2 As Worksheet
　Dim i As Long, j As Integer
　Dim a As Long, b As Integer, c As Long
　'処理するシートの名前を変更に格納
　Set WS1 = Worksheets("sheet1")　　　　　　　　　
　Application.ScreenUpdating = False '画面の動きを固定
　'右側にシートを追加
　ActiveWorkbook.Sheets.Add After:=WS1
　Set WS2 = Worksheets(ActiveSheet.Name)
　a = 1 '該当行
　b = 2 '該当列
　With WS1
　　'sheet1の1行目から最終行まで処理
　　For i = 1 To .Cells(Application.Rows.Count, 1).End(xlUp).Row
　　　'sheet1、AB列を転記
　　　Cells(a, 1) = .Cells(i, 1)
　　　Cells(a, 2) = .Cells(i, 2)
　　　c = a '該当項目の最初の行を取得
　　　'sheet1の2列目から最終列まで処理
　　　For j = 2 To .Cells(i, .Application.Columns.Count).End(xlToLeft).Column
　　　　If .Cells(i, j + 1) = "" Then Exit For
　　　　If .Cells(i, j) = .Cells(i, j + 1) Then '左のセルと値が同じ場合
　　　　　a = a + 1
　　　　　Cells(a, b) = .Cells(i, j + 1)
　　　　Else '左のセルと値が違う場合
　　　　　b = b + 1
　　　　　a = c
　　　　　Cells(a, b) = .Cells(i, j + 1)
　　　　End If
　　　Next j
　　　b = 2
　　　'使用範囲内の最終行取得
　　　a = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
　　Next i
　End With
　Application.ScreenUpdating = True '画面の固定を解除
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

検索項目を入力して、同じ値があればそのセルを選択し、表示するには？

A1に入力した値と同じ値を、A2以降のＡ列から探して、そのセルを選択して一番上に表示します。
Private Sub Worksheet_Change(ByVal Target As Range)
　Dim i As Long
　If Target.Address <> "$A$1" Then Exit Sub 　　　　'対象がA1以外なら処理しないで終わる
　If Target <> "" Then 　　　　　　　　　　　　　　　　　　'空白でなければ次の処理を実行する
　　'2行目からA列最終行まで繰り返す
　　For i = 2 To Cells(Application.Rows.Count, 1).End(xlUp).Row
　　　If Target = Cells(i, 1) Then 　　　　　　　　　　　　'入力した内容と同じセルがＡ列にあれば
　　　　Cells(i, 1).Select 　　　　　　　　　　　　　　　　　'そのセルを選択
　　　　ActiveWindow.ScrollRow = i 　　　　　　　　　　そのセルの行までスクロール
　　　　Exit Sub 　　　　　　　　　　　　　　　　　　　　　　'処理を終わる
　　　End If
　　Next
　　MsgBox "該当する項目がありませんでした"
　End If
End Sub

検索項目を入力して、同じ値があればその行を検索行の下に挿入

	A	B	C	D	E			A	B	C	D	E
1	抽出前						1	抽出後
2	抽出前						2	抽出後
3	品番	品名	定価	原価	入荷月		3	品番	品名	定価	原価	入荷月
4		aa	150			5行目の検索値 (aaまたは150) に該当する全データを抽出します	4		aa	150
5	品番	品名	定価	原価	入荷月		5	101	aa	100	80	1
6	101	aa	100	80	1		6	102	ee	150	100	5
7	102	aa	150	100	5		7	101	aa	120	100	4
8	101	aa	120	100	4		8	品番	品名	定価	原価	入荷月
9	102	cc	150	100	5		9	101	aa	100	80	1
10	103	bb	130	110	6		10	102	ee	150	100	5
11							11	101	aa	120	100	4
12							12	102	cc	140	120	5
13							13	103	bb	130	110	6

Sub miko_test1()
Dim i As Integer, j As Long, g As Long
'抽出前の最終行を取得
g = Cells(Application.Rows.Count, 1).End(xlUp).Row
'６行目から１列目のデータがなくなるまで繰り返し
j = 6
Do
'１列目から３行目の最終列まで繰り返し
For i = 1 To Cells(3, Application.Columns.Count).End(xlToLeft).Column
If Cells(4, i) = Cells(j, i) Then
Rows("5").Insert Shift:=xlDown
Rows(j + 1).Copy Range("A5")
j = j + 1
Exit For
End If
Next
j = j + 1
If Cells(j, 1) = "" Then Exit Do
Loop
'抽出最終行取得
If Cells(Application.Rows.Count, 1).End(xlUp).Row > g Then
g = Cells(Application.Rows.Count, 1).End(xlUp).Row - g
If MsgBox("抽出分をクリアしていいですか？", vbOKCancel + vbQuestion) = vbOK Then
Rows("5:" & g + 4).Delete Shift:=xlUp
Else
MsgBox "抽出行を削除しませんでした。5行目から" & g + 4 & "行目まで抽出しています"
End If
Else
MsgBox "抽出したデータはありませんでした"
End If
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

	A	B	C	D	E			A	B	C	D	E
1	抽出前						1	抽出後
2	抽出前						2	抽出後
3	品番	品名	定価	原価	入荷月		3	品番	品名	定価	原価	入荷月
4	102	cc	150		5	5行目の検索値全てに合致するデータを抽出します【品名】欄はキーワードで検索	4	102	cc	150		5
5	品番	品名	定価	原価	入荷月		5	102	aacc	150	100	5
6	101	aabb	100	80	1		6	品番	品名	定価	原価	入荷月
7	102	aacc	150	100	5		7	101	aabb	100	80	1
8	101	aacc	120	100	4		8	102	aacc	150	100	5
9	102	aacc	150	100	5		9	101	aacc	120	100	4
10	103	aabb	130	110	6		10	102	aacc	140	120	5
11							11	103	aabb	130	110	6

Sub miko_test2()
　Dim i As Integer, j As Long, g As Long, k As Integer, m As Integer
　'抽出前の最終行を取得
　g = Cells(Application.Rows.Count, 1).End(xlUp).Row
　'６行目から１列目のデータがなくなるまで繰り返し
　j = 6
　Do
　　'１列目から３行目の最終列まで繰り返し
　　For i = 1 To Cells(3, Application.Columns.Count).End(xlToLeft).Column
　　　If Cells(4, i) <> "" And Cells(4, i) <> Cells(j, i) Then
　　　　'品名検索
　　　　If i = 2 Then
　　　　　For k = 1 To Len(Cells(j, 2))
　　　　　　If Mid(Cells(j, 2), k, Len(Cells(4, 2))) = Cells(4, 2) Then
　　　　　　　GoTo pro2 '抽出チェックを継続
　　　　　　End If
　　　　　Next
　　　　End If
　　　　GoTo pro1 '抽出処理を飛ばす
　　　End If
pro2:
　　Next
　　Rows("5").Insert Shift:=xlDown
　　Rows(j + 1).Copy Range("A5")
　　j = j + 1
　　MsgBox j & "行目を抽出"
pro1:
　　j = j + 1
　　If Cells(j, 1) = "" Then Exit Do
　Loop
　'抽出最終行取得
　If Cells(Application.Rows.Count, 1).End(xlUp).Row > g Then
　　g = Cells(Application.Rows.Count, 1).End(xlUp).Row - g
　　If MsgBox("抽出分をクリアしていいですか？", vbOKCancel + vbQuestion) = vbOK Then
　　　Rows("5:" & g + 4).Delete Shift:=xlUp
　　Else
　　　MsgBox "抽出行を削除しませんでした。5行目から" & g + 4 & "行目まで抽出しています"
　　End If
　Else
　　MsgBox "抽出したデータはありませんでした"
　End If
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

組み合わせを表示するには（候補から２項目を組合せと合計）

	A	B	C	D
1	候補	左の候補から右の組み合わせと合計を表示します	組み合わせ	合計
2	10		10 と 20 の合計	30
3	20		10 と 30 の合計	40
4	30		20 と 30 の合計	50

処理する候補のセル範囲（上の例だとA2～A4）を選択してから実行してください。
Sub miko_test()
　Dim i As Long, j As Integer, retu As Integer
　Dim m As Long, mm As Long, n As Integer
　'選択対象がセルでなければ､マクロを中止
　If Not TypeName(Selection) = "Range" Then Exit Sub
　m = Selection.Row '選択範囲の最初の行
　mm = Selection.Rows(Selection.Rows.Count).Row '選択範囲の最後の行
　n = Selection.Columns(1).Column '選択範囲の最初の列
　retu = n + 2 '選択範囲の２列右隣の列
　'選択範囲の最初の行から最後の行まで繰り返し
　For i = m To mm
　　For j = i + 1 To mm
　　　'選択範囲の右隣の列の最終行に記入
　　　Cells(Cells(Application.Rows.Count, retu).End(xlUp).Row + 1, retu) = _
　　　Cells(i, n) & " と " & Cells(j, n) & " の合計"
　　　Cells(Cells(Application.Rows.Count, retu).End(xlUp).Row, retu + 1) = _
　　　Cells(i, n) + Cells(j, n)
　　Next
　Next
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

組合せを表示するには（B列の候補から２・３・・・５項目の組合せと平均）

	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1	名前	点数		２組の組合せと平均			３組の組合せと平均			４組の組合せと平均			５組の組合せと平均
2	A	85		A と B の平均	75		A と B と C の平均	75		A と B と C と D の平均	79.3		A と B と C と D と E の平均	78.8
3	B	65		A と C の平均	80		A と B と D の平均	80.66666667		A と B と C と E の平均	75.5		A と B と C と D と F の平均	77
4	C	75		A と D の平均	88.5		A と B と E の平均	75.66666667		A と B と C と F の平均	73.3		A と B と C と D と G の平均	74.2
5	D	92		A と E の平均	81		A と B と F の平均	72.66666667		A と B と C と G の平均	69.8		A と B と C と D と H の平均	73
6	E	77		A と F の平均	76.5		A と B と G の平均	68		A と B と C と H の平均	68.3		A と B と C と D と I の平均	75.8
7	F	68		A と G の平均	69.5		A と B と H の平均	66		A と B と C と I の平均	71.8		A と B と C と D と J の平均	81
8	G	54		A と H の平均	66.5		A と B と I の平均	70.66666667		A と B と C と J の平均	78.3		A と B と C と E と F の平均	74
9	H	48		A と I の平均	73.5		A と B と J の平均	79.33333333		A と B と D と E の平均	79.8		A と B と C と E と G の平均	71.2
10	I	62		A と J の平均	86.5		A と C と D の平均	84		A と B と D と F の平均	77.5		A と B と C と E と H の平均	70
11	J	88		B と C の平均	70		A と C と E の平均	79		A と B と D と G の平均	74		A と B と C と E と I の平均	72.8

Sub miko_test2()
　Dim i As Long, j As Long, k As Long, m As Long, n As Long
　'B列の最初の行から最後の行まで繰り返し
　For i = 2 To Cells(Application.Rows.Count, 2).End(xlUp).Row
　　'２組の組み合わせ
　　For j = i + 1 To Cells(Application.Rows.Count, 2).End(xlUp).Row
　　　'選択範囲の右隣の列の最終行に記入
　　　Cells(Cells(Application.Rows.Count, 4).End(xlUp).Row + 1, 4) = _
　　　Cells(i, 1) & " と " & Cells(j, 1) & " の平均"
　　　Cells(Cells(Application.Rows.Count, 4).End(xlUp).Row, 5) = _
　　　(Cells(i, 2) + Cells(j, 2)) / 2
　　　'３組の組み合わせ
　　　For k = j + 1 To Cells(Application.Rows.Count, 2).End(xlUp).Row
　　　　Cells(Cells(Application.Rows.Count, 7).End(xlUp).Row + 1, 7) = _
　　　　Cells(i, 1) & " と " & Cells(j, 1) & " と " & _
　　　　Cells(k, 1) & " の平均"
　　　　Cells(Cells(Application.Rows.Count, 7).End(xlUp).Row, 8) = _
　　　　(Cells(i, 2) + Cells(j, 2) + Cells(k, 2)) / 3
　　　　'４組の組み合わせ
　　　　For m = k + 1 To Cells(Application.Rows.Count, 2).End(xlUp).Row
　　　　　Cells(Cells(Application.Rows.Count, 10).End(xlUp).Row + 1, 10) = _
　　　　　Cells(i, 1) & " と " & Cells(j, 1) & " と " & _
　　　　　Cells(k, 1) & " と " & Cells(m, 1) & " の平均"
　　　　　Cells(Cells(Application.Rows.Count, 10).End(xlUp).Row, 11) = _
　　　　　(Cells(i, 2) + Cells(j, 2) + Cells(k, 2) + _
　　　　　Cells(m, 2)) / 4
　　　　　'５組の組み合わせ
　　　　　For n = m + 1 To Cells(Application.Rows.Count, 2).End(xlUp).Row
　　　　　　Cells(Cells(Application.Rows.Count, 13).End(xlUp).Row + 1, 13) = _
　　　　　　Cells(i, 1) & " と " & Cells(j, 1) & " と " & _
　　　　　　Cells(k, 1) & " と " & Cells(m, 1) & " と " & _
　　　　　　Cells(n, 1) & " の平均"
　　　　　　Cells(Cells(Application.Rows.Count, 13).End(xlUp).Row, 14) = _
　　　　　　(Cells(i, 2) + Cells(j, 2) + Cells(k, 2) + _
　　　　　　Cells(m, 2) + Cells(n, 2)) / 5
　　　　　Next
　　　　Next
　　　Next
　　Next
　Next
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

２列の内容によって、他のシートにデータをコピーするには？

シート１				左のシート１から右のシートを作成します	営業・北岡
	A	B	C			A	B	C
1	(部署)	(担当者)	(取引先)		1	(部署)	(担当者)	(取引先)
2	営業	北岡	静岡販売		2	営業	北岡	静岡販売
3	営業	北岡	中部販売		3	営業	北岡	中部販売
4	営業	松田	関西販売
5	管理	田中	四国販売		営業・松田
						A	B	C
					1	(部署)	(担当者)	(取引先)
					2	営業	松田	関西販売

					管理・田中
						A	B	C
					1	(部署)	(担当者)	(取引先)
					2	管理	田中	四国販売

一旦「シ－ト１」以外のシートの、A～C列２行目以降をクリアし、該当のシートを探して「シ－ト１」の内容をコピーします。　　
その名前のシートが存在しない場合、新しくシートを作成します。
　【注意】「シ－ト１」は変更しませんが、それ以外のシートはクリアしてしまいますのでご注意ください。
　　　　　シートをクリアしない場合は、コードの７行目から、１１行目までを削除してください。
　　　　　そうすると、既存のデータにどんどん蓄積していきます。
　　　　
Sub miko_test()
　Dim i As Integer, j As Integer, h As Integer
　Dim S As Object, WS1 As Worksheet
　Application.ScreenUpdating = False '画面の動きを固定
　Set WS1 = Worksheets("シ－ト１")
　With WS1
　　'シ－ト１以外のシートの、A～C列２行目以降をクリア
　　For Each S In Sheets
　　　If S.Name <> .Name Then S.Range("A2:C" & _
　　　　　　　S.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
　　Next
　　'シ－ト１の２行目からA列最終行まで繰り返し
　　For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　'既存のシート分繰り返す
　　　For Each S In Sheets
　　　　'(部署)＋・＋(担当者)が名前になったシートがある場合の処理
　　　　If .Cells(i, 1) & "・" & .Cells(i, 2) = S.Name Then
　　　　　h = 1 '判定を1にする
　　　　　'A～C列をコピーする
　　　　　.Range(.Cells(i, 1), .Cells(i, 3)).Copy _
　　　　　S.Range(S.Cells(S.Cells(Rows.Count, "A").End(xlUp).Row + 1, 1), _
　　　　　S.Cells(S.Cells(S.Rows.Count, "A").End(xlUp).Row + 1, 3))
　　　　End If
　　　Next
　　　If h = 1 Then
　　　　h = 0
　　　Else
　　　　'(部署)＋・＋(担当者)が名前になったシートがない場合の処理
　　　　Sheets.Add After:=Worksheets(Worksheets.Count)
　　　　ActiveSheet.Name = .Cells(i, 1).Value & "・" & .Cells(i, 2).Value
　　　　.Range("A1:C1").Copy Range("A1") '見出し行をコピー
　　　　'A～C列をコピー
　　　　.Range(.Cells(i, 1), .Cells(i, 3)).Copy _
　　　　Range(Cells(Cells(Rows.Count, "A").End(xlUp).Row + 1, 1), _
　　　　Cells(Cells(Rows.Count, "A").End(xlUp).Row + 1, 3))
　　　End If
　　Next
　End With
　Application.ScreenUpdating = True '画面の固定解除
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

複数の指定の値に合致するデータを抽出するには？

【Sheet1】							【Sheet2】
	A	B	C	D	E	F		A	B	C	D	E	F
1	日付	得意先名	商品名	単価	数量	金額	1	日付	得意先名	商品名	単価
2	9月7日	A	t	1,100	5	10,000	2	9月7日	A	t	1,100
3	9月7日	B	t	1,100	5	10,000	3
4	9月7日	C	h	1,100	5	10,000	4	日付	得意先名	商品名	単価	数量	金額
5	9月7日	A	t	1,100	5	10,000	5	9月7日	A	t	1,100	5	10,000
6	9月7日	B	t	1,100	5	10,000	6	9月7日	A	t	1,100	5	10,000
7	9月7日	C	h	1,100	5	10,000
8	9月8日	A	q	1,100	5	10,000
9	9月8日	B	t	1,100	5	10,000
10	9月8日	C	h	1,100	5	10,000

上記【Sheet2】の2行目の条件に該当するデータを【Sheet1】から、オートフィルタを使って【Sheet2】にコピーします。
Sub miko_test()
　Dim WS1 As Worksheet, WS2 As Worksheet
　Dim LastR As Long, LastC As Integer
　Application.ScreenUpdating = False
　Set WS1 = Worksheets("Sheet1")
　Set WS2 = Worksheets("Sheet2")
　LastR = WS1.Cells(Application.Rows.Count, 1).End(xlUp).Row
　LastC = WS1.Cells(1, Columns.Count).End(xlToLeft).Column
　WS1.Select
　Range(Cells(1, 1), Cells(LastR, LastC)).Select
　With Selection
　　.AutoFilter
　　'オートフィルタの抽出条件は文字列で指定するので、日付、単価等はTextプロパティを使います。
　　.AutoFilter Field:=1, Criteria1:=WS2.Range("A2").Text 　　　'日付
　　.AutoFilter Field:=2, Criteria1:=WS2.Range("B2").Value 　　'得意先名
　　.AutoFilter Field:=3, Criteria1:=WS2.Range("C2").Value 　　'商品名
　　.AutoFilter Field:=4, Criteria1:=WS2.Range("D2").Text　　　'単価
　　.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Copy
　　WS2.Range("A5").PasteSpecial Paste:=xlValues
　　.AutoFilter
　End With
　Application.ScreenUpdating = True
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

２つのブックを比べて、異なるデータを３つ目のブックに書き出すには？　

Book2・Sheet1の値を、Book1・Sheet1で探して、A～G列のどれかひとつでも違っている場合、
Book2・Sheet1A～H列をBook3・Sheet1に書き出します。
Sub miko_test()
　Dim WS(1 To 3) As Worksheet
　Dim i As Long, j As Long, LastR(1 To 3) As Long
　Application.ScreenUpdating = False '画面の動きを固定
　Set WS(1) = Workbooks("Book1.xls").Worksheets("Sheet1") '先月分
　Set WS(2) = Workbooks("Book2.xls").Worksheets("Sheet1") '今月分
　Set WS(3) = Workbooks("Book3.xls").Worksheets("Sheet1") '差分
　'差分のシートを選択し、全セルをクリア
　WS(3).Select
　Cells.ClearContents
　'先月分、当月分の最終行取得
　LastR(1) = WS(1).Cells(Application.Rows.Count, "A").End(xlUp).Row
　LastR(2) = WS(2).Cells(Application.Rows.Count, "A").End(xlUp).Row
　'先月分、当月分の全項目をくっつけて、差分シートに書き出す
　For i = 1 To LastR(1)
　　With WS(1)
　　　Cells(i, 1) = .Cells(i, 1) & .Cells(i, 2) & .Cells(i, 3) & _
　　　.Cells(i, 4) & .Cells(i, 5) & .Cells(i, 6) & .Cells(i, 7)
　　End With
　Next
　For i = 1 To LastR(2)
　　With WS(2)
　　　Cells(i, 2) = .Cells(i, 1) & .Cells(i, 2) & .Cells(i, 3) & _
　　　.Cells(i, 4) & .Cells(i, 5) & .Cells(i, 6) & .Cells(i, 7)
　　End With
　Next
　'差分の最終行取得
　LastR(3) = Cells(Application.Rows.Count, "A").End(xlUp).Row
　'見出し行をコピー
　WS(2).Range("A1:H1").Copy WS(3).Range("C1")
　'差分のB列を最後まで処理
　For i = 2 To Cells(Application.Rows.Count, "B").End(xlUp).Row
　　'A列に同じ値がひとつもない場合
　　If WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(LastR(3), 1)), Cells(i, 2).Value) = 0 Then
　　　'今月分シートの該当行A～H列をコピー
　　　WS(2).Range("A" & i & ":H" & i).Copy Range("C" & Cells(Application.Rows.Count, "C").End(xlUp).Row + 1)
　　End If
　Next
　'作業列を削除
　Columns("A:B").Delete Shift:=xlToLeft
　Application.ScreenUpdating = True '画面の動きを戻す
End Sub
　

選択範囲内で指定した値と同じ値で、３番目に該当するものを探すには？　
http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200205/02050024.txt
　「検索について」　【VBAラウンジ】

いろんな方法がありましたので、全部キープしました。♪
まずは、【Findメソッド】
Sub 検索demo()
Dim rng1st As Range, rngNext As Range, lngFindCount As Long
　With Worksheets("text1").Columns(3)
　　Set rng1st = .Find( _
　　What:="営業", After:=.Cells(.Rows.Count, 1), _
　　　LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
　　SearchDirection:=xlNext, MatchCase:=False)
　　Set rngNext = rng1st
　　Do
　　　lngFindCount = lngFindCount + 1
　　　If lngFindCount = 3 Then MsgBox "３番目の行は " & CStr(rngNext.Row) & " です．"
　　　Set rngNext = .FindNext(After:=rngNext)
　　Loop Until rng1st.Address = rngNext.Address
　End With
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

【Match関数】
Sub Check3rd_St()
    Dim Sh As Worksheet
    Dim MyR As Range
    Dim x As Variant
    Dim y As Long
    Set Sh = Sheets("Text1")
    x = Application.Match("営業", Sh.Columns("C"), 0)
    If Not IsError(x) Then
       y = x: x = 0
       Set MyR = _
       Sh.Range(Sh.Cells(y + 1, 3), Sh.Cells(Sh.Rows.Count, 3).End(xlUp))
       x = Application.Match("営業", MyR, 0)
       If Not IsError(x) Then
          y = y + x: x = 0
          Set MyR = _
          Sh.Range(Sh.Cells(y + 1, 3), Sh.Cells(Sh.Rows.Count, 3).End(xlUp))
          x = Application.Match("営業", MyR, 0)
          If Not IsError(x) Then
             y = y + x
             MsgBox Sh.Cells(y, 3).Address(False, False) & _
             " に見つかりました", 48
             Set MyR = Nothing
          End If
          Set MyR = Nothing
       End If
    End If
    Set Sh = Nothing
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

【Ifで判定】時間はかかりますが、コードは短い！　データ量が少なければこれがお手軽♪（^^ゞ
Sub Test()
　Dim myRng As Range, c As Range, i As Integer
　With Worksheets("text1")
　　Set myRng = .Columns(3).SpecialCells(xlCellTypeConstants)
　　For Each c In myRng
　　　If c.Value = "営業" Then i = i + 1
　　　If i = 3 Then MsgBox c.Row & "行目に有りました。": Exit Sub
　　Next c
　　MsgBox "「営業」は、" & i & "ヶしか有りません。"
　End With
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

【ユーザー定義関数】　何度も使うなら、これ！
Sub Test()
　Dim lngIns As Long
　lngIns = MyMatch("営業", Worksheets("text1").Range("C:C"), 3)
　MsgBox lngIns
End Sub
Function MyMatch(s, r, n) As Long
　Dim i As Long, j As Long
　On Error GoTo ErrorHandler
　For j = 1 To n
　　i = i + WorksheetFunction.Match(s, _
　　r.Resize(r.Rows.Count - i).Offset(i), 0)
　Next
　MyMatch = i
　Exit Function
　ErrorHandler:
End Function
　　このコードの使い方は、マクロの使い方(６)　ユーザー定義関数（標準モジュール）にあります。

オートフィルタ切り替えマクロ

’シートがオートフィルタされていなければ、１行目をオートフィルタします。　既にオートフィルタされていれば、解除します。
Sub オートフィルタ()
If ActiveSheet.AutoFilterMode = False Then
Rows("1:1").AutoFilter　　　　　　　　　　　　　　’１行目をオートフィルタする
Else
ActiveSheet.AutoFilterMode = False　　　　　　’オートフィルタ解除
End If
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。