ホーム VBAプログラムのサンプル プログラム開発等の委託の流れ 料金設定 受託規定
お問い合わせ 自己紹介 Excelでどこまでできるか データベース構築 ワークフロー データ分析 趣味の切手
科学・技術および経理事務の計算 農業土木および土木の歴史遺産写真 小企業支援
山崎農業研究所へのリンク Google Earth /地形図・海図からの測線データ（経・緯度、XY座標等）作成
その他（Ⅰ～Ⅶに属しないもの） VBA無料質問コーナ 小説になった農業用水路（農業土木施設）
現在無職ですので元職場への連絡・問合わせはご遠慮ください。
【VBAプログラムコードのサンプル】
VBAプログラムコードのサンプル
‘******************************************************************************
1.ヘロンの公式（ファイル名）
Private Sub CommandButton1_Click()
Call Module1.Calculate
End
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub Calculate()
Sheets("Sheet1").Select
Dim Area As Single '面積
'----------------------------
Call Module10.Tryal_Interval
'データ入力
a
= Cells(18, 3)
b
= Cells(19, 3)
c
= Cells(20, 3)
'----------------
s
= (a + b + c) / 2
Cells(22, 3) = s
'計算
Area = Heron(a, b, c)
'----------------
'結果の出力
Cells(23, 3) = Area
End Sub
'----------------------------------------------------------------------------------------------------------------------
Public Function Heron(a As Single, b As
Single, c As Single)
s
= (a + b + c) / 2
If s >= a And s >= b And s >= c Then
Heron = (s * (s - a) * (s - b) * (s - c)) ^ 0.5
Else
MsgBox "入力値が適切ではありません。" & Chr(13) &
"(s-a)、(s-b)、(s-c) " & Chr(13) & "の値が正になるように入力してください。"
End If
End Function
‘******************************************************************************
'2. ３次方程式の解計算（ファイル名）
'----------------------------------------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
Call Module1.Macro1
End
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 :
2002/5/5 ユーザー名 : 益永八尋
'
'
'*****************************************************************
'*
３次方程式の解を求める *
'*
FILE NAME IS "HOUTEI-3"
BY MASUNAGA 1986.5.15 *
【注意】このサンプルコードはBasicで作成されたコードからVBAのコードに変換したものであるため、Basicの表現が残っている。また、このためコードが読みづらいものになっている。
'*****************************************************************
'
Dim
X(10) As Single
Dim
Z(10) As Single
A1 =
Cells(16, 3)
A2 =
Cells(17, 3)
A3 =
Cells(18, 3)
A4 =
Cells(19, 3)
A =
A2 / A1
B0 =
A3 / A1
C =
A4 / A1
'----------------------------------------
PAI
= 3.1415926
A =
A2 / A1
B0 =
A3 / A1
C =
A4 / A1
MM =
(3 * B0 - A * A) / 3
NN =
(2 * A ^ 3 - 9 * A * B0 + 27 * C) / 27
DD =
NN ^ 2 / 4 + MM ^ 3 / 27
DD1
= Sgn(DD) + 2
On
DD1 GoTo 1410, 1360, 1310
1310:
N = 1: '----- DD > 0 ------
Z1 =
-NN / 2 + Sqr(DD)
Z2 =
-NN / 2 - Sqr(DD)
Z(1)
= Sgn(Z1) * Abs(Z1) ^ (1 / 3) + Sgn(Z2) * Abs(Z2) ^ (1 / 3)
GoTo
1500
1360:
N = 2: '----- DD=0
-------
S =
Sgn(NN)
Z(1)
= S * Sqr(-MM / 3)
Z(2)
= -2 * S * Sqr(-MM / 3)
GoTo
1500
1410:
N = 3: '----- DD < 0 ------
S =
-Sgn(NN)
W =
S * Sqr(NN * NN / 4 / (-MM ^ 3 / 27))
GoSub 1660
DEG
= ACS * 180 / PAI
For
J = 1 To 3
W0
= (DEG / 3 + 120 * J) * PAI / 180
Z(J) = 2 * Sqr(-MM / 3) * Cos(W0)
Next
J
1500:
For
J = 1 To N
X(J) = Z(J) - A / 3
Next
J
'-------------- 印刷 ------------------------
Range("B23:C25").Clear
For
J = 1 To N
Cells(22 + J, 2) = "X(" & Format(J, "0") &
")="
Cells(22 + J, 3) = Format(X(J), "##0.000000")
Next
J
'--------------------------------------------
Call Module1.Keisen 'ｻﾌﾞﾙｰﾁﾝ【Keisen】の実行
'--------------------------------------------
End sub
'=============================================================
'==============================================================
1660:
Sub Acos（）
'-------------- SUBRUTINE
-------------------
If W
= 0 Then ACS = PAI / 2: GoTo 1720
If W
> 0 Then GoTo 1690 Else GoTo 1710
1690:
ACS = Atn(Sqr(1 - W * W) / W)
GoTo 1720
1710:
ACS = PAI + Atn(Sqr(1 - W * W) / W)
1720:
'--------------------------------------------
End Sub
'----------------------------------------------------------------------------------------------------------------------
Sub Keisen()
' Macro2 Macro
' マクロ記録日 :
2002/5/5 ユーザー名 : 益永八尋
Range("B22:D25").Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("B23:B25").Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
End Sub
‘******************************************************************************