Sample Macro  値の操作 [応用型] Previous Next

1) 千円単位に数を丸める このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub 千円単位に数を丸める()                        '四捨五入、切り上げ、切り捨て
    ブック名 = "BBB.xls"                        '※1
    円シート = "YEN"                            '※2
    千シート = "SEN"                            '※3
    基準セル = "A2"                             '※4
    列 = Range(基準セル).Column                 '基準セルアドレスから列番号を取得
    With Workbooks(ブック名).Worksheets(円シート)
        下端行 = .Range(基準セル).End(xlDown).Row '円単位データの下端行を検出
        For 行 = 2 To 下端行
            Worksheets(千シート).Cells(行, 列) _
                = Application.Round(.Cells(行, 列) / 1000, 0) '※5
        Next
    End With
End Sub
'=================================================================================
Sub 百万以上または千以上の数字だけを表示する()
    数値 = 1234567890
    百万単位 = Format(数値, "#,,")              '※6
    千単位 = Format(数値, "#,")                 '※6
    MsgBox 数値 & " を百万単位にすると " & 百万単位 & " です。"
    MsgBox 数値 & " を千単位にすると " & 千単位 & " です。"
End Sub
'=================================================================================
<コメント>
※1 BBB.xls にはブック名を記入
※2 YEN には円単位のデータが入っているシート名を記入
※3 SEN には千円単位のデータが入っているシート名を記入
※4 A2 には円単位のデータ(見出し行除く)が入っている上端セルアドレスを記入
※5 Round:四捨五入、切り上げ:Round関数をRoundupに変える、切り捨て:RoundDownに変える
※6 百万未満または千未満は四捨五入される

2) 千円未満を四捨五入してゼロ表示する このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub 千円未満を四捨五入してゼロ表示する()
    ブック名 = "BBB.xls"                        '※1
    シート名 = "YEN"                            '※2
    セル範囲 = "A2:A4"                          '※3
    With Workbooks(ブック名).Worksheets(シート名)
        For Each 各セル In .Range(セル範囲)
            各セル.NumberFormatLocal = "#,##0,"",000"";-#,##0,"",000"";0"
        Next
    End With
End Sub
'=================================================================================
<コメント>
※1 BBB.xls にはブック名を記入
※2 YEN には円単位のデータが入っているシート名を記入
※3 A2:A4 には円単位のデータが入っているセル範囲を記入


3) 当日データをDBの上部に転記する このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub 当日データをDBの上部に転記する()
    If Sheets("環境").Cells(1, 2) >= "8.0" Then 'Excelのバージョン ※1
        下限 = 65536                            'Excel97の場合の最下端行
    Else
        下限 = 16384                            'Excel95の場合の最下端行
    End If
    Sheets("aシート").Select                    '当日データのシートを選択する
        上 = 1                                  '基点セルの行番号(この場合はA1の1)
        左 = 1                                  '基点セルの列番号(A1のAの数字表記)
        下 = Range(Cells(上, 左), Cells(上, 左)).End(xlDown).Row '下端検出
        右 = 11                                 '右端セルの列番号(K1のKの数字表記)
        If 下 = 下限 Then                       '当日データが無い場合
            Range("A1").Select
            Exit Sub                            'このサブプロシージャの出口へ
        End If

    Sheets("bシート").Select                    'DBシートを選択
        行数 = "2:" & 下                        '挿入する行数をセットする
        Rows(行数).Insert Shift:=xlDown         '行を挿入する
        Range(Cells(5, 左), Cells(5, 右)).Copy  '挿入前の最上行をコピー
        Range(Cells(2, 左), Cells(下, 右)).PasteSpecial Paste:=xlAll '書式等すべて貼り付け

    Sheets("aシート").Select                    '当日データのシートを選択
        Range(Cells(2, 左), Cells(下, 右)).Copy '検出した範囲をコピー
    Sheets("bシート").Select                    'DBシートを選択
        Range("A2").PasteSpecial Paste:=xlValues '当日データの値を貼り付け
End Sub
'=================================================================================
<コメント>
※1 「環境」シートの内容は下図のとおり
環境シート


4) 検索して別のシートに貼り付ける このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub 検索ボタン_click()                          'Sheets2の検索ボタンが押された時のマクロ
    Sheets("Sheet2").Select                     '抜き出し結果のシート
        Range("H1:J1").ClearContents            'エディットボックスの値格納セルをクリア
        Range("A2:F6").ClearContents            '検索結果の格納セルをクリア
    DialogSheets("Dialog1").Show                'ダイアログボックスを映す
