EXCEL-VBA SHORT PROGRAM & EXCEL SHEET

１．　カーソルの上下・左右の移動切替

　　　カーソルの上下・左右の移動は　オプション（Ｏ）→編集→入力後にセルを移動する（Ｍ）で設定出来るが、操作が煩雑である。　　　　

　　　Ｖｉｓｕａｌ　Ｂａｓｉｃ　ＥｄｉｔｏｒでＶＢＡＰｒｏｊｅｃｔを開き、ＶＢＡＰｒｏｊｅｃｔ（ＰＥＲＳＯＮＡＬ..ＸＬＳ）の標準モジュールに下記マクロをに書込み（コピーにても可）、保存してＥＸＣＥＬに戻る。　ユーザー設定（Ｃ）→コマンド→マクロからユーザー設定ボタン（ニコチャンマーク）をドラッグ＆ドロップでツールバーに入れる。　その後、ニコチャンをクリックした時に出る「マクロの登録」でリストにあるＣｕｒｓｏｌＭｏｖｅをクリックしてマクロ名（Ｍ）：に転送し、「ＯＫ」ボタンを押すと　ニコチャンと下記マクロはリンクされ、ニコチャンをクリックするたびに移動が上下・左右に切替わる。　

　　　ユーザー設定（Ｃ）を開き、ニコチャンを右クリックするとニコチャンに名前（Ｎ）を付けることが出来る。　またニコチャンの色・形を変更したり、別のアイコンに変更することも出来る。　　（画像ー０１）右上に変色したニコチャンマークの表示あり。

　　　多量のデータを同一方向に入力する場合　カーソルの移動が簡単に切替できて便利である。

SOURCE ＣＯＤE

Sub CursolMove()

If Application.MoveAfterReturnDirection = xlToRight Then
Application.MoveAfterReturnDirection = xlDown
Else
Application.MoveAfterReturnDirection = xlToRight
End If

End Sub

　　　ツール（Ｔ）→マクロ（Ｍ）→新しいマクロの記録（Ｍ）で出る「マクロの記録」にマクロ名（Ｍ）に分かりやすい名前（例：ＣｕｒｓｏｌＭｏｖｅ等）を付け、マクロの保存先（Ｉ）を「個人用マクロブック（ＰＥＲＳＯＮＡＬ..ＸＬＳの標準モジュールに記録される）」にして、良く使うキー操作（文字サイズ・色変更、セル色変更、条件付き書式等）を登録して保存、上記と同様な方法でニコチャンマークにリンクさせれば、複雑なキー操作がワンクリックで可能となる。

２．　条件付き書式

　　　書式（Ｏ）・条件付き書式（Ｄ）では「３個」の条件しか設定できない。（次期Ｏｆｆｉｃｅでは無制限といわれているが？）

　　　株価のデータ収集（画像ー０１）において、Ｈ行の記述に多数（３個以上）の条件付き書式を設定出来たので参考に記述する。

　　　プログラムの条件として、Ｈ行の文字が「微下方・下方・大下方・無配・減配」の場合は文字を赤色とする。　一方　業績が赤字の場合　セルを黄色にした上に文字も赤色とする。　業績が赤字の場合は必ず最初に「赤」書いてデータを入れる。　

プログラムの動作は、文字が「微下方・下方・大下方・無配・減配」の場合は文字を赤色にする。　最初の文字が「赤」の場合、｢赤」を読み取って、文字を赤色にした上、セルも黄色にする。　「赤」が削除されたデータに書き換えると、文字は黒・セルは白に自動的に戻る。プログラム中先頭の　100-400の番号　は行番号である。

　　　このプログラムはシート固有のプログラムであるため　Ｖｉｓｕａｌ　Ｂａｓｉｃ　ＥｄｉｔｏｒでＶＢＡＰｒｏｊｅｃｔを開き、ＶＢＡＰｒｏｊｅｃｔのＭｉｃｒｏｓｏｆｔ　Ｅｘｃｅｌ　Ｏｂｊｅｃｔｓの該当シートに記述する（コピーした場合は条件等を変えること）必要がある。　　　マクロはＥＸＣＥＬシートの起動時に自動的に読み込まれる。

（画像－０１）

SOURCE ＣＯＤE

