数値フィルターの設定

数値フィルター

cnt(0) = Sheets("設定").Cells(5, 2)
cnt(1) = Sheets("設定").Cells(5, 3)

If cnt(1) <> "" And cnt(0) <> "" Then
Selection.AutoFilter field:=1, Criteria1:=cnt(0), Operator:=xlAnd, Criteria2:=cnt(1)
ElseIf cnt(0) <> "" Then
Selection.AutoFilter field:=1, Criteria1:=cnt(0)
End If ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ ↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑

グラフの軸編集(ユーザーフォームから)

x軸

Private Sub x_Click()

If Me.yma.Text = "" And Me.ymi.Text = "" Then
Charts("偶発探査").Axes(xlCategory).MaximumScaleIsAuto = True
Charts("偶発探査").Axes(xlCategory).MinimumScaleIsAuto = True
ElseIf Me.ymi.Text = "" Then
Charts("偶発探査").Axes(xlCategory).MinimumScaleIsAuto = True
Charts("偶発探査").Axes(xlCategory).MaximumScale = Me.yma.Text
ElseIf Me.yma.Text = "" Then
Charts("偶発探査").Axes(xlCategory).MaximumScaleIsAuto = True
Charts("偶発探査").Axes(xlCategory).MinimumScale = Me.ymi.Text
Else

Charts("偶発探査").Axes(xlCategory).MaximumScale = Me.yma.Text
Charts("偶発探査").Axes(xlCategory).MinimumScale = Me.ymi.Text
End If


End Sub

y軸

Private Sub CommandButton1_Click()

If Me.tx_xmax.Text = "" And Me.tx_xmin.Text = "" Then
Charts("偶発探査").Axes(xlValue).MaximumScaleIsAuto = True
Charts("偶発探査").Axes(xlValue).MinimumScaleIsAuto = True
ElseIf Me.tx_xmin.Text = "" Then
Charts("偶発探査").Axes(xlValue).MinimumScaleIsAuto = True
Charts("偶発探査").Axes(xlValue).MaximumScale = Me.tx_xmax.Text
ElseIf Me.tx_xmax.Text = "" Then
Charts("偶発探査").Axes(xlValue).MaximumScaleIsAuto = True
Charts("偶発探査").Axes(xlValue).MinimumScale = Me.tx_xmin.Text
Else

Charts("偶発探査").Axes(xlValue).MaximumScale = Me.tx_xmax.Text
Charts("偶発探査").Axes(xlValue).MinimumScale = Me.tx_xmin.Text
End If


End Sub

↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ ↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑

ワイブル解析

標準モジュール
Option Explicit

Private blnOk As Boolean
Private okng As Integer



Sub fileopen()

Dim filename As String
Dim name As String
Dim mr As Double
Dim ans As Integer
Dim model(2) As String
Dim comp(2) As String

model(0) = Sheets("設定").Cells(3, 2)
model(1) = Sheets("設定").Cells(3, 3)
model(2) = Sheets("設定").Cells(3, 4)
comp(0) = Sheets("設定").Cells(4, 2)
comp(1) = Sheets("設定").Cells(4, 3)
comp(2) = Sheets("設定").Cells(4, 4)

Sheets("累積H").AutoFilterMode = False
Sheets("累積H").Range("A:H").Delete

filename = Application.GetOpenFilename


If filename <> "False" Then
ans = MsgBox(filename & "を読み込みます", vbOKCancel, "読み込み確認")
If ans = vbOK Then
Workbooks.Open filename
name = ActiveWorkbook.name
mr = Cells(Rows.Count, 1).End(xlUp).Row
Selection.AutoFilter field:=3, Criteria1:="1"

If model(0) <> "" Then
Selection.AutoFilter field:=4, Criteria1:=model, Operator:=xlFilterValues
End If
If comp(0) <> "" Then
Selection.AutoFilter field:=5, Criteria1:=comp, Operator:=xlFilterValues
End If

Range(Cells(1, 1), Cells(mr, 1)).Select
Selection.Copy
ThisWorkbook.Activate
Sheets("累積H").Cells(1, 1).PasteSpecial
Workbooks(name).Activate
Range(Cells(1, 2), Cells(mr, 2)).Select
Selection.Copy
ThisWorkbook.Activate
Sheets("累積H").Cells(1, 2).PasteSpecial
Workbooks(name).Close
Else
MsgBox "終了します"
End If