End Sub
'---------------------------------------------------------------------------------
Sub OKボタン_click()                            'ダイアログボックスのOKボタン押下時で実行
    DialogSheets("Dialog1").Hide                'ダイアログボックスを消す
    Range("H1") = DialogSheets(1).EditBoxes(1).Text '会員番号をセルに格納
    Range("I1") = DialogSheets(1).EditBoxes(2).Text '名前をセルに格納
    Range("J1") = DialogSheets(1).EditBoxes(3).Text 'TELをセルに格納
    名前 = Range("I1")                          '名前を取り出す
    If 名前 <> "" Then                          '名前がヌルでなければ
        Sheets("一時").Select                   '一時的なシート
             Cells.Clear                        'すべてクリア
        Sheets("Sheet1").Select                 '会員名簿
            Range("A2").Select
                Selection.AutoFilter            'オートフィルターをリセット
                Selection.AutoFilter Field:=2, Criteria1:=名前
                Selection.CurrentRegion.Copy    'アクティブセル領域をコピー
        Sheets("一時").Select                   '一時的なシート
            Range("A1").PasteSpecial Paste:=xlValues '値を貼り付け
            下 = Range(Cells(1, 1), Cells(1, 1)).End(xlDown).Row '下端検出
            Range(Cells(2, 1), Cells(下, 6)).Copy '検出した範囲を選択してコピー
        Sheets("Sheet2").Select
            Range("A2").PasteSpecial Paste:=xlValues '値を貼り付け
        Sheets("Sheet1").Select
            Selection.AutoFilter
        Sheets("Sheet2").Select
            Range("A2").Select
    End If
End Sub
'=================================================================================
<コメント>
※1 シートのレイアウトなどは 名簿から検索して別のシートに貼り付けるには? を見てください。


5) 複数のシートの値を別のシートに統合する このページのトップへ もくじへ 使用可能なExcelのバージョン
'---------------------------------------------------------------------------------
Sub 複数のシートの値を別のシートに統合する()
    Worksheets("月間").Range("B2:C5").ClearContents '数式と値をクリアする

    Worksheets("月間").Range("B2").Consolidate _
        sources:=Array("前半!R2C2:R5C3", "後半!R2C2:R5C3"), _
        Function:=xlSum             '前半シートと後半シートのB2:C5の値を月間シートへ統合
End Sub
'---------------------------------------------------------------------------------
<コメント>
※1 シートの内容は下図のとおりで、前半シートと後半シートのB2:C5セルの値を、月間シートの
   同じセルに統合します
前半シート 後半シート 月間シート

サンプルブックのダウンロードは ここをクリック (YNxv258_tougou.xls 30KB)
※ 一旦、ブックをハードディスクに保存し、開き直してから実行してください。


6) 数式をオートフィルしたように設定する このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub 数式をオートフィルしたように設定する()
    セル範囲 = "D2:D5"                           '※1
    数式 = "=B2*C2"                             '※2
    Range(セル範囲).Formula = 数式
End Sub
'=================================================================================
<コメント>
※1 ""内には、数式を設定したいセル範囲を記述
※2 ""内には、セル範囲の最初のセルに設定する数式を記述
※3 このマクロで、数式をD2:D5セルへ設定し終わったシート
設定後のシート


7) オートフィルで連続データを作成する このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub オートフィルで連続データを作成する()        '※1
    リストの種類 = xlFillSeries                 '※3-1 (連続データ)
    基準データ = "1"                            '※4
    基準セル = "A1"                             '※5
    書込先セル = "A1:A10"                       '※6
    Range(基準セル).Value = 基準データ
    Range(基準セル).AutoFill Range(書込先セル), リストの種類
End Sub
'---------------------------------------------------------------------------------
Sub オートフィルで曜日を展開する()              '※2
    基準データ = "日"                           '※4 (日曜日の意)
    基準セル = "B1"                             '※5
    展開先セル = "B1:H1"                        '※6
    Range(基準セル).Value = 基準データ
    Range(基準セル).AutoFill Range(展開先セル) '※3-2
End Sub
'=================================================================================
<コメント>
※1 処理結果 ※2 処理結果
※3-1 リストの種類を指定する引数Typeの詳細は こちら
※3-2 リストの種類を省略すると元になるセル範囲に応じて最も適切な種類のリストが選択される
※4 基準となるデータ
※5 基準となるデータが入ったセル範囲
※6 オートフィルの書き込み先(または展開先)となるセル範囲(基準セルを含めること)


8) オートフィルターしたデータの合計を表示 このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub オートフィルターしたデータの合計を表示する()
    シート名 = "Sheet1"                         '※1
    基準セル = "A1"                             '※2
    合計セル = "B6"                             '※3
    抽出列 = 1                                  '※4
    抽出キー = "みかん"                          '※5
    Worksheets(シート名).Activate
    数式初期値 = Range(合計セル).Formula         '数式を退避する
    Range(合計セル).Formula = "=SUBTOTAL(9,B2:B5)" '※6 SUBTOTAL関数を設定する
    Range(基準セル).AutoFilter Field:=抽出列, Criteria1:=抽出キー 'オートフィルターする

    MsgBox 合計セル & "セルの値は抽出したデータだけの合計です"
    Range(基準セル).AutoFilter
    Range(合計セル).Formula = 数式初期値          '数式を復元する
