タイトル欄のアドレスは、エクセルファンクラブの該当する頁へのリンク先です。
詳しい事は、こちらのお願いをご覧になってください。
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)標準モジュールにあります。 |