Else
MsgBox "終了します"

End If


End Sub

Sub hazard()

Dim n As Double

ThisWorkbook.Sheets("WPP").Activate
Sheets("WPP").AutoFilterMode = False
Sheets("WPP").Range("A:B").Clear
ThisWorkbook.Sheets("累積H").Activate
n = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("累積H").Range(Cells(1, 1), Cells(n, 2)).Sort Key1:=Sheets("累積H").Cells(1, 1), order1:=xlAscending, Header:=xlYes
Cells(1, 3) = Cells(1, 1)
Cells(1, 4) = Cells(1, 2)
Range("C2").Resize(n - 1).Formula = "=A2/1000"
Range("D2").Resize(n - 1).Formula = "=if(B2=""生存"",0,1)"
Cells(1, 5) = "h(t)"
Range("E2").Resize(n - 1).Formula = "=1/(1+" & n & "-row())"
Cells(1, 6) = "H(t)"
Range("F2").Formula = "=D2*E2"
Range("F3").Resize(n - 2).Formula = "=D3*E3+F2"
Cells(1, 7) = "寿命(k)"
Cells(1, 8) = "F(t)"
Range("G2").Resize(n - 1).Formula = "=C2"
Range("H2").Resize(n - 1).Formula = "=1-Exp(-F2)"
Range("A1").AutoFilter field:=4, Criteria1:="1"
Range(Cells(1, 7), Cells(n, 8)).Select
Selection.Copy
Sheets("WPP").Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False



End Sub

Sub wpp()

Dim buf As Variant
Dim n As Double
Dim m As Double

Sheets("WPP").Select
n = Sheets("WPP").Cells(Rows.Count, 1).End(xlUp).Row
m = Sheets("WPP").Cells(Rows.Count, 12).End(xlUp).Row
Range(Cells(2, 12), Cells(m, 24)).Clear
Range("L2").Resize(n - 1) = "=LN(A2)"
Range("M2").Resize(n - 1) = "=LN(-1*LN(1-B2))"
Range("P2").Resize(n - 1) = "=L2"
Range("Q2").Resize(n - 1) = "=IF(AND($D$4>P2),M2,NA())"
Range("R2").Resize(n - 1) = "=IF(AND($D$4P2),M2,NA())"
Range("S2").Resize(n - 1) = "=IF(AND($E$4P2),M2,NA())"

Sheets("偶発探査").Select
ThisWorkbook.RefreshAll

buf = Application.InputBox(Prompt:="偶発期の下限値を入力してください", Type:=1)
If buf Then
Sheets("WPP").Cells(2, 4) = buf
End If
buf = Application.InputBox(Prompt:="偶発期の上限値を入力してください", Type:=1)
If buf Then
Sheets("WPP").Cells(2, 5) = buf
End If
buf = Application.InputBox(Prompt:="摩耗期Ⅰの上限値を入力してください", Type:=1)
If buf Then
Sheets("WPP").Cells(2, 6) = buf
End If

guhatu.Show


MsgBox okng

Continue:

Sheets("WPP").Select

End Sub

ユーザーフォーム


Private Sub Bt_d_clear_Click()
With Sheets("WPP")
Sheets("WPP").Cells(3, 4) = 0
End With

End Sub

Private Sub Bt_d_down_Click()
With Sheets("WPP")
Sheets("WPP").Cells(3, 4) = Sheets("WPP").Cells(3, 4) - Me.text微調整.Text
End With
End Sub

Private Sub Bt_d_up_Click()
With Sheets("WPP")
Sheets("WPP").Cells(3, 4) = Sheets("WPP").Cells(3, 4) + Me.text微調整.Text
End With

End Sub

Private Sub Bt_down_Click()
With Sheets("WPP")
Sheets("WPP").Cells(2, 4) = Me.text偶発下限.Text
End With

End Sub

Private Sub Bt_end_Click()
End
End Sub

Private Sub Bt_OK_Click()
Unload Me
End Sub

Private Sub Bt_u_down_Click()
With Sheets("WPP")
Sheets("WPP").Cells(3, 5) = Sheets("WPP").Cells(3, 5) - Me.text微調整2.Text
End With
End Sub

Private Sub Bt_u_up_Click()
With Sheets("WPP")
Sheets("WPP").Cells(3, 5) = Sheets("WPP").Cells(3, 5) + Me.text微調整2.Text
End With

End Sub

Private Sub Bt_up_Click()
With Sheets("WPP")
Sheets("WPP").Cells(2, 5) = Me.text偶発上限.Text
End With

End Sub



Private Sub Btma1_Click()
With Sheets("WPP")
Sheets("WPP").Cells(2, 6) = Me.textma1.Text
End With

End Sub

Private Sub Btmaclear_Click()
With Sheets("WPP")
Sheets("WPP").Cells(3, 6) = 0

End With

End Sub

Private Sub Btmadown_Click()
With Sheets("WPP")
Sheets("WPP").Cells(3, 6) = Sheets("WPP").Cells(3, 6) - Me.Textmabityou.Text

End With
End Sub

Private Sub Btmaup_Click()
With Sheets("WPP")
Sheets("WPP").Cells(3, 6) = Sheets("WPP").Cells(3, 6) + Me.Textmabityou.Text

End With


End Sub

Private Sub Label1_Click()

End Sub

Private Sub Label11_Click()

End Sub

Private Sub OptionButton1_Click()
Sheets("偶発探査").Select
End Sub

Private Sub OptionButton2_Click()
Sheets("設定値").Select
End Sub



Private Sub OptionButton3_Click()

ActiveChart.SeriesCollection(3).Trendlines(1).Format.Line.Visible = msoTrue
ActiveChart.SeriesCollection(4).Trendlines(1).Format.Line.Visible = msoFalse

End Sub

Private Sub OptionButton4_Click()
ActiveChart.SeriesCollection(4).Trendlines(1).Format.Line.Visible = msoTrue
ActiveChart.SeriesCollection(3).Trendlines(1).Format.Line.Visible = msoFalse

End Sub

Private Sub OptionButton5_Click()
ActiveChart.SeriesCollection(4).Trendlines(1).Format.Line.Visible = msoTrue
ActiveChart.SeriesCollection(3).Trendlines(1).Format.Line.Visible = msoTrue
End Sub

Private Sub OptionButton6_Click()
ActiveChart.SeriesCollection(4).Trendlines(1).Format.Line.Visible = msoFalse
ActiveChart.SeriesCollection(3).Trendlines(1).Format.Line.Visible = msoFalse

End Sub

Private Sub UserForm_Initialize()

With Sheets("WPP")
Me.text偶発下限.Text = .Cells(2, 4)
Me.text微調整.Text = .Cells(3, 4)
Me.text偶発上限.Text = .Cells(2, 5)
Me.text微調整2.Text = .Cells(3, 5)
Me.textma1.Text = .Cells(2, 6)
Me.Textmabityou.Text = .Cells(3, 6)
End With

End Sub


画像

累積H
WPP.png
WPP2NG.png
ユーザーホーム
偶発探査
設定値
設定
↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ ↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑

エクセル マクロ バッチ

VBS

Dim excelApp : Set excelApp = CreateObject("Excel.Application")
' Excelを非表示にする
excelApp.Visible = TURE

Dim targetFile : targetFile = WScript.Arguments(0)
Dim targetMacro : targetMacro = WScript.Arguments(1)
' Excelファイルを開く
excelApp.Workbooks.Open targetFile
' マクロの実行
excelApp.Run targetMacro


バッチ
cscript aut.vbs C:\Users\papas\Documents\aut.xlsm 実行
↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ ↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑

PPT操作


Sub 実行()

Application.ScreenUpdating = False

If Cells(3, 2) <> "" Then

Call 読み込み '指定フォルダの指定ファイルを読み込み

Else

Call 読み込み2 '指定フォルダのファイルを読み込み

End If

Call コピーペースト 'csvファイルを読み込み
Call 並び替え 'コピー&ペースト&並び替え
Call ppt 'パワーポイント貼り付け

Application.ScreenUpdating = True

End Sub

Sub 読み込み()

Dim buf As String
Dim tmp() As String
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim y As Integer
Dim n As Integer
Dim dir As String
Dim fname As String
Dim sname As String


sname = Sheets("設定").Cells(4, 2)
dir = Sheets("設定").Cells(2, 2) '1列,11行のセルを読み込み
fname = Sheets("設定").Cells(3, 2) '2列,11行のセルを読み込み
x = Sheets("設定").Cells(5, 2) '3列,11行のセルを読み込み
y = Sheets("設定").Cells(6, 2) '4列,11行のセルを読み込み
j = 0
fname = dir & "\" & fname

Open fname For Input As #1
Do Until EOF(1)
Line Input #1, buf
tmp = Split(buf, ",")
For i = LBound(tmp) To UBound(tmp)
Sheets(sname).Cells(x + j, y + i) = tmp(i)
Next i
j = j + 1
Loop
Close #1


End Sub

Sub コピーペースト()

Dim sname As String
Dim cposi As String
Dim pposi As String

pposi = Sheets("設定").Cells(11, 2)
cposi = Sheets("設定").Cells(10, 2)
sname = Sheets("設定").Cells(9, 2)
Sheets(sname).Select
Sheets(sname).Range(cposi).CurrentRegion.Select
Selection.Copy
Sheets(sname).Range(pposi).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

End Sub

Sub 並び替え()

Dim sname As String
Dim sposi As String
Dim pposi As String

pposi = Sheets("設定").Cells(11, 2)
sname = Sheets("設定").Cells(9, 2)
sposi = Sheets("設定").Cells(12, 2)

Sheets(sname).Select
Sheets(sname).Range(pposi).CurrentRegion.Sort _
Key1:=Sheets(sname).Range(sposi), _
order1:=xlDescending, _
Header:=xlYes

End Sub


Sub 読み込み2()

Dim buf As String
Dim tmp() As String
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim y As Integer
Dim n As Integer
Dim adress As String
Dim fname As String
Dim sname As String


sname = Sheets("設定").Cells(4, 2)
adress = Sheets("設定").Cells(2, 2)
fname = dir(adress & "\*.*", vbNormal)
x = Sheets("設定").Cells(5, 2)
y = Sheets("設定").Cells(6, 2)
j = 0
fname = adress & "\" & fname

Open fname For Input As #1
Do Until EOF(1)
Line Input #1, buf
tmp = Split(buf, ",")
For i = LBound(tmp) To UBound(tmp)
Sheets(sname).Cells(x + j, y + i) = tmp(i)
Next i
j = j + 1
Loop
Close #1


End Sub

Sub ppt()

Dim pp As Object
Dim ppfile As Object
Dim ppsld As Object
Dim adress As String
Dim dirfname As String
Dim fname As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim sname As String
Dim gname As String
Dim page As Integer
Dim x As Double
Dim y As Double
Dim w As Double
Dim h As Double
Dim ChaNo As Integer



j = Sheets("設定").Cells(16, 2)
adress = Sheets("設定").Cells(15, 2)
fname = dir(adress & "\*.*", vbNormal)
dirfname = adress & "\" & fname

Set pp = CreateObject("PowerPoint.Application")
Set ppfile = pp.Presentations.Open(Filename:=dirfname)

For i = 0 To j - 1
sname = Sheets("設定").Cells(18 + i, 1)
gname = Sheets("設定").Cells(18 + i, 2)
page = Sheets("設定").Cells(18 + i, 7)
y = Sheets("設定").Cells(18 + i, 3)
x = Sheets("設定").Cells(18 + i, 4)
w = Sheets("設定").Cells(18 + i, 5)
h = Sheets("設定").Cells(18 + i, 6)
ChaNo = Sheets("設定").Cells(18 + i, 8)

ThisWorkbook.Activate
Sheets(sname).ChartObjects(gname).Activate
ActiveChart.ChartArea.Select
' ActiveChart.ChartArea.Copy 'グラフをコピー
ActiveChart.CopyPicture Appearance:=xlScreen, _
Size:=xlScreen, Format:=xlPicture '図としてコピー

Set ppsld = ppfile.slides(page)
ppsld.Shapes.Paste
With ppsld.Shapes(ChaNo)
' .LockAspectRatio = msoTrue '縦横比固定
.Top = y '上からの位置
.Left = x '左からの位置
.Width = w '画像の幅
.Height = h '画像の高さ
' .ZOrder msoSendToBack '一番奥の位置へ
End With
Application.CutCopyMode = False
Next i


End Sub





キャプチャ

↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ ↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑
プロフィール

abc

Author:abc
このブログの内容に真実はありません。

最新記事
最新コメント
月別アーカイブ
カテゴリ
検索フォーム
RSSリンクの表示
リンク
ブロとも申請フォーム

この人とブロともになる

QRコード
QR