End Sub
'=================================================================================
<処理概要>
 ・下図(左端)のB6セルには金額の合計を求めるSUM関数が入っている
 ・そのままでオートフィルターすると合計の行は表示されない
 ・B6セルのSUM関数をSUBTOTAL関数(図参照)に変更してからオートフィルターすると
 ・抽出されたデータだけの合計が表示されるようになる
 
<コメント>
※1 Sheet1 にはリストのあるシート名を記述
※2 A1 にはリスト内のセルアドレスを1つ記述
※3 B6 には合計金額のセルアドレスを記述
※4 1 にはオートフィルターの対象となるフィールド番号(列番号)を記述
※5 みかん にはオートフィルターの抽出条件となる文字列を記述
※6 SUBTOTAL関数の集計方法として 9 (SUM) を指定しているが、SUBTOTAL関数は
   この値にかかわらず、フィルタの結果に含まれていない行はすべて無視される


9) 文字列の存在を調査 このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub 特定の文字列が何個存在するか調査する()
    Worksheets("調査表").Activate                       '※1
        下端 = Range("A" & Rows.Count).End(xlUp).Row    '下端検出
        Range("B2:B" & 下端).Value = 0                  '調査結果を一旦ゼロにする
        Range("F2").Value = ""                          '答えをクリア
        特定文字列 = Cells(2, 4)                        '特定の文字列を取り出す
        For 行 = 2 To 下端                              '下端行まで反復する
            文字列 = Range("A" & 行).Value              '文字列を取り出す
            If InStr(文字列, 特定文字列) > 0 Then       '※2	
                Range("B" & 行).Value = 1               '調査結果を1にする
                Range("F2").Value = Range("F2").Value + 1 '存在個数に1加える
            End If
        Next
        Range("F2").Select
End Sub
'=================================================================================
<コメント>
※1 "調査表"のサンプルと操作法
表サンプル
※2 InStr関数の詳細は
こちら

10) 漢数字を半角数字に置換 このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Option Explicit
Dim 下端 As Integer                             '元データの下端
'---------------------------------------------------------------------------------
Sub 漢数字を半角数字に置き換える()
    Sheets("SSS").Select                        'シートを選択する ※1
        Columns("A:A").Copy
        Range("B1").PasteSpecial Paste:=xlAll   'すべて貼り付け
        Range("B1").Select                      '列見出し
            ActiveCell.Value = "置き換え後のデータ"
        下端 = Range(Cells(1, 2), Cells(1, 2)).End(xlDown).Row '元データの下端検出
        リプレスする
End Sub
'---------------------------------------------------------------------------------
Private Sub リプレスする()
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="一", replacement:="1"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="二", replacement:="2"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="三", replacement:="3"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="四", replacement:="4"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="五", replacement:="5"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="六", replacement:="6"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="七", replacement:="7"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="八", replacement:="8"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="九", replacement:="9"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="○", replacement:="0"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="壱", replacement:="1"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="弐", replacement:="2"
    Range(Cells(2, 2), Cells(下端, 2)).Replace what:="参", replacement:="3"
End Sub
'=================================================================================
<コメント>
※1 SSSにはシート名を記入
※2 注意事項住所録の漢数字を半角数字に変えるには 参照



11) 値の大小関係を評価する このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub 値の大小関係を評価する()
    基準値 = 20
    セル = "A1"
    値 = Range(セル)
    評価 = IIf(値 < 基準値, "小さい", "小さくはない")
End Sub
'=================================================================================


12) 空白セルに1行上のセルの値をセット このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub 空白セルに1行上のセルの値をセットする()
    セル範囲 = "A1:A20"                         '※1
    For Each 各セル In Range(セル範囲)
        With 各セル
           If .Value = "" Then
              .Value = 各セル.Offset(-1, 0).Value
           End If
        End With
    Next
End Sub
'=================================================================================
<コメント>
※1 同じ列のセル範囲を記入


13) セルに丸囲み文字をセットする このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================
Sub セルに丸囲み文字をセットする()                 '※1
    Range("A1").Value = ChrW(12953)             '秘
    Range("A2").Value = 12953
    Range("B1").Value = ChrW(12957)             '優
    Range("B2").Value = 12957
    Range("C1").Value = ChrW(12958)             '印
    Range("C2").Value = 12958
    Range("D1").Value = ChrW(12961)             '休
    Range("D2").Value = 12961
    Range("E1").Value = ChrW(12962)             '写
    Range("E2").Value = 12962
    Range("F1").Value = ChrW(12963)             '正
    Range("F2").Value = 12963
End Sub
'=================================================================================
<コメント>
※1 代表的なサンプル (2行目の数字はChrW関数の引数となるユニコード)

※2 よく使われそうなサンプル … 丸囲み文字は他にもある

Excel VBA Macro