Private Sub Worksheet_Change(ByVal Target As Range)

Dim icolor As Integer

If Not Intersect(Target, Range("H4:H500")) Is Nothing Then                               　　　　　     　Select Case Target
  　　 Case "微下方"　　' Case 100 To 200 （範囲の記述）
    　　　   icolor = 3: GoTo 150
  　　Case "下方"
  　　　   icolor = 3: GoTo 150
  　　 Case "大下方"
    　　　   icolor = 3: GoTo 150
  　　 Case "無配"
   　　　    icolor = 3: GoTo 150
  　　 Case "減配"
    　　　   icolor = 3: GoTo 150
  　　 Case Else
     　　　　GoTo 300
100 　　　icolor = 3
      　　　 Target.Interior.ColorIndex = 6: GoTo 160
150 　　　Target.Interior.ColorIndex = 0
160
　End Select
     　　　 Target.Font.ColorIndex = icolor
End If

200　　　GoTo 400

300　 '"赤"の取得
     　　　 Dim AK As String
     　　　 AK = Left(Target, 1)
      　 If AK = "赤" Then GoTo 100 Else GoTo 150
400

End Sub

３．　ＥＸＣＥＬシートの印刷禁止

　　　ＥＸＣＥＬシートはデータの保護は出来るが、印刷禁止は出来ない。　　ＭＳ技術サポートとメールのやり取りして、ヒントをもらい　試行錯誤で作成したのが　　ＣＥＭＥＮＴ　ＰＬＡＮＴ　ＥＮＧＩＮＥＥＲＩＮＧ　ＥＸＣＥＬ－ＶＢＡ　ＰＲＯＧＲＡＭ　で使用した印刷禁止のマクロで、コードは下記である。

　　　このマクロはブック共通となるため、ＶＢＡＰｒｏｊｅｃｔのＭｉｃｒｏｓｏｆｔ　Ｅｘｃｅｌ　Ｏｂｊｅｃｔｓ内のＴｈｉｓＷｏｒｋＢｏｏｋに記述（コピーも可）する。　マクロはＥＸＣＥＬシートの起動時に自動的に読み込まれる。

SOURCE ＣＯＤＥ

Private Sub Workbook_BeforePrint(Cancel As Boolean)

　　　　Flag = MsgBox(" Can't print out. 　OK ? ", vbYes)

　　If Flag = vbNo Or vbYes Then
　　　　Cancel = True
　　End If

End Sub

　　　上記を参考に　ＷＯＲＤシートの印刷禁止に取り組み　同等な機能は確認できたが、ウイルスセキュリティソフトがマクロをウイルスと認識して　ウマク作動せず　作成を断念。ＷＯＲＤシートはＰＤＦに変換して、保護・印刷禁止としている。

　　　ＷＯＲＤシートを印刷禁止するマクロがあればアドバイス願いたい。

４．　貼付と罫線削除　2007/02/03

　　　Webからデータをコピーして貼り付けた場合、不要な罫線がコピーされることがある。貼付と同時に、罫線を削除する簡単なプログラムを紹介する。　「マクロの記録」からでも作成可能であるが、処理が遅いので使えない。　　「マクロの記録」より作成されるコードは２行、４～１１行となるが、４～１１行を３行で代替。　ＰＥＲＳＯＮＡＬ．ＥＸＬに書き込み、ニコチャンマークにリンクさせれば、ワンクリックで「貼付と罫線削除」が可能となる。

SOURCE ＣＯＤＥ

Sub Paste_DelLine()

　　ActiveSheet.Paste
　　Selection.Borders().LineStyle = xlNone

　　'Selection.Borders(xlDiagonalDown).LineStyle = xlNone
　　'Selection.Borders(xlDiagonalUp).LineStyle = xlNone
　　'Selection.Borders(xlEdgeLeft).LineStyle = xlNone
　　'Selection.Borders(xlEdgeTop).LineStyle = xlNone
　　'Selection.Borders(xlEdgeBottom).LineStyle = xlNone
　　'Selection.Borders(xlEdgeRight).LineStyle = xlNone
　　'Selection.Borders(xlInsideVertical).LineStyle = xlNone
　　'Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

５．データの指定位置への移動　2007/10/01

