MakeList
Sub MakeList()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long, n As Long
Dim v1 As Double, v2 As Double
Dim m1 As Double, m2 As Double
Dim flg As Long, wb As Workbook
Dim flg2 As Long
Dim 閾値 As Double, 違う閾値も計算する As Long
For Each wb In Workbooks
Call GetExcelDataWorkBook(ws1, ws2, wb, flg)
'MsgBox flg
If flg = 2 Then Exit For
Next wb
'ws1 :amc ___ :: Data Sheet
'ws2 :list :: list Sheet
ThisWorkbook.Worksheets("Main").Activate
Application.Goto ThisWorkbook.Worksheets("Main").Range("A10"), True
ThisWorkbook.Worksheets("Main").Range("A10").Value = wb.Name
ThisWorkbook.Worksheets("Main").Range("A11").Value = ws1.Name
ThisWorkbook.Worksheets("Main").Range("A12").Value = ws2.Name
If flg = -1 Then
MsgBox wb.Name
MsgBox ws1.Name
MsgBox ws2.Name
End If
If flg < 2 Then Exit Sub
ws2.Activate
'Set ws1 = Workbooks("20190728-AMC02.xlsx").Worksheets("amc20190728_83")
'Set ws2 = Workbooks("20190728-AMC02.xlsx").Worksheets("list_83")
ws2.Cells.Clear
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
i = 10
n = ws1.Cells(i, 1).End(xlDown).Row
If n = Rows.Count Then
MsgBox "なにかおかしい、たぶん（" + ws1.Name + "）の A10が空白。確認してください。"
ws1.Cells(i, 1).Interior.Color = RGB(255, 0, 0)
flg = -100
Exit Sub
End If
flg2 = 1
If チェックボックスの確認("マイナス側のバイアスあり", ws1) = 1 Then flg2 = 2
If チェックボックスの確認("任意の閾値の設定", ws1) = 1 Then
Call 閾値読み込み(ws1, 閾値)
違う閾値も計算する = 0
If 閾値 > 0 And 閾値 < 1 Then 違う閾値も計算する = 1
End If
j = 1
Do
v1 = ws1.Cells(i, 1).Value
v2 = ws1.Cells(i + 1, 1).Value
If Abs(v1) <= 0.0001 And Abs(v2 - 1) <= 0.001 Then
ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 7)).Value = _
ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 7)).Value
ws2.Cells(j, 8).Value = i
Call IcAna(i, ws1, m1, m2)
ws2.Cells(j, 9).Value = m1
ws2.Cells(j, 10).Value = m2
Call IcTrap(i, ws1, m1, m2)
ws2.Cells(j, 11).Value = m1
ws2.Cells(j, 12).Value = m2
If flg2 = 2 Then
Call IcAnaMinus(i, ws1, m1, m2)
ws2.Cells(j, 13).Value = m1
ws2.Cells(j, 14).Value = m2
Call IcTrapMinus(i, ws1, m1, m2)
ws2.Cells(j, 15).Value = m1
ws2.Cells(j, 16).Value = m2
End If
j = j + 1
End If
i = i + 1
Loop While i <= n
ThisWorkbook.Worksheets("Main").Range("J1").Value = j - 1
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ThisWorkbook.Worksheets("Main").Activate
Application.Goto ThisWorkbook.Worksheets("Main").Range("A1"), True
End Sub