| |
|
|
Sample Macro 値の操作 [応用型] |
 |
|
|
|
1) 千円単位に数を丸める |
 |
 |
'=========================================================================================
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
MsgBox Format(数値, "#,,") '※6 百万以上
MsgBox Format(数値, "#,") '※6 千以上
End Sub
'=========================================================================================
＜コメント＞
※1 BBB.xls にはブック名を記入
※2 YEN には円単位のデータが入っているシート名を記入
※3 SEN には千円単位のデータが入っているシート名を記入
※4 A2 には円単位のデータ(見出し行除く)が入っている上端セルアドレスを記入
※5 Round：四捨五入、切り上げ：Round関数をRoundupに変える、切り捨て：RoundDownに変える
※6 百万未満または千未満は四捨五入される
|
2) 千円未満を四捨五入してゼロ表示する |
|
|
'=========================================================================================
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の上部に転記する |
|
|
'=========================================================================================
Sub 当日データをDBの上部に転記する()
If Sheets("環境").Cells(1, 2) >= "8.0" Then 'Excelのバージョン ※１
下限 = 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 'ＤＢシートを選択
行数 = "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 'ＤＢシートを選択
Range("A2").PasteSpecial Paste:=xlValues '当日データの値を貼り付け
End Sub
'=========================================================================================
＜コメント＞
※１ 「環境」シートの内容は下図のとおり
|
4) 検索して別のシートに貼り付ける |
|
|
'=========================================================================================
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
'=========================================================================================
＜コメント＞
※１ シートのレイアウトなどは 名簿から検索して別のシートに貼り付けるには？ を見てください。
|
5) 複数のシートの値を別のシートに統合する |
|
|
'-----------------------------------------------------------------------------------------
Sub 複数のシートの値を別のシートに統合する()
Worksheets("月間").Range("B2:C5").ClearContents '数式と値をクリアする
'
Worksheets("月間").Range("B2").Consolidate _
sources:=Array("前半!R2C2:R5C3", "後半!R2C2:R5C3"), _
Function:=xlSum '前半シートと後半シートのB2:C5の値を月間シートへ統合
End Sub
'-----------------------------------------------------------------------------------------
＜コメント＞
※１ シートの内容は下図のとおりで、前半シートと後半シートのB2:C5セルの値を、月間シートの
同じセルに統合します
サンプルブックのダウンロードは ここをクリック （YNxv258_tougou.xls 30KB）
※ 一旦、ブックをハードディスクに保存し、開き直してから実行してください。
|
|
6) 数式をオートフィルしたように設定する |
|
|
'=========================================================================================
Sub 数式をオートフィルしたように設定する()
セル範囲 = "D2:D5" '※１
数式 = "=B2*C2" '※２
Range(セル範囲).Formula = 数式
End Sub
'=========================================================================================
＜コメント＞
※１ ""内には、数式を設定したいセル範囲を記述
※２ ""内には、セル範囲の最初のセルに設定する数式を記述
※３ このマクロで、数式をD2:D5セルへ設定し終わったシート
|
7) オートフィルタしたデータの合計を表示 |
|
|
'=========================================================================================
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関数は
この値にかかわらず、フィルタの結果に含まれていない行はすべて無視される
|
8) 文字列の存在を調査 |
|
|
'=========================================================================================
Sub 特定の文字列が何個存在するか調査する()
Sheets("調査表").Select '※１
下端 = Range("A1").End(xlDown).Row '下端検出
Range(Cells(2, 2), Cells(下端, 2)).Value = 0 '調査結果を一旦ゼロにする
Cells(2, 6) = "" '答えをクリア
特定文字列 = Cells(2, 4) '特定の文字列を取り出す
特定長さ = Len(特定文字列) ' 〃 の長さを調べる
For 行 = 2 To 下端 '下端行まで反復する
文字列 = Cells(行, 1) '文字列を取り出す
文字列長さ = Len(文字列) '文字列の長さを調べる
先端 = 1 '文字列の先端
比較:
If 文字列長さ >= 特定長さ Then '文字列は特定文字列より長いか
If 特定文字列 = Mid(文字列, 先端, 特定長さ) Then '文字列の一部が一致するか
Cells(行, 2) = 1 '調査結果を1にする
Cells(2, 6) = Cells(2, 6) + 1 '存在個数に1加える
GoTo 次へ
End If
文字列長さ = 文字列長さ - 1 '文字列長さを1字減らす
先端 = 先端 + 1 '次の文字を指し示す
GoTo 比較
End If
次へ:
Next
Range("F2").Select
End Sub
'=========================================================================================
＜コメント＞
※１ "調査表"のサンプルと操作法
|
9) 漢数字を半角数字に置換 |
|
|
'=========================================================================================
Option Explicit
Dim 下端 As Integer '元データの下端
'-----------------------------------------------------------------------------------------
Sub 漢数字を半角数字に置き換える()
Sheets("SSS").Select 'シートを選択する ※１
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
'=========================================================================================
＜コメント＞
※１ SSSにはシート名を記入
※２ 注意事項 …
住所録の漢数字を半角数字に変えるには 参照
|
10) 値の大小関係を評価する |
|
|
'=========================================================================================
Sub 値の大小関係を評価する()
基準値 = 20
セル = "A1"
値 = Range(セル)
評価 = IIf(値 < 基準値, "小さい", "小さくはない")
End Sub
'=========================================================================================
|