　　　行方向にランダムな列に書かれたデータを同一行の指定列にマクロで移動させる。

（画像ー２）にある２～７行のランダムな列にあるデータをAA列に揃えて移動する。　２行のAA、BBデータをAA列に移動した場合の「マクロの記録」は　SOURCE ＣＯＤＥ　の５～８行となる。　このマクロでは　移動セル数、移動先セル名が固定しているので　３行のCC-DDデータを「マクロの実行」で同一行AAセルに移動できない。　　　

　　　６行の「２５」と７行の「”AA2”」を変数に変えると　３行のCC-DDデータを範囲選択後　「マクロの実行」（個人用マクロブックに保存し、ニコチャンマークにリンクさせておいてクリックする）で同データが　同一行のAA列に移動する。　４～７行のデータも同様にAA列に移動できる。

　　　データ行が多く、また移動列が離れている場合は非常に便利なマクロとなる。約１４００行で、ランダム４列に書かれたデータ整理に役立った。

（画像ー０２）

拡大は画像クリック

SOURCE ＣＯＤＥ

Sub MoveData()

　 'Macro1 Macro

　 'マクロ記録日 : 2007/9/30 ユーザー名 : Ryu&You

　　'Selection.Cut

　　'ActiveWindow.SmallScroll ToRight:=25

　　'Range(”AA2”).Select

　　'ActiveSheet.Paste

　　Dim Row, Col, AA As Integer

　 Dim BB, ET As String

　 Row = ActiveCell.Row 　　　　　　　　　'行位置

　 Col = ActiveCell.Column 　　　　　　　　'列位置

　 BB = "ET" & Row 　　　　　　　　　　　'移動先指定(変数）セル名の作成

　 AA = 27 - Col 　　　　　　　　　　　　　'移動セル数の計算

　 'Debug.Print AA; BB; Row; Col: End

　 Selection.Cut

　 ActiveWindow.SmallScroll ToRight:=AA 　　　　　　'セルの移動

　 Range(BB).Select 　　　　　　　　　　　　　　　　　　 'セル範囲の選択

　 ActiveSheet.Paste

End Sub

.６．　自動的に列方向へセルをコピー＆貼付　　（「２．条件付書式」と関連）

　　　選択した列範囲内のセルを上から順番に自動的に「コピー＆貼付」を行う。

「２．条件付書式」においてプログラムした列のセルは書き換えると条件に応じて書式（フォント・色等）が変わる。　しかしそのセルのリンク先ではその列に同プログラムを移植してもデータは変更表示されるが書式は変わらない。　リンク先の書式を変えるためには「コピー＆貼付」しなければならない。　リンク数が多いと「コピー＆貼付」をセル一つずつ行うのも大変だ。

　　　そこで下記マクロを作成、書式を変える列を範囲選択してニコチャンマークをクリックすれば選択範囲内の書式を自動的に修正表示させることにした。　セルが一段ずつ下がり書式が修正される。

SOURCE ＣＯＤＥ

Sub CopyPasteColumn()

' Macro1 Macro

' マクロ記録日 : 2007/10/4 ユーザー名 : Ryu&You

Dim Row, RowN , Col , N As Integer

Dim BB As String

　　 Row = ActiveCell.Row

Col = ActiveCell.Column

RowN = Selection.Rows.Counｔ　　　　　　　　　　　　　　　　'選択行数

　　　　　　　　　'Debug.Print Row, Col , BB, CC, RowN: End

For N = Row To Row + RowN - 1

　　　　'BB="I"& N

ActiveWindow.SmallScroll Down:=1 '行の一段下げ

Cells(N, Col ).Select 'セルの選択

Selection.Copy

ActiveSheet.Past

　　　　　　　　　 'Debug.Print N, BB

Next N ': End

End Sub

７．　不連続範囲の一発選択

　　　不連続な範囲を選択（して、その後コピー状態に）する場合は　Ctrl-Key　を使わねばならず、両手作業となる。　マウスだけの片手だけで不連続な範囲を選択するために下記マクロを作成した。

　　　本マクロは　不連続な同一長さの２列を選択し、コピー状態まで行うためのマクロで、　適当な１列にマウスで必要長さ（行数）を選択しておけば　ニコチャンマークをクリックするだけで　平行方向のその長さの２列（G列AA:BB、Ｉ列CC:DD)を選択し、コピー状態にする。　下記マクロを参考に　Unionメソッド　を使えば多数の範囲選択が出来る。

