computer/programing/vba
をテンプレートにして作成
[
トップ
] [
新規
|
一覧
|
単語検索
|
最終更新
|
ヘルプ
|
ログイン
]
開始行:
#contents
#highlighter(VBScript){{
Sub DelAllGraph()
ActiveSheet.ChartObjects.Delete
End Sub
}}
#highlighter(VBScript){{
Sub data_reduction001()
'This proguram takes order the original experimental data.
'The original data is "粘度2016.xlsm" which is located in RAID02.
l = 1
For i = 1 To 7
For j = 1 To 4
For k = 1 To 11
Cells(20 * l + k - 1, 7) = Cells(1 + j, -4 + 11 * i + k)
Next k
l = l + 1
Next j
Next i
End Sub
}}
#highlighter(VBScript){{
Sub Narae_Previous000()
'Upper cell is refered by using this program.
'This program is used to handle different experimental data number.
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim n As Double
n = 1
i = 1
Do While Cells(20 * i + 1, 3) <> ""
k = 0
n = 1
For j = 1 To 20
If Cells(20 * i + j, 3) <> n Then
Range(Cells(20 * i + j, 1), Cells(20 * i + j, 30)).Font.Color = vbRed
k = k + 1
Else
Range(Cells(20 * i + j, 1), Cells(20 * i + j, 30)).Font.Color = vbBlack
Cells(20 * i + j, 4) = "=d" & 20 * i + j - 1
Cells(20 * i + j, 5) = "=e" & 20 * i + j - 1
End If
n = Cells(20 * i + j, 3)
Next j
i = i + 1
Loop
End Sub
}}
#highlighter(VBScript){{
Sub Calc_ExcessMolarVolume()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim n As Double
n = 1
i = 1
Do While Cells(20 * i + 1, 3) <> ""
k = 0
n = 1
For j = 1 To 20
Cells(20 * i + j, 10) = "=i" & 20 * i + j & "-(i" & 20 * i + 1 & "*(1-" & "c" & 20 * i + j & ")+c" & 20 * i + j & "*i" & 20 * i + 20 & ")"
Next j
i = i + 1
Loop
End Sub
}}
*キーワードを蛍光ペンで着色(word用) [#pd75bcfb]
#highlighter(VBScript,number=off){{
Sub キーワードを蛍光ペンで着色()
Dim myRange As Range
Dim myKW As String
Dim myColor As String
myKW = InputBox("キーワードを入力してください。")
'キーワードが入力されない場合には終了
If myKW = "" Then Exit Sub
'現在の蛍光ペンの色を保存
myColor = Options.DefaultHighlightColorIndex
'蛍光ペンの色を黄色に設定
Options.DefaultHighlightColorIndex = wdYellow
'wdAuto
'wdBlack
'wdBlue
'wdBrightGreen
'wdByAuthor
'wdDarkBlue
'wdDarkRed
'wdDarkYellow
'wdGray25
'wdGray50
'wdGreen
'wdNoHighlight
'wdPink
'wdRed
'wdTeal
'wdTurquoise
'wdViolet
'wdWhite
'wdYellow
'myRange(オブジェクト変数)を設定
Set myRange = ActiveDocument.Range(0, 0)
'一括置換を実行(「検索と置換」ダイアログボックスの設定)
With myRange.Find
.Text = myKW '検索する文字列
.Replacement.Text = "" '置換後の文字列(空欄でOK)
.Replacement.Highlight = True '置換後の文字列の蛍光ペンをオン
.Forward = True
.Wrap = wdFindStop
.Format = True '書式の設定をオン
.MatchCase = False '大文字と小文字の区別する
.MatchWholeWord = False '完全に一致する単語だけを検索する
.MatchByte = False '半角と全角を区別する
.MatchAllWordForms = False '英単語の異なる活用形を検索する
.MatchSoundsLike = False 'あいまい検索(英)
.MatchFuzzy = False 'あいまい検索(日)
.MatchWildcards = False 'ワイルドカードを使用する
.Execute Replace:=wdReplaceAll
End With
'蛍光ペンの色を元に戻す
Options.DefaultHighlightColorIndex = myColor
'myRangeを解放
Set myRange = Nothing
End Sub
}}
*グラフ作図(密度データ) [#r67ef280]
#highlighter(VBScript){{
Sub Draw_Graph000()
'This program draw the graphs of volumetric and viscometric behaviors.
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim n As Integer
Dim gpos_x As Integer
Dim gpos_y As Integer
Dim g_width As Integer
Dim g_hight As Integer
Dim chartObj As ChartObject
Dim ans As Integer
Dim graph_name As String
Dim data_number(20) As Integer
Dim alcohol As String
Dim strSheetName As String
strSheetName = ActiveSheet.Name
' アクティブシート上に既存のグラフがあれば削除
If ActiveSheet.ChartObjects.Count > 0 Then
For i = 1 To ActiveSheet.ChartObjects.Count
' グラフ名が一致するか
If ActiveSheet.ChartObjects(i).Name = graph_name Then
ActiveSheet.ChartObjects(i).Delete
Exit For
End If
Next i
End If
alcohol = strSheetName
physical_value = "density"
If alcohol = "methanol" Then
n = 7
data_number(1) = 4 '351K
data_number(2) = 4 '373K
data_number(3) = 4 '476K
data_number(4) = 3 '523K
data_number(5) = 3 '573K
data_number(6) = 3 '618K
data_number(7) = 3 '673K
ElseIf alcohol = "ethanol" Then
n = 7
data_number(1) = 4 '351K
data_number(2) = 4 '373K
data_number(3) = 4 '476K
data_number(4) = 3 '523K
data_number(5) = 3 '573K
data_number(6) = 3 '618K
data_number(7) = 3 '673K
ElseIf alcohol = "1-propanol" Then
n = 7
data_number(1) = 4 '351K
data_number(2) = 4 '373K
data_number(3) = 4 '476K
data_number(4) = 3 '523K
data_number(5) = 3 '573K
data_number(6) = 3 '618K
data_number(7) = 3 '673K
ElseIf alcohol = "2-propanol" Then
n = 7
data_number(1) = 4 '351K
data_number(2) = 4 '373K
data_number(3) = 4 '476K
data_number(4) = 3 '523K
data_number(5) = 3 '573K
data_number(6) = 3 '618K
data_number(7) = 3 '673K
End If
For i = 1 To n
'グラフの位置
gpos_x = 420 * (1 - 1) + 100
gpos_y = 299 * (i - 1) + 300
'グラフのサイズ
g_width = 90 * 4
g_hight = 90 * 3
' グラフ識別子
graph_name = "numbered_entry"
'Objects追加位置(左位置, 上位置, 幅, 高さ)
Set chartObj = ActiveSheet.ChartObjects.Add(gpos_x, gpos_y, g_width, g_hight)
chartObj.Name = graph_name
'ChartArea設定
chartObj.Chart.ChartArea.Format.Line.Visible = msoFalse
With chartObj.Chart
'ChartArea設定
.ChartArea.Format.Line.Visible = msoFalse
.PlotArea.Select 'PlotArea設定(暫定)
With Selection
.Format.Line.ForeColor.ObjectThemeColor = msoThemeColorText1 'plot area枠を黒に
.Height = 230
.Width = 320
.Top = 5
.Left = 25
End With
For j = 1 To data_number(i)
'データ設定
If j <> 1 Then
.SeriesCollection.NewSeries
End If
With .SeriesCollection(j)
l = 20
For k = 1 To i - 1
l = l + data_number(k) * 20
Next k
l = l + 20 * (j - 1)
.Values = Range(Cells(l + 1, 4), Cells(l + 20, 4))
.XValues = Range(Cells(l + 1, 3), Cells(l + 20, 3))
.Name = Cells(l + 1, 13)
.ChartType = xlXYScatterLines
'以下散布図線付き時のみ
With .Format.Line
'線を作画するか
.Visible = msoTrue
'線の太さ
.Weight = 0.5
'点線
'.DashStyle = msoLineSysDash
.ForeColor.RGB = RGB(127 * (Int(j / 9) Mod 3), 127 * (Int(j / 3) Mod 3), 127 * (Int(j) Mod 3))
End With
'.ChartType = xlXYScatter '散布図
.MarkerStyle = xlMarkerStyleCircle 'マーカー (丸)
.MarkerSize = 5
.MarkerBackgroundColorIndex = 0 'マーカー塗りつぶしの色
.MarkerForegroundColor = RGB(127 * (Int(j / 9) Mod 3), 127 * (Int(j / 3) Mod 3), 127 * (Int(j) Mod 3))
End With
Next j
'グラフタイトル
.HasTitle = True
With .ChartTitle
.Text = alcohol
.Left = 60
.Top = 15
With .Format.TextFrame2.TextRange.Font
.Bold = msoFalse
.Size = 10
'MS P ゴシック
.Name = "+mj-ea"
End With
End With
'x軸タイトル
With .Axes(xlCategory, xlPrimary)
.HasTitle = True
With .AxisTitle
.Font.Bold = msoFalse
If alcohol = "methanol" Then
.Characters.Text = "xm"
'ここでの(1, 1)は文字の範囲を指定
.Characters(1, 1).Font.FontStyle = "italic"
'下付き
.Characters(2, 1).Font.Subscript = True
ElseIf alcohol = "ethanol" Then
.Characters.Text = "xe"
.Characters(1, 1).Font.FontStyle = "italic"
.Characters(2, 1).Font.Subscript = True
ElseIf alcohol = "1-propanol" Then
.Characters.Text = "x1pro"
.Characters(1, 1).Font.FontStyle = "italic"
.Characters(2, 5).Font.Subscript = True
ElseIf alcohol = "2-propanol" Then
.Characters.Text = "x2pro"
.Characters(1, 1).Font.FontStyle = "italic"
.Characters(2, 5).Font.Subscript = True
Else
.Characters.Text = "x"
.Characters(1, 1).Font.FontStyle = "italic"
End If
.Characters.Font.Size = 12
End With
End With
'y軸タイトル
With .Axes(xlValue, xlPrimary)
.HasTitle = True
With .AxisTitle
.Font.Bold = msoFalse
.Characters.Text = "density / kg m-3"
.Characters(15, 2).Font.Superscript = True
End With
End With
'x軸設定
With .Axes(xlCategory)
.MaximumScale = 1
.MinimumScale = 0
.MajorTickMark = xlInside '軸目盛内向き
.TickLabels.NumberFormatLocal = "G/標準"
.MajorGridlines.Delete '補助線を削除
With .Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
End With
End With
'y軸設定
With .Axes(xlValue)
.MajorTickMark = xlInside
.TickLabels.NumberFormatLocal = "G/標準"
.MajorGridlines.Delete
With .Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
End With
End With
'凡例設定
With .Legend
.Left = 230
.Width = 100
.Height = 100
.Top = 100
End With
End With
Next i
End Sub
}}
終了行:
#contents
#highlighter(VBScript){{
Sub DelAllGraph()
ActiveSheet.ChartObjects.Delete
End Sub
}}
#highlighter(VBScript){{
Sub data_reduction001()
'This proguram takes order the original experimental data.
'The original data is "粘度2016.xlsm" which is located in RAID02.
l = 1
For i = 1 To 7
For j = 1 To 4
For k = 1 To 11
Cells(20 * l + k - 1, 7) = Cells(1 + j, -4 + 11 * i + k)
Next k
l = l + 1
Next j
Next i
End Sub
}}
#highlighter(VBScript){{
Sub Narae_Previous000()
'Upper cell is refered by using this program.
'This program is used to handle different experimental data number.
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim n As Double
n = 1
i = 1
Do While Cells(20 * i + 1, 3) <> ""
k = 0
n = 1
For j = 1 To 20
If Cells(20 * i + j, 3) <> n Then
Range(Cells(20 * i + j, 1), Cells(20 * i + j, 30)).Font.Color = vbRed
k = k + 1
Else
Range(Cells(20 * i + j, 1), Cells(20 * i + j, 30)).Font.Color = vbBlack
Cells(20 * i + j, 4) = "=d" & 20 * i + j - 1
Cells(20 * i + j, 5) = "=e" & 20 * i + j - 1
End If
n = Cells(20 * i + j, 3)
Next j
i = i + 1
Loop
End Sub
}}
#highlighter(VBScript){{
Sub Calc_ExcessMolarVolume()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim n As Double
n = 1
i = 1
Do While Cells(20 * i + 1, 3) <> ""
k = 0
n = 1
For j = 1 To 20
Cells(20 * i + j, 10) = "=i" & 20 * i + j & "-(i" & 20 * i + 1 & "*(1-" & "c" & 20 * i + j & ")+c" & 20 * i + j & "*i" & 20 * i + 20 & ")"
Next j
i = i + 1
Loop
End Sub
}}
*キーワードを蛍光ペンで着色(word用) [#pd75bcfb]
#highlighter(VBScript,number=off){{
Sub キーワードを蛍光ペンで着色()
Dim myRange As Range
Dim myKW As String
Dim myColor As String
myKW = InputBox("キーワードを入力してください。")
'キーワードが入力されない場合には終了
If myKW = "" Then Exit Sub
'現在の蛍光ペンの色を保存
myColor = Options.DefaultHighlightColorIndex
'蛍光ペンの色を黄色に設定
Options.DefaultHighlightColorIndex = wdYellow
'wdAuto
'wdBlack
'wdBlue
'wdBrightGreen
'wdByAuthor
'wdDarkBlue
'wdDarkRed
'wdDarkYellow
'wdGray25
'wdGray50
'wdGreen
'wdNoHighlight
'wdPink
'wdRed
'wdTeal
'wdTurquoise
'wdViolet
'wdWhite
'wdYellow
'myRange(オブジェクト変数)を設定
Set myRange = ActiveDocument.Range(0, 0)
'一括置換を実行(「検索と置換」ダイアログボックスの設定)
With myRange.Find
.Text = myKW '検索する文字列
.Replacement.Text = "" '置換後の文字列(空欄でOK)
.Replacement.Highlight = True '置換後の文字列の蛍光ペンをオン
.Forward = True
.Wrap = wdFindStop
.Format = True '書式の設定をオン
.MatchCase = False '大文字と小文字の区別する
.MatchWholeWord = False '完全に一致する単語だけを検索する
.MatchByte = False '半角と全角を区別する
.MatchAllWordForms = False '英単語の異なる活用形を検索する
.MatchSoundsLike = False 'あいまい検索(英)
.MatchFuzzy = False 'あいまい検索(日)
.MatchWildcards = False 'ワイルドカードを使用する
.Execute Replace:=wdReplaceAll
End With
'蛍光ペンの色を元に戻す
Options.DefaultHighlightColorIndex = myColor
'myRangeを解放
Set myRange = Nothing
End Sub
}}
*グラフ作図(密度データ) [#r67ef280]
#highlighter(VBScript){{
Sub Draw_Graph000()
'This program draw the graphs of volumetric and viscometric behaviors.
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim n As Integer
Dim gpos_x As Integer
Dim gpos_y As Integer
Dim g_width As Integer
Dim g_hight As Integer
Dim chartObj As ChartObject
Dim ans As Integer
Dim graph_name As String
Dim data_number(20) As Integer
Dim alcohol As String
Dim strSheetName As String
strSheetName = ActiveSheet.Name
' アクティブシート上に既存のグラフがあれば削除
If ActiveSheet.ChartObjects.Count > 0 Then
For i = 1 To ActiveSheet.ChartObjects.Count
' グラフ名が一致するか
If ActiveSheet.ChartObjects(i).Name = graph_name Then
ActiveSheet.ChartObjects(i).Delete
Exit For
End If
Next i
End If
alcohol = strSheetName
physical_value = "density"
If alcohol = "methanol" Then
n = 7
data_number(1) = 4 '351K
data_number(2) = 4 '373K
data_number(3) = 4 '476K
data_number(4) = 3 '523K
data_number(5) = 3 '573K
data_number(6) = 3 '618K
data_number(7) = 3 '673K
ElseIf alcohol = "ethanol" Then
n = 7
data_number(1) = 4 '351K
data_number(2) = 4 '373K
data_number(3) = 4 '476K
data_number(4) = 3 '523K
data_number(5) = 3 '573K
data_number(6) = 3 '618K
data_number(7) = 3 '673K
ElseIf alcohol = "1-propanol" Then
n = 7
data_number(1) = 4 '351K
data_number(2) = 4 '373K
data_number(3) = 4 '476K
data_number(4) = 3 '523K
data_number(5) = 3 '573K
data_number(6) = 3 '618K
data_number(7) = 3 '673K
ElseIf alcohol = "2-propanol" Then
n = 7
data_number(1) = 4 '351K
data_number(2) = 4 '373K
data_number(3) = 4 '476K
data_number(4) = 3 '523K
data_number(5) = 3 '573K
data_number(6) = 3 '618K
data_number(7) = 3 '673K
End If
For i = 1 To n
'グラフの位置
gpos_x = 420 * (1 - 1) + 100
gpos_y = 299 * (i - 1) + 300
'グラフのサイズ
g_width = 90 * 4
g_hight = 90 * 3
' グラフ識別子
graph_name = "numbered_entry"
'Objects追加位置(左位置, 上位置, 幅, 高さ)
Set chartObj = ActiveSheet.ChartObjects.Add(gpos_x, gpos_y, g_width, g_hight)
chartObj.Name = graph_name
'ChartArea設定
chartObj.Chart.ChartArea.Format.Line.Visible = msoFalse
With chartObj.Chart
'ChartArea設定
.ChartArea.Format.Line.Visible = msoFalse
.PlotArea.Select 'PlotArea設定(暫定)
With Selection
.Format.Line.ForeColor.ObjectThemeColor = msoThemeColorText1 'plot area枠を黒に
.Height = 230
.Width = 320
.Top = 5
.Left = 25
End With
For j = 1 To data_number(i)
'データ設定
If j <> 1 Then
.SeriesCollection.NewSeries
End If
With .SeriesCollection(j)
l = 20
For k = 1 To i - 1
l = l + data_number(k) * 20
Next k
l = l + 20 * (j - 1)
.Values = Range(Cells(l + 1, 4), Cells(l + 20, 4))
.XValues = Range(Cells(l + 1, 3), Cells(l + 20, 3))
.Name = Cells(l + 1, 13)
.ChartType = xlXYScatterLines
'以下散布図線付き時のみ
With .Format.Line
'線を作画するか
.Visible = msoTrue
'線の太さ
.Weight = 0.5
'点線
'.DashStyle = msoLineSysDash
.ForeColor.RGB = RGB(127 * (Int(j / 9) Mod 3), 127 * (Int(j / 3) Mod 3), 127 * (Int(j) Mod 3))
End With
'.ChartType = xlXYScatter '散布図
.MarkerStyle = xlMarkerStyleCircle 'マーカー (丸)
.MarkerSize = 5
.MarkerBackgroundColorIndex = 0 'マーカー塗りつぶしの色
.MarkerForegroundColor = RGB(127 * (Int(j / 9) Mod 3), 127 * (Int(j / 3) Mod 3), 127 * (Int(j) Mod 3))
End With
Next j
'グラフタイトル
.HasTitle = True
With .ChartTitle
.Text = alcohol
.Left = 60
.Top = 15
With .Format.TextFrame2.TextRange.Font
.Bold = msoFalse
.Size = 10
'MS P ゴシック
.Name = "+mj-ea"
End With
End With
'x軸タイトル
With .Axes(xlCategory, xlPrimary)
.HasTitle = True
With .AxisTitle
.Font.Bold = msoFalse
If alcohol = "methanol" Then
.Characters.Text = "xm"
'ここでの(1, 1)は文字の範囲を指定
.Characters(1, 1).Font.FontStyle = "italic"
'下付き
.Characters(2, 1).Font.Subscript = True
ElseIf alcohol = "ethanol" Then
.Characters.Text = "xe"
.Characters(1, 1).Font.FontStyle = "italic"
.Characters(2, 1).Font.Subscript = True
ElseIf alcohol = "1-propanol" Then
.Characters.Text = "x1pro"
.Characters(1, 1).Font.FontStyle = "italic"
.Characters(2, 5).Font.Subscript = True
ElseIf alcohol = "2-propanol" Then
.Characters.Text = "x2pro"
.Characters(1, 1).Font.FontStyle = "italic"
.Characters(2, 5).Font.Subscript = True
Else
.Characters.Text = "x"
.Characters(1, 1).Font.FontStyle = "italic"
End If
.Characters.Font.Size = 12
End With
End With
'y軸タイトル
With .Axes(xlValue, xlPrimary)
.HasTitle = True
With .AxisTitle
.Font.Bold = msoFalse
.Characters.Text = "density / kg m-3"
.Characters(15, 2).Font.Superscript = True
End With
End With
'x軸設定
With .Axes(xlCategory)
.MaximumScale = 1
.MinimumScale = 0
.MajorTickMark = xlInside '軸目盛内向き
.TickLabels.NumberFormatLocal = "G/標準"
.MajorGridlines.Delete '補助線を削除
With .Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
End With
End With
'y軸設定
With .Axes(xlValue)
.MajorTickMark = xlInside
.TickLabels.NumberFormatLocal = "G/標準"
.MajorGridlines.Delete
With .Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
End With
End With
'凡例設定
With .Legend
.Left = 230
.Width = 100
.Height = 100
.Top = 100
End With
End With
Next i
End Sub
}}
ページ名: