Option Explicit
Const Folder As String = "D:\goo\data9"
Public Sub 測定結果設定()
Dim fname As String
Dim fcount As Long: fcount = 0
Dim ms As Worksheet
Dim mscol As Long '差分値距離列番号(統合)
Dim mjcol As Long '実測値列番号(統合)
Dim tscol As Long '差分値距離列番号(CSV)
Dim tjcol As Long '実測値列番号(CSV)
Dim msrow As Long '差分値距離行番号(統合)
Dim mjrow As Long '実測値行番号(統合)
Dim tsrow As Long '差分値距離行番号(CSV)
Dim tjrow As Long '実測値行番号(CSV)
Dim fno As Long 'CSVファイル番号
Dim bno As Long 'CSVファイル内ブロック番号
Dim t1 As Double
Dim t2 As Double
t1 = Timer
Application.ScreenUpdating = False
Set ms = Worksheets("測定結果")
'前回使用領域のクリア
ms.Cells.ClearContents
ms.Cells.Font.Color = RGB(0, 0, 0)
ms.Cells(1, "A").Value = "取得ファイル名"
ms.Cells(3, "A").Value = "コメント"
fname = Dir(Folder & "\" & "LS?.??_L0?.csv")
Do While fname <> ""
fcount = fcount + 1
'実測値距離、差分値距離設定(横複数列に設定)
Call set_data(ms, fcount, fname)
fname = Dir
Loop
If fcount = 0 Then
MsgBox ("該当ファイルなし")
Exit Sub
End If
'差分値距離、実測値距離設定(縦1列に設定)
mscol = fcount * 2 + 3
mjcol = mscol + 1
ms.Cells(3, mscol).Value = "差分値距離"
ms.Cells(3, mjcol).Value = "実測値距離"
For fno = 1 To fcount
tscol = fno * 2 + 1
tjcol = fno * 2
For bno = 1 To 3
tjrow = (bno - 1) * 8 + 4
tsrow = tjrow + 4
msrow = (fno - 1) * 12 + (bno - 1) * 4 + 4
mjrow = msrow
'差分値設定
ms.Cells(tsrow, tscol).Resize(4, 1).Font.Color = RGB(255, 0, 0) '赤
ms.Cells(msrow, mscol).Resize(4, 1).Value = ms.Cells(tsrow, tscol).Resize(4, 1).Value
'実測値設定
ms.Cells(tjrow, tjcol).Resize(4, 1).Font.Color = RGB(0, 0, 255) '青
ms.Cells(mjrow, mjcol).Resize(4, 1).Value = ms.Cells(tjrow, tjcol).Resize(4, 1).Value
Next
Next
ms.Columns(mscol).Font.Color = RGB(255, 0, 0) '赤
ms.Columns(mjcol).Font.Color = RGB(0, 0, 255) '青
Application.ScreenUpdating = True
t2 = Timer
MsgBox ("完了 所要時間=" & t2 - t1 & "秒")
End Sub
Private Sub set_data(ByRef ms As Worksheet, ByVal fcount As Long, ByVal fname As String)
'CSVファイルをオープン
Dim csvpath As String 'CSVファイルパス
Dim wb As Workbook 'CSVファイルブック
Dim ws As Worksheet 'CSVファイルシート
Dim mcol As Long '測定結果設定列番号
csvpath = Folder & "\" & fname
Workbooks.OpenText Filename:=csvpath, DataType:=xlDelimited, comma:=True, textqualifier:=xlTextQualifierNone
Set wb = Workbooks.Item(Workbooks.count)
Set ws = wb.Worksheets(1)
'コメント設定
If fcount = 1 Then
ms.Range("A4:A27").Value = ws.Range("B9:B32").Value
End If
mcol = fcount * 2
'ファイル名設定
Dim bname As String
bname = Left(fname, Len(fname) - 4)
ms.Cells(1, mcol).Value = bname
'実測値距離
ms.Cells(3, mcol).Value = "実測値距離"
ms.Range(ms.Cells(4, mcol), ms.Cells(27, mcol)).Value = ws.Range("D9:D32").Value
'差分値距離
ms.Cells(3, mcol + 1).Value = "差分値距離"
ms.Range(ms.Cells(4, mcol + 1), ms.Cells(27, mcol + 1)).Value = ws.Range("E9:E32").Value
'CSVファイルクローズ
wb.Close
End Sub
T3B0aW9uIEV4cGxpY2l0CgpDb25zdCBGb2xkZXIgQXMgU3RyaW5nID0gIkQ6XGdvb1xkYXRhOSIKUHVibGljIFN1YiDmuKzlrprntZDmnpzoqK3lrpooKQogICAgRGltIGZuYW1lIEFzIFN0cmluZwogICAgRGltIGZjb3VudCBBcyBMb25nOiBmY291bnQgPSAwCiAgICBEaW0gbXMgQXMgV29ya3NoZWV0CiAgICBEaW0gbXNjb2wgQXMgTG9uZyAgICAgICAgICAgJ+W3ruWIhuWApOi3nembouWIl+eVquWPtyjntbHlkIgpCiAgICBEaW0gbWpjb2wgQXMgTG9uZyAgICAgICAgICAgJ+Wun+a4rOWApOWIl+eVquWPtyjntbHlkIgpCiAgICBEaW0gdHNjb2wgQXMgTG9uZyAgICAgICAgICAgJ+W3ruWIhuWApOi3nembouWIl+eVquWPtyhDU1YpCiAgICBEaW0gdGpjb2wgQXMgTG9uZyAgICAgICAgICAgJ+Wun+a4rOWApOWIl+eVquWPtyhDU1YpCiAgICBEaW0gbXNyb3cgQXMgTG9uZyAgICAgICAgICAgJ+W3ruWIhuWApOi3nembouihjOeVquWPtyjntbHlkIgpCiAgICBEaW0gbWpyb3cgQXMgTG9uZyAgICAgICAgICAgJ+Wun+a4rOWApOihjOeVquWPtyjntbHlkIgpCiAgICBEaW0gdHNyb3cgQXMgTG9uZyAgICAgICAgICAgJ+W3ruWIhuWApOi3nembouihjOeVquWPtyhDU1YpCiAgICBEaW0gdGpyb3cgQXMgTG9uZyAgICAgICAgICAgJ+Wun+a4rOWApOihjOeVquWPtyhDU1YpCiAgICBEaW0gZm5vIEFzIExvbmcgICAgICAgICAgICAgJ0NTVuODleOCoeOCpOODq+eVquWPtwogICAgRGltIGJubyBBcyBMb25nICAgICAgICAgICAgICdDU1bjg5XjgqHjgqTjg6vlhoXjg5bjg63jg4Pjgq/nlarlj7cKICAgIERpbSB0MSBBcyBEb3VibGUKICAgIERpbSB0MiBBcyBEb3VibGUKICAgIHQxID0gVGltZXIKICAgIEFwcGxpY2F0aW9uLlNjcmVlblVwZGF0aW5nID0gRmFsc2UKICAgIFNldCBtcyA9IFdvcmtzaGVldHMoIua4rOWumue1kOaenCIpCiAgICAn5YmN5Zue5L2/55So6aCY5Z+f44Gu44Kv44Oq44KiCiAgICBtcy5DZWxscy5DbGVhckNvbnRlbnRzCiAgICBtcy5DZWxscy5Gb250LkNvbG9yID0gUkdCKDAsIDAsIDApCiAgICBtcy5DZWxscygxLCAiQSIpLlZhbHVlID0gIuWPluW+l+ODleOCoeOCpOODq+WQjSIKICAgIG1zLkNlbGxzKDMsICJBIikuVmFsdWUgPSAi44Kz44Oh44Oz44OIIgogICAgZm5hbWUgPSBEaXIoRm9sZGVyICYgIlwiICYgIkxTPy4/P19MMD8uY3N2IikKICAgIERvIFdoaWxlIGZuYW1lIDw+ICIiCiAgICAgICAgZmNvdW50ID0gZmNvdW50ICsgMQogICAgICAgICflrp/muKzlgKTot53pm6LjgIHlt67liIblgKTot53pm6LoqK3lrprvvIjmqKropIfmlbDliJfjgavoqK3lrprvvIkKICAgICAgICBDYWxsIHNldF9kYXRhKG1zLCBmY291bnQsIGZuYW1lKQogICAgICAgIGZuYW1lID0gRGlyCiAgICBMb29wCiAgICBJZiBmY291bnQgPSAwIFRoZW4KICAgICAgICBNc2dCb3ggKCLoqbLlvZPjg5XjgqHjgqTjg6vjgarjgZciKQogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgICflt67liIblgKTot53pm6LjgIHlrp/muKzlgKTot53pm6LoqK3lrprvvIjnuKYx5YiX44Gr6Kit5a6a77yJCiAgICBtc2NvbCA9IGZjb3VudCAqIDIgKyAzCiAgICBtamNvbCA9IG1zY29sICsgMQogICAgbXMuQ2VsbHMoMywgbXNjb2wpLlZhbHVlID0gIuW3ruWIhuWApOi3nemboiIKICAgIG1zLkNlbGxzKDMsIG1qY29sKS5WYWx1ZSA9ICLlrp/muKzlgKTot53pm6IiCiAgICBGb3IgZm5vID0gMSBUbyBmY291bnQKICAgICAgICB0c2NvbCA9IGZubyAqIDIgKyAxCiAgICAgICAgdGpjb2wgPSBmbm8gKiAyCiAgICAgICAgRm9yIGJubyA9IDEgVG8gMwogICAgICAgICAgICB0anJvdyA9IChibm8gLSAxKSAqIDggKyA0CiAgICAgICAgICAgIHRzcm93ID0gdGpyb3cgKyA0CiAgICAgICAgICAgIG1zcm93ID0gKGZubyAtIDEpICogMTIgKyAoYm5vIC0gMSkgKiA0ICsgNAogICAgICAgICAgICBtanJvdyA9IG1zcm93CiAgICAgICAgICAgICflt67liIblgKToqK3lrpoKICAgICAgICAgICAgbXMuQ2VsbHModHNyb3csIHRzY29sKS5SZXNpemUoNCwgMSkuRm9udC5Db2xvciA9IFJHQigyNTUsIDAsIDApICfotaQKICAgICAgICAgICAgbXMuQ2VsbHMobXNyb3csIG1zY29sKS5SZXNpemUoNCwgMSkuVmFsdWUgPSBtcy5DZWxscyh0c3JvdywgdHNjb2wpLlJlc2l6ZSg0LCAxKS5WYWx1ZQogICAgICAgICAgICAn5a6f5ris5YCk6Kit5a6aCiAgICAgICAgICAgIG1zLkNlbGxzKHRqcm93LCB0amNvbCkuUmVzaXplKDQsIDEpLkZvbnQuQ29sb3IgPSBSR0IoMCwgMCwgMjU1KSAn6Z2SCiAgICAgICAgICAgIG1zLkNlbGxzKG1qcm93LCBtamNvbCkuUmVzaXplKDQsIDEpLlZhbHVlID0gbXMuQ2VsbHModGpyb3csIHRqY29sKS5SZXNpemUoNCwgMSkuVmFsdWUKICAgICAgICBOZXh0CiAgICBOZXh0CiAgICBtcy5Db2x1bW5zKG1zY29sKS5Gb250LkNvbG9yID0gUkdCKDI1NSwgMCwgMCkgICAn6LWkCiAgICBtcy5Db2x1bW5zKG1qY29sKS5Gb250LkNvbG9yID0gUkdCKDAsIDAsIDI1NSkgICAn6Z2SCiAgICBBcHBsaWNhdGlvbi5TY3JlZW5VcGRhdGluZyA9IFRydWUKICAgIHQyID0gVGltZXIKICAgIE1zZ0JveCAoIuWujOS6hiDmiYDopoHmmYLplpM9IiAmIHQyIC0gdDEgJiAi56eSIikKRW5kIFN1YgoKUHJpdmF0ZSBTdWIgc2V0X2RhdGEoQnlSZWYgbXMgQXMgV29ya3NoZWV0LCBCeVZhbCBmY291bnQgQXMgTG9uZywgQnlWYWwgZm5hbWUgQXMgU3RyaW5nKQogICAgJ0NTVuODleOCoeOCpOODq+OCkuOCquODvOODl+ODswogICAgRGltIGNzdnBhdGggQXMgU3RyaW5nICAgJ0NTVuODleOCoeOCpOODq+ODkeOCuQogICAgRGltIHdiIEFzIFdvcmtib29rICAgICAgJ0NTVuODleOCoeOCpOODq+ODluODg+OCrwogICAgRGltIHdzIEFzIFdvcmtzaGVldCAgICAgJ0NTVuODleOCoeOCpOODq+OCt+ODvOODiAogICAgRGltIG1jb2wgQXMgTG9uZyAgICAgICAgJ+a4rOWumue1kOaenOioreWumuWIl+eVquWPtwogICAgY3N2cGF0aCA9IEZvbGRlciAmICJcIiAmIGZuYW1lCiAgICBXb3JrYm9va3MuT3BlblRleHQgRmlsZW5hbWU6PWNzdnBhdGgsIERhdGFUeXBlOj14bERlbGltaXRlZCwgY29tbWE6PVRydWUsIHRleHRxdWFsaWZpZXI6PXhsVGV4dFF1YWxpZmllck5vbmUKICAgIFNldCB3YiA9IFdvcmtib29rcy5JdGVtKFdvcmtib29rcy5jb3VudCkKICAgIFNldCB3cyA9IHdiLldvcmtzaGVldHMoMSkKICAgICfjgrPjg6Hjg7Pjg4joqK3lrpoKICAgIElmIGZjb3VudCA9IDEgVGhlbgogICAgICAgIG1zLlJhbmdlKCJBNDpBMjciKS5WYWx1ZSA9IHdzLlJhbmdlKCJCOTpCMzIiKS5WYWx1ZQogICAgRW5kIElmCiAgICBtY29sID0gZmNvdW50ICogMgogICAgJ+ODleOCoeOCpOODq+WQjeioreWumgogICAgRGltIGJuYW1lIEFzIFN0cmluZwogICAgYm5hbWUgPSBMZWZ0KGZuYW1lLCBMZW4oZm5hbWUpIC0gNCkKICAgIG1zLkNlbGxzKDEsIG1jb2wpLlZhbHVlID0gYm5hbWUKICAgICflrp/muKzlgKTot53pm6IKICAgIG1zLkNlbGxzKDMsIG1jb2wpLlZhbHVlID0gIuWun+a4rOWApOi3nemboiIKICAgIG1zLlJhbmdlKG1zLkNlbGxzKDQsIG1jb2wpLCBtcy5DZWxscygyNywgbWNvbCkpLlZhbHVlID0gd3MuUmFuZ2UoIkQ5OkQzMiIpLlZhbHVlCiAgICAn5beu5YiG5YCk6Led6ZuiCiAgICBtcy5DZWxscygzLCBtY29sICsgMSkuVmFsdWUgPSAi5beu5YiG5YCk6Led6ZuiIgogICAgbXMuUmFuZ2UobXMuQ2VsbHMoNCwgbWNvbCArIDEpLCBtcy5DZWxscygyNywgbWNvbCArIDEpKS5WYWx1ZSA9IHdzLlJhbmdlKCJFOTpFMzIiKS5WYWx1ZQogICAgJ0NTVuODleOCoeOCpOODq+OCr+ODreODvOOCugogICAgd2IuQ2xvc2UKRW5kIFN1Ygo=