SOURCE ＣＯＤＥ

Sub Multi_RangeSelect()

　　　　Dim Row, RowN , Col As Integer

　　　　Dim AA, BB, CC, DD As String

　　　　　　Row = ActiveCell.Row

　　　　　　Col = ActiveCell.Column

　　　　　　RowN = Selection.Rows.Count '適当な一列長さ（選択行数）

　　　　AA = "G" & Row: BB = "G" & Row + RowN - 1

　　　　CC = "I" & Row: DD = "I" & Row + RowN - 1

　　　　　　 'Debug.Print Row, Col , AA, BB, CC, DD, RowN ': End

　　　　　　'Range(AA, BB).Select

　　　　　　'Range(CC, DD).Select

　　　　 Union(Range(AA, BB), Range(CC, DD)).Select　　　　　'多数の範囲選択

　　　　Selection.Copy　　　　　　　　　　　　　　　　　　　　　　　 'コピー状態

End Sub

８．　カーソルの指定シートの指定セルへの移動

　　　ブック内のあるシートから指定シートの指定セルへカーソルをマクロにより移動させる。　移動先カーソルはウインドウ枠を固定した指定シートの左上に位置させる。

　　　Ｂｏｏｋ０１の「ＧＧ～ＡＡ」の各シートから対応するＳｈｅｅｔ１の「Ｃ３０９～Ｃ３」へカーソルを移動させる。　現在のカーソルがどの「ＧＧ～ＡＡ」シートにあるかシート名を読み取って対応するＳｈｅｅｔ１の「Ｃ３０９～Ｃ３」に移動する。　あらかじめＳｈｅｅｔ１の指定セルにはブックマークを付けてリンクを張り＃Ｆ６（Ａ３１０）からＣ２５８へ飛ぶようにしておく。　理由はＳｈｅｅｔ１に張付けられた表を左上に揃えたいからこの様な方法をとったが、他の方法もある。　＃Ｇ７、Ｅ５～＃Ａ１も同様にする。実際組んだマクロがシートの　終わり→初め　に作業するように作ったので本サンプルもそのままにしているが、必要なら　初め→終わり　に作業を進めるよう修正願いたい。

　　　Ｉｆ　文は２分岐では　Ｉｆ　Ｔｈｅｎ　Ｅｌｓｅ　Ｅｎｄ　Ｉｆ　でも書けるが、実プログラムは３分岐もあるのでこの様な書き方とした。

Ｂｏｏｋ０１の内容については左記　Ｂｏｏｋ０１．ｈｔｍ　をクリックしてください。

SOURCE ＣＯＤＥ

Sub SheetCellMove()

　　　　Dim WS As String

　　　　WS = ActiveCell.Worksheet.Name 'シート名読み取り

　　　　　　　　'Debug.Print WS: End

　Select Case WS　　　　　　　　　　　　　　　　　　　　'シート名により分岐

　　　Case "GG"　　　　

　　　　　If ActiveCell.Row >= 54 Then GoTo 100 '最初カーソルはＧＧの５４行以降に

　　　　　If 52 >= ActiveCell.Row Then GoTo 101　　'置き、次は５２行以内置く

100 　　Worksheets("Sheet1").Select

　　　　　Worksheets("Sheet1").Range("A361").Select

　　　　　Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True: GoTo 102

101 　 Worksheets("Sheet1").Select

　　　　　Worksheets("Sheet1").Range("A310").Select

　　　　　Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True: GoTo 102

102

Case "FF"　　　　　　　　　　　　　　　　　　　　　　　'カーソル位置はＦＦ内のどこでも　

　　　　　Worksheets("Sheet1").Select　　　　　　　　　'良い　　ＥＥ～ＢＢも同様

　　　　　Worksheets("Sheet1").Range("A259").Select

　　　　　Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True

'　　 Case "EE" Case "DD"　　Case "CC"　　は省略

'　　　　　　A206 A157 A106

Case "BB"

　　　　　Worksheets("Sheet1").Select

　　　　　Worksheets("Sheet1").Range("A55").Select

　　　　　Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True

　End Select

End Sub

　　　次回は　Ｎｏ－８，４，７　を組み合わせてホームページ上の表データをコピー状態にしておき、ＧＧ～ＡＡシート上からＳｈｅｅｔ１の指定位置に貼り付け、貼り付けた表データの必要部分を選択し、選択部分をコピー状態にする　までの一連のマクロを３個のプロシジャーで構成して実行させる統合マクロを作成する。　選択部分はコピー状態にあるため　ＧＧ～ＡＡ　のシートに戻って　そのシートの必要位置に簡単に貼り付けられる。　ホームページ上の必要データをパソコンに取り込み、時系列的に並べる作業が軽減される。

９．　表データの貼付とデータの選択　

　　　上段をメイン、中段をサブ１、下段をサブ２呼ぶと　プログラムの動きはメインの　Paste_DelLine01　でサブ１へ、サブ１から　RangeSelectCopy01　でサブ２へ飛ぶ。　

　　　ホームページ上の表データをコピー状態にしておき、最初のカーソルを　ＧＧシートの５４行以降に置いておいて、ニコチャンマークをクリックすると　表データがＳｈｅｅｔ１のＧＧ枠内に張付けられて　Ａ－５、Ａ－７　列が選択され、コピー状態となる。

　　　コピー状態になったＳｈｅｅｔ１のデータをＧＧシートに戻って、時系列的にデータを入れたい場所Ｇ３にカーソルを置いて、ＥＸＣＥＬの貼付のアイコンをクリックすればＧ，Ｈにデータが挿入できる。

SOURCE ＣＯＤＥ

Sub ＤａｔａＰａｓｔｅ_Select() 　　 ' 各シートからＳｈｅｅｔ１の指定場所へカーソル移動

　　　　Dim WS As String

　　　　WS = ActiveCell.Worksheet.Name
　　　　'Debug.Print WS: End

　Select Case WS

　　　Case "GG"
　　　　　If ActiveCell.Row >= 54 Then GoTo 100
　　　　　If 52 >= ActiveCell.Row Then GoTo 101
100 　　Worksheets("Sheet1").Select
　　　　　Worksheets("Sheet1").Range("A361").Select
　　　　　Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True: GoTo 102
101 　　Worksheets("Sheet1").Select
　　　　　Worksheets("Sheet1").Range("A310").Select
　　　　　Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True: GoTo 102
102 　　　　　Paste_DelLine01

　　　Case "FF"
　　　　　Worksheets("Sheet1").Select
　　　　　Worksheets("Sheet1").Range("A55").Select
　　　　　Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
　　　　　　　　Paste_DelLine0

　　Case "EE" Case "DD"　Case "CC"　　は省略　　　　　　A206 A157 A106

　　　Case "BB"
　　　　　Worksheets("Sheet1").Select
　　　　　Worksheets("Sheet1").Range("A55").Select
　　　　　Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
　　　　　　　　Paste_DelLine01

　End Select
End Sub

Sub Paste_DelLine01()　　　　'Ｓｈｅｅｔ１の移動カーソル位置に表データを貼付、掛線削除

　　　　ActiveSheet.Paste
　　　　Selection.Borders().LineStyle = xlNone

　　　　Sheets("Sheet1").Select
　　 RangeSelectCopy01

End Sub

Sub RangeSelectCopy01()　　　'表データの　Ｇ，Ｉ列Ｒｏｗ行を選択し、コピー状態にする

　　　　Dim Row, RowN, Col, N As Integer
　　　　Dim AA, BB, CC, DD As String

　　　　Row = ActiveCell.Row
　　　　Col = ActiveCell.Column
　　　　RowN = Selection.Rows.Count
　　　　　　AA = "G" & Row: BB = "G" & Row + RowN - 1
　　　　　　CC = "I" & Row: DD = "I" & Row + RowN - 1
　　　　　　　　　' Debug.Print Row, Col, AA, BB, CC, DD, RowN ': End

　　　　　　　　　'Range(AA, BB).Select
　　　　　　　　　'Range(CC, DD).Select
　　　　Union(Range(AA, BB), Range(CC, DD)).Select
　　　　Selection.Copy

End Sub　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　

１０．　　追加データの別表への取得

