Excelノート 16-1 検索・置換・抽出・並べ替

HOME  検索  索引  もくじ  関数目次ージへ        次ページへ 

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

1  編集したいセルを一発で左上に表示するには?
2  入力された内容と一致するセルを選択する方法
3  抜けている数字の抽出をするには
4  横方向に昇順にならびかえるには
5  シート1からシート4までの中で,同一内容のセルがいくつあるかを調べるには
6  ”残業”という値が入っているセルをB列から探し出し、そのセルが何行目にあるか調べたい
7  同一入力データのセルを全て指定するには?
8  シートを保護した状態でオートフィルタを使うには
9  セルの計算式を一括抽出するには(Sheet1→Sheet2)
10 シート1のNOを右クリックした時、シート2の、シート1と同じNoの所を選択するには
11 フリガナを無視して並び替えするには

12 シート1でフラグを付けたデータだけ、シート2に抽出するには
13 B列にデータが入力されている行のみ、別シートに抽出するには
14 選択したセルの値を常に指定のセルに表示するには
15 文字と数字からなるデータ ( A-10、A-2、A-5 ) を並べ替えるには
16 塗りつぶしてある行を抽出するには
17  シート内の全てのセルで、セル内での改行を削除して複数行を1行にするには?
18 指定した文字列を含む全てのデータを抽出するには?
19 Sheet1にあって、Sheet2にないものを、Sheet3に抽出するには?
20 キーワードを検索し、他のブックのキーワードと同じシートに抽出するには?

1 編集したいセルを一発で左上に表示するには?
 Sub Test()
  Application.Goto Range("S10"), True
 End Sub

Goto メソッドの第2引数に True を指定すると、指定したセルが画面左上にきます。
  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
2 入力された内容と一致するセルを選択する方法
実行すると、アクティブセルと同じ内容のセルを全て選択します。
 Sub FindCells()
  Dim startCell As Range
  Dim aCell As Range
  Dim tRange As Range
  Set startCell = ActiveCell
  Set tRange = startCell
  Set aCell = Cells.Find(What:=startCell.Value, After:=startCell)
  Do Until aCell.Address = startCell.Address
   Set tRange = Union(tRange, aCell)
   Set aCell = Cells.FindNext(After:=aCell)
  Loop
  tRange.Select
  Set startCell = Nothing
  Set tRange = Nothing
  Set aCell = Nothing
 End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
