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