　　　Ｓｈｅｅｔ１のデータをＧＧシートへ張付ける時に、Ｓｈｅｅｔ１のデータの追加Ｌ列データをＧＧシートの別表に挿入するマクロを次に記述する。　ＧＧシートのＧ３にカーソルを置きニコチャンマークをクリックして下記のマクロを実行すれば　Ｇ，Ｈ　と　Ｓｈｅｅｔ１のＬのデータがＧＧシートの別表Ｇ列に取得できる。　Ｂｏｏｋ２に表とデータの関連を示す、

　　　１．リンク方式数式データの貼付　と　２．直接方式データの貼付　の両方をコードに書き込んである。　１．リンク方式はリンクを貼る手間はかかるが、プログラムが簡単だ。　２．直接方式は　EachRangeSelect02　のサブルーティンが必要となる。

　　Ｂｏｏｋ０２の内容については左記　Ｂｏｏｋ０２．ｈｔｍ　をクリックしてください。

Sub Paste_DataGet()
'
' Macro1 Macro
' マクロ記録日 : 2007/10/10 ユーザー名 : Ryu&You
'
　　　　ActiveSheet.Paste　　　　　　　　　'Ｓｈｅｅｔ１選択セルの貼付

　　　　Dim AA, BB, WSS As String　　　　'追加データの範囲選択とコピー/貼付
　　　　Dim M, N As Integer
　　　　　　　M = ActiveCell.Column
　　　　　　　N = ActiveCell.Row
　　　　　　　　　　' Debug.Print M: End

　　　　　　　　　　　　　　　　　　　　　　　　'(１．リンク方式数式データの貼付)
　　　　Range("Ｌ309:Ｌ358").Select　　 'リンク先数式データ範囲設定とコピー状態に
　　　　Selection.Copy
　　　　ActiveWindow.SmallScroll Down:=-50　　 '指定先Ｇ71にカーソルを移動
　　　　ActiveWindow.SmallScroll ToRight:=M - 5
　　　　Cells(71, M).Select
　　　　ActiveSheet.Paste　　　　　 '指定先に数式貼付により数式データ挿入
　　　　Range(Cells(71, M), Cells(120, M)).Select 　　　'挿入数式データの数値化
　　　　Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
　　　　　　　　:=False, Transpose:=False

　　　　　　'WSS = ActiveCell.Worksheet.Name 　'(２．直接方式データの貼付 :6行)

　　　　　　'EachRangeSelect02

　　　　　　'Selection.Copy
　　　　　　'Sheets(WSS).Select
　　　　　　'Cells(801, M).Select
　　　　　　'ActiveSheet.Paste

　　　　Selection.Font.ColorIndex = 5 　　　　　'数値化フォントの青へ色替え
　　　　Application.CutCopyMode = False　　 'コピー状態解除

　　　　Application.Wait (Now() + TimeValue("00:00:03")) '３秒間停止タイマー：データ
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　'確認のため挿入

　　　　Cells(3, M).Select 　'カーソルを戻す

End Sub

Sub EachRangeSelect02()

　　　　Dim WS As String

　　　　WS = ActiveCell.Worksheet.Name
　　　　Debug.Print WS: End

　　Select Case WS

　　　　Case "ＧＧ"
　　　　　　If ActiveCell.Row = 3 Then
　　　　　　　Worksheets("Sheet1").Select
　　　　　　　Range("Ｌ309:Ｌ358").Select
　　　　　　Else
　　　　　　End If

　　　　Case "ＦＦ"
　　　　　　If ActiveCell.Row = 3 Then
　　　　　　　Worksheets("Sheet1").Select
　　　　　　　Range("Ｌ258:Ｌ307").Select
　　　　　　Else
　　　　　　End If

　　　　Case "ＥＥ"　　Case "ＤＤ"　　Case "ＣＣ"　　Case "ＢＢ"　　'省略

　　　　Case "ＡＡ"
　　　　　　If ActiveCell.Row = 3 Then
　　　　　　　Worksheets("Sheet1").Select
　　　　　　　Range("Ｌ3:Ｌ52").Select
　　　　　　Else
　　　　　　End If

　　End Select
End Sub

　シート名取得、アクティブ範囲行列数取得、カーソルの位置取得と移動方法、範囲選定に変数の使用方法等をマスターすれば　Ｂｏｏｋ内へデータの取り込みまたはデータの移動が自由に出来る。　　