3 抜けている数字の抽出をするには
A列に1から1000まで連続した数字が入力されています。その中の抜けている数字をB列に表示します。
 Sub test()
  Dim データ範囲 As Range
  Dim i As Integer 
  Dim j As Integer
  Application.ScreenUpdating = False
  Set データ範囲 = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
  j = 1
  For i = 1 To 1000
   If データ範囲.Find(What:=i, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
    Cells(j, 2).Value = i
    j = j + 1
   End If
  Next
  Set データ範囲 = Nothing
  Application.ScreenUpdating = True
 End Sub
  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
4 横方向に昇順にならびかえるには
Excel97、Excel2000 共通
 データ、並べ替え、オプション、列単位にチェックを入れる
5 シート1からシート4までの中で,同一内容のセルがいくつあるかを調べるには
左から1〜4番目のシートを対象に検索します。strCell = "aa" の所の、aa を選択文字に変えてください。
 
Sub test2()
  Dim strCell As String
  Dim i As Integer
  Dim j As Integer
  strCell = "aa"      
'<--選択文字に変えてください。
  j = 0
  For i = 1 To 3
   j = j + Application.WorksheetFunction.CountIf(Worksheets(i).Cells, strCell)
  Next i
  MsgBox j
 End Sub
  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
任意の4つのシートを対象にする場合はオブジェクト変数を使います。
 Sub test3()
  Dim strCell As String
  Dim ws As Worksheet
  Dim j As Integer
  strCell = "aa"       
'<--選択文字に変えてください。
  j = 0
  For Each ws In Worksheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4"))
   j = j + Application.WorksheetFunction.CountIf(ws.Cells, strCell)
  Next
  MsgBox j
 End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
6 ”残業”という値が入っているセルをB列から探し出し、そのセルが何行目にあるか調べたい
Sub Test()
 Dim rw As Variant
 rw = Application.Match("残業", ActiveSheet.Range("B:B"), 0)
 If IsError(rw) Then
  MsgBox "見つかりませんでした。"
  Else
  MsgBox rw & "行目に見つかりました。"
 End If
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
7 同一入力データのセルを全て指定するには?
Sub 同一セル選択()
  Dim myarea As Range
  If TypeName(Selection) <> "Range" Then Exit Sub
  If Selection.Cells.Count > 1 Then
    MsgBox "単独セルを選択して下さい。"
    Exit Sub
  End If
  If ActiveCell.Value = "" Then
    MsgBox "値のあるセルを選択して下さい。"
    Exit Sub
  End If
  Application.ScreenUpdating = False
  For Each myarea In ActiveSheet.UsedRange
    If myarea.Value = ActiveCell.Value Then
      On Error Resume Next
      Union(Selection, myarea).Select
    End If
  Next
  Application.ScreenUpdating = True
End Sub
  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
8 シートを保護した状態でオートフィルタを使うには
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200104/01040138.txt
あらかじめオートフィルタを設定しておき、下記のマクロを標準モジュールに貼り付けてファイルを閉じて、
再起動します。
 Sub Auto_Open()
  Worksheets("Sheet1").EnableAutoFilter = True
  Worksheets("Sheet1").Protect UserInterfaceOnly:=True
 End Sub

これを、ファイル内の全てのシートに設定する場合のコードです。。
 Sub Auto_Open()
  Dim Sh As Worksheet
  For Each Sh In Worksheets
   Sh.EnableAutoFilter = True
   Sh.Protect UserInterfaceOnly:=True
  Next Sh
 End Sub

保護しないシートがあるなら、ファイルを開いてからそのシートだけ保護を解除するか、
シートの名前にNOを振って、NOの付いているシートだけ保護します。以下はその場合コードです。
シート名は、「保護シート1」「保護シート2」……「保護シート100」までの例です(^^)
 Sub Auto_Open()
  Dim i As Integer
  For i = 1 To 100
   Worksheets("保護シート" & i).EnableAutoFilter = True
   Worksheets("保護シート" & i).Protect UserInterfaceOnly:=True
  Next
 End Sub

規則性のないシート名で、それだけを保護する場合、シートを配列に入れます。
 Sub Auto_Open()
  Dim Sh As Worksheet
  For Each Sh In Sheets(Array("Sheet1", "Sheetあ", "SheetZ"))
   Sh.EnableAutoFilter = True
   Sh.Protect UserInterfaceOnly:=True
  Next Sh
 End Sub

次のマクロでは、インデックスが、3, 5, 7 のシート以外を保護します。
 Sub Auto_Open()
  Dim Sh As Worksheet, x As Integer
  For Each Sh In Worksheets
   x = sh.Index
   Select Case x
    Case 3, 5, 7
    Case Else 
     Sh.EnableAutoFilter = True
     Sh.Protect UserInterfaceOnly:=True
   End Select
  Next Sh
 End Sub

  これらコードの使い方は、
マクロの使い方(1)標準モジュールにあります。
  (ただし、このマクロの使い方で、4番目の「Alt+F8 でマクロ名を選んで実行します」は、必要ありません。)
9 セルの計算式を一括抽出するには(Sheet1→Sheet2)
Sub 計算式抽出()
 Dim myRange As Range
 Dim MsgResp As Integer
 Dim SaveStatus As Boolean ' 現在の『DisplayStatusBar』値
 Dim lng個数 As Long
 Dim i As Long
 Dim j As Integer
 Dim k As Integer
 On Error GoTo TRAP
 lng個数 = Worksheets("Sheet1").Cells. _
 SpecialCells(xlCellTypeFormulas).Count
 MsgResp = MsgBox("計算式セルの個数は" & lng個数 & "個です" _
 & vbCrLf & "抽出しますか?", _
 vbInformation + vbYesNo)
 If (MsgResp = vbYes) Then
  i = 0
  j = 0
  k = 1
  SaveStatus = Application.DisplayStatusBar ' 現在の『DisplayStatusBar』値を保存
  Application.DisplayStatusBar = True ' ステータスバーを表示状態へ
  For Each myRange In _
    Worksheets("Sheet1").Cells _
    .SpecialCells(xlCellTypeFormulas)
    i = i + 1 ' 処理カウント
    j = j + 1 ' 行番号
    If (j > 500) Then
      j = 1 ' 列を変更する
      k = k + 3
    End If
    Application.StatusBar = "計算式抽出(" & i & "/" & lng個数 & ")" ' 進行状況
    With Worksheets("Sheet2")
     .Cells(j, k).Value = _
     "[" & myRange.Address(False, False) & "]" & myRange.Formula
     .Cells(j, k).Value = _
     "[" & myRange.Address(False, False) & "]"
     .Cells(j, k + 1).NumberFormat = "@"
     .Cells(j, k + 1).Value = myRange.Formula
    End With
  Next
  Application.StatusBar = False ' ステータスバーをEXCELへ返す
  Application.DisplayStatusBar = False ' ステータスバーを非表示に
  Application.DisplayStatusBar = SaveStatus ' 処理前の状態に戻す
 End If
 Exit Sub
TRAP:
MsgBox "抽出する計算式がありません"
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
10 シート1のNOを右クリックした時、シート2の、シート1と同じNoの所を選択するには
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
 Dim Fcell As Range
 Set Fcell = Worksheets("sheet2").Range("A:A").Find(What:=Target.Value, LookIn:=xlValues, MatchByte:=True) 
'sheet2のA列を選択
 If Fcell Is Nothing Then
  MsgBox "対象データが見つかりません", vbCritical
 Else
  Worksheets("sheet2").Activate
  Fcell.Select
 End If
 Cancel = True
End Sub

  このコードの使い方は、マクロの使い方(2)該当するシートのモジュールにあります。
11 フリガナを無視して並び替えするには
Excel97、Excel2000 共通
 1.メニュー[データ]-[並べ替え]
 2.[オプション]ボタンをクリック
 3.[方法]のところで[ふりがなを使わない]にチェック
12 シート1でフラグを付けたデータだけ、シート2に抽出するには
http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200101/01010063.txt
  ***** Sheet1 *****

       A         B       C       D
1
2
3   フラグ   氏名   年齢    住所
4     ※      田中     25    田中町
5              鈴木     27    鈴木町
6     ※      近藤     29    近藤町
7              佐藤     35    佐藤町
8              小川     28    小川町
***** Sheet2 *****

      A           B        C        D
1
2
3
4
5
6  行番号     氏名   年齢    住所
7     4          田中     25    田中町
8     6          近藤     29    近藤町
Sheet1のA列で右クリックすると ※ 印を付けたり消したりし、データを、Sheet2のB〜D列に抽出します。
尚、Sheet2のA列を作業範囲として、該当データのSheet1の行番号を記入しています。
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim myRange As Range, i As Long, j As Long, LastRow2 As Long
Dim WS1 As Worksheet, WS2 As Worksheet, c As Range
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
'A列以外、または1〜3行目を選択した場合は処理を終わる
If Target.Column <> 1 Or Target.Row < 4 Then Exit Sub
On Error GoTo TRAP
For Each c In Selection
 LastRow2 = WS2.Cells(Cells.Rows.Count, 1).End(xlUp).Row  
'sheet2の最終行を取得
 If c.Value = "" Then
  c.Value = "※"
  j = c.Row
  WS2.Cells(LastRow2 + 1, 1) = j           
'A列に行番号を記入
  WS2.Cells(LastRow2 + 1, 2) = WS1.Cells(j, 2)  
'B列のデータを転記
  WS2.Cells(LastRow2 + 1, 3) = WS1.Cells(j, 3)  
 'C列のデータを転記
  WS2.Cells(LastRow2 + 1, 4) = WS1.Cells(j, 4) 
 'D列のデータを転記
 ElseIf c.Value = "※" Then
  c.Value = ""
  LastRow2 = WS2.Cells(Cells.Rows.Count, 1).End(xlUp).Row  
'sheet2の最終行を取得
  j = c.Row
  'WS2に該当するデータがあれば、削除する
  For i = LastRow2 To 2 Step -1
   If WS2.Cells(i, 1) = j Then
    WS2.Rows(i).Delete Shift:=xlUp
   End If
  Next
 Else
  c.Value = ""
 End If
Next
Cancel = True
TRAP:
End Sub

  このコードの使い方は、マクロの使い方(2)該当するシートのモジュールにあります。
13 B列にデータが入力されている行のみ、別シートに抽出するには
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200010/00100023.txt
  「数値の入っているデータの抽出するには?」  【編集コーナー】
1行目は項目名が入っているものとします。
 Sub test()
  Dim WS1 As Worksheet
  Dim WS2 As Worksheet
  Set WS1 = Sheets("Sheet1")
'データの入っているシート
  Set WS2 = Sheets("Sheet2")
'抽出したデータを転記するシート
  WS2.Cells.ClearContents
  With WS1.UsedRange
   .AutoFilter Field:=2, Criteria1:="<>"
   .SpecialCells(xlVisible).Copy WS2.Cells(1, 1)
   .AutoFilter
  End With
  Set WS1 = Nothing
  Set WS2 = Nothing
 End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
14 選択したセルの値を常に指定のセルに表示するには
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
 If Target.Address = "$A$1" Then Exit Sub   
'表示するセルを対象からはずす
  Range("A1").Value = Target.Value       
'選択したセルの値を指定のセル(A1)に表示
End Sub

  このコードの使い方は、マクロの使い方(2)該当するシートのモジュールにあります。
15 文字と数字からなるデータ ( A-10、A-2、A-5 ) を並べ替えるには
Excel2002 確認済
Sub test()
  Dim aRange As Range
  On Error Resume Next
  Set aRange = Application.InputBox("ソートするセルをドラッグして下さい", "セルの選択", Type:=8)
  If Err.Number = 0 Then
   Application.ScreenUpdating = False
   With aRange
    .EntireColumn.Insert
    With .Offset(0, -1)
     .Formula = "=LEFT(B1,2)&TEXT(VALUE(RIGHT(B1,LEN(B1)-2)),""000"")"
     .Resize(, 2).Sort Key1:=.Cells(1, 1)
     .EntireColumn.Delete
    End With
   End With
   Application.ScreenUpdating = True
  End If
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
16 塗りつぶしてある行を抽出するには
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200103/01030091.txt
Sheet1のA列が赤で塗りつぶされている行を、Sheet2の1行目以降に表示し、
次に、その下にそれ以外の行を表示します。

 Sub 色判定抽出()
  Dim LastRow As Long, i As Long, Rowpos As Long
  LastRow = Worksheets("Sheet1").Cells(Cells.Rows.Count, 1).End(xlUp).Row
  Rowpos = 1
  For i = 1 To LastRow
   If Worksheets("Sheet1").Cells(i, 1).Interior.Color = vbRed Then
    Worksheets("Sheet1").Rows(i).Copy Worksheets("Sheet2").Cells(Rowpos, 1)
    Rowpos = Rowpos + 1
   End If
  Next
  For i = 1 To LastRow
   If Worksheets("Sheet1").Cells(i, 1).Interior.Color <> vbRed Then
    Worksheets("Sheet1").Rows(i).Copy Worksheets("Sheet2").Cells(Rowpos, 1)
    Rowpos = Rowpos + 1
   End If
  Next
    End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
17 シート内の全てのセルで、セル内での改行を削除して複数行を1行にするには?
【編集】【置換】【検索する文字列】の欄で、Ctrl+J を押し、【すべて置換】をクリックします。
18 指定した文字列を含む全てのデータを抽出するには?
次のようなシートで、下にあるマクロを実行すると、キーワードを要求してきますので
検索したい文字列(下の例では「購入」と入れました)を入力すると、
Sheet1のA列を検索して該当するデータをSheet2に抽出します。

***** Sheet1 *****
  【質問】        【回答】
 この道具はなに?    それはですね、
 どこで購入できる?   ご連絡ください。
 動かないんだけど、   あっれぇ???
 購入してはみたが    返品しますか?
 購入しようかな     お願いしますぅ
 購入は止めよう     なーんだ(-_-;)
 たいしたものないなぁ  すみません(^^;;

***** Sheet2 *****
  【質問】        【回答】
 どこで購入できる?   ご連絡ください。
 購入してはみたが    返品しますか?
 購入しようかな     お願いしますぅ
 購入は止めよう     なーんだ(-_-;)

Sub test()
 Dim a As Variant, LastRow1 As Long, LastRow2 As Integer
 Dim i As Long, k As Long, WS1 As Worksheet, WS2 As Worksheet
 On Error GoTo TRAP
 Application.ScreenUpdating = False
 Set WS1 = Sheets("Sheet1")
 Set WS2 = Sheets("Sheet2")
 WS1.Activate
 Cells(1, 1).Select
 'キーワードをインプットボックスで指定
 a = Application.InputBox(Prompt:="キーワードを入力してください", Type:=2)
 '各シートの最終行を取得
 LastRow1 = WS1.Cells(Rows.Count, 1).End(xlUp).Row
 LastRow2 = WS2.Cells(Rows.Count, 1).End(xlUp).Row + 1
 '最初に検索された内容を抽出
 Cells.Find(What:=a, After:=WS1.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
     xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate
 WS2.Cells(LastRow2, 1) = ActiveCell.Value
 WS2.Cells(LastRow2, 2) = ActiveCell.Offset(0, 1).Value
 '検索した行を変数に代入
 i = ActiveCell.Row
 k = i
 '2番目以降を検索して抽出
 Do
  LastRow2 = LastRow2 + 1
  Cells.FindNext(After:=Cells(i, 1)).Activate
  '検索値が最初の行に戻ったら終了
  If ActiveCell.Row = k Then Exit Do
   WS2.Cells(LastRow2, 1) = ActiveCell.Value
   WS2.Cells(LastRow2, 2) = ActiveCell.Offset(0, 1).Value
   i = ActiveCell.Row
 Loop
 WS2.Activate
TRAP:
 Application.ScreenUpdating = True
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
19 Sheet1にあって、Sheet2にないものを、Sheet3に抽出するには?
http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200105/01050383.txt
  「シートAにあって、シートBにないデータをシートCに抽出するには」
A列のデータを見て同じ物がなければ、A列、B列のデータを抽出します
 Sub Check_Data()
  Dim c As Range
  With Sheets("Sheet1")
   For Each c In .Range("A2", .Range("A65536").End(xlUp))
    If IsError(Application.Match(c.Value, Sheets("Sheet2").Columns(1), 0)) Then
     .Range(c, c.Offset(0, 1)).Copy Sheets("Sheet3") _
     .Range("A65536").End(xlUp).Offset(1)
    End If
   Next
  End With
 End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
20 キーワードを検索し、他のブックのキーワードと同じシートに抽出するには?
Sub miko_test()
 Dim rngFound As Range, Name As String, SakiSht As Worksheet, i As Integer
 Set rngFound = Range("D2").Find(what:="回路")   
'D2に回路というキーワードがあればそのセルを変数に格納
 Name = "回路" 'キーワードを変数に格納
 If rngFound Is Nothing Then                
'セルの変数に何も入っていなければ以下を実行する
  Set rngFound = Range("D2").Find(what:="ABC")
  Name = "ABC"
  If rngFound Is Nothing Then
   Set rngFound = Range("D2").Find(what:="無線")
   Name = "無線"
   If rngFound Is Nothing Then
    MsgBox "種別を入力して下さい"
   End If
  End If
 End If
 Set SakiSht = Workbooks("Sakibook.xls").Worksheets(Name)  
'他のブックのシート名を変数に格納
 For i = 3 To 7
  SakiSht.Cells(i, 4) = Cells(i, 4)                    
'データを他のブックに記入
 Next
End Sub

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

HOME  検索  索引  もくじ  関数目次ージへ        次ページへ 

このページのTOPへ

 

 

 

 

 

inserted by FC2 system