　　データが時系列的に並べば　後はＥＸＣＥＬのグラフ機能を使って簡単に好きな形式のグラフを作ることが出来てデータの変動が一目で分かる。

　　ここに記載の全マクロは実際に使用しているが、Ｎｏ－８，９，１０はモデル化に当たってバグ（シート名、セル番号等、コードは実マクロからのコピーのためバグはないと思う）があるかもしれないので　その時は修正願いたい。

１１．　インボリュート逆関数　と　転位歯車の基本計算

　　御年６７才、転位歯車の諸元を基本計算することになり　インボリュート関数　なんてチンプンカンプン、NET　（http://www.nc-net.or.jp/morilog/m120353.html）のお世話になって　ヤット　理解できるようになる。　投稿者には感謝。　プログラム、エクセルマクロ登録、使用方法が　解かりにくかったので　ここで　簡単に利用できるように　説明した。

プログラム

Function INV(α)　　　　　　　　’インボリュート関数定義
　　　INV = Tan(α) - α
End Function

Function AINV(invα)　　　　　’インボリュート逆関数の計算　　ニュートン法による解
　　　　B = 1.5706
　　Do
　　　　S = B
　　　　B = S - (Tan(S) - S - invα) / (Tan(S) ^ 2)
　　Loop Until Abs(B - S) < 0.000000001
　　　　AINV = B
End Function

EXSAMPLE		転位平歯車の基本計算		（出典：KHK歯車大学より）
				pinion　1	gear　2
m：モジュール				3
α：圧力角				20
ｚ：歯数				12	24
ｘ：転位係数				0.6	0.36
invα’	2・tanα・（ｘ1+ｘ2）/（ｚ1+ｚ2）＋invα			0.034316195
	inv20.0＝	0.0149044
	inv14.5＝	0.0055448
α’：圧力角		0.455332	rad	26.08851807
ｙ：距離係数	（ｚ1+ｚ2）/2・（ｃosα/cosα’-１）			0.833286828
a：中心距離	((z1+z2)/2+y)・ｍ			56.49986048
d：基準円		ｚ・ｍ		36	72
ｄｂ：基準円		ｄ・cosα		33.82892	67.6578486
d'：噛合部ＰＣＤ		db/cosα’		37.66657	75.33314731
ha１：歯末の丈		（１+ｙ-ｘ2）・ｍ		4.41986
ha２：歯末の丈		（１+ｙ-ｘ１）・ｍ			3.699860485
h：歯丈		(2.25+y-(x1+x2))・m		6.369860485
da：歯先円直径		d+2・ha		44.83972	79.39972097
df：歯底円直径		da-2・h		32.1	66.66

　　　　　　invα’＝0.0034316195　の場合　α’＝0.455332rad＝26.08851807° となる。

　　　　　　　　　（註）プログラムの　α　は　基本計算の　α’　と同じ。

エクセルマクロへの登録（　Function　は　エクセル自作関数　の定義コード）

1.歯車の諸元を計算しているエクセルブックの　「ツール」→「マクロ」→「Visual Basic Editor」クリックしてエディター画面を開く。　

2.画面左の「VBAProject」を左クリックして　「挿入」から「標準モジュール」をクリックすると　プロジェクト内に「標準モジュール」（Module1)が追加され　右にＭｏｄｕｌｅ１ウインドウが開く。　ここに上記プログラムをコピーする。

3.上書きしてエクセルブックに戻る。　ブック内でインボリュート逆関数が利用可能となる。

エクセルブックでの使用方法

１.セル（Ａ,５）に　角度α（radian）値が　あるとしよう。　セル（Ａ,７）にインボリュート逆関数を表示させようとすれば　セル（Ａ,７）に　”＝ＡＩＮＶ（Ａ,５）”　と記述すれば　逆関数がradianで求められる。

２.他のブックで使用したい場合は　計算しようとするブックに　上記と同様にコピーして使用することになります。　どのブックでも使える　PERSONAL.EXL　と　Function関数　との違いとなります。　　　　

１２．　インボリュート歯車の歯形作図（　前　１１．と関連　）

　　大口径歯車（m=22、θ=20°、N=13ｘ109）メンテに携わっているが、摩耗が進行してきたので、歯の計測を始めた。　オリジナル歯形寸法を知るために歯形作図に挑戦した。　簡単にするため　エクセルの表計算とグラフ機能　を使用する。　インボリュート関数、座標変換等インターネットで探し　グラフ化出来た。　転位歯車であるためか　計算と理論　どうりでは　どうも　実際の歯形（歯厚）と異なるようなので　手入力で修正系数を入れて　実際の歯形　に近くなるようにした。　お分かりの方に　正しい方法をアドバイス願えれば幸いです。

エクセルブック　は　下記ファイル名　クリック　して　ＤＬ　願いたい。

ファイル名　：　Shape Drawing for Shifted Gear Tooth

	転位平歯車　の　歯厚計算　　　　（出典：KHK歯車大学より）
	pinion　１
m	22	ha	=m + mx	22
α	20
ｚ	13	歯厚	s=	34.5576
ｘ	0	＝(π/2+2・tanα）・m
ha	=m + mx	歯厚半径	ψ=	6.9230769
		＝90/z+(360・tanα)/（π・ｚ）
PCD＝	286	弦歯厚	ss	34.473571
b=	85	＝z・m・sinψ
		弦高さ	hha	23.042636
		＝z・m（1-cosψ)/2+ha
	gear　２
m	22	ha	=m + mx	44
α	20
ｚ	109	歯厚	s=	50.572331
ｘ	1	＝(π/2+2・tanα）m
ha	=m + mx	歯厚半径	ψ=	1.2083296
		＝90/z+(360・tanα)/（π・ｚ）
PCD＝	2398	弦歯厚	ss	50.568582
b=	90	＝z・m・sinψ
		弦高さ	hha	44.266625
		＝z・m（1-cosψ)/2+ha

	転位平歯車　の　基礎計算　　　　（出典：KHK歯車大学より）
				pinion　１	gear　２
m：モジュール				22
α：圧力角				20
ｚ：歯数				13	109
ｘ：転位係数				0	1
ｲﾝﾎﾞﾘｭｰﾄα’	2・tanα・（ｘ1+ｘ2）/（ｚ1+ｚ2）＋inv α			0.020871232
inv α’
inv α=	Tan α -　α		0.014904492
		AINV(inv α’)		（　前　１１．プログラム使用）
α’：圧力角		0.38891	rad	22.28282225
ｙ：距離係数	（ｚ1+ｚ2）/2・（ｃosα/cosα’-１）			0.947262616
a：中心距離	((ｚ1+ｚ2)/2+y)・ｍ			1362.839778
d：基準円	ｚ・ｍ			286	2398
ｄｂ：基準円	ｄ・cosα			268.752	2253.3822
d'：噛合部ＰＣＤ	db/cosα’			290.4413	2435.2383
ha１：歯末の丈	（1+ｙ-ｘ2）・ｍ			20.83978
ha２：歯末の丈	（1+ｙ-ｘ1）・ｍ				42.839778
h：歯丈	(2.25+y-(x1+x2))・m			48.33977756
da：歯先円直径	d+2・ha			327.6796	2483.6796
df：歯底円直径	da-2・h			231	2387

１３．　平歯車の強度計算　（　前　１２．と関連　）

　　前　１２．転位平歯車の強度計算を　ＫＨＫ歯車大学　の計算式に基づき　エクセルの表計算を利用して　少ない入力（数値表を新たに作成し、極力自動入力とした）で　入力（Ｋｗ）に対して、歯車曲げ強度（Ｋｗ）及び面圧強度（Ｋｗ）が十分であるかどうかを　「ＯＫ or NO」　で判定するプログラム作成した。参考として　ＫＨＫ歯車大学の計算式のオリジナル　を添付してあります。　歯車設計等については　実経験ないため　計算式の解釈等に間違いあれば　アドバイスいただき、修正を加えて行くことにしたい。　

ファイル名　：　Check of Gear Tooth_Strength

　　プログラム詳細内容については　上記ファイルを　開くか又は保存して確認、試用してください。　参考になれば幸いである。

TOP PAGE CEMENT ENGINEERING EXCEL VBA .NET VB SCHTASKS/WSH

NOW CONSTRUCTING