|
|
|
2017.11.19
カテゴリ：お勉強
Option Explicit Private Declare Function timeGetTime Lib "winmm.dll" () As Long #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long) #End If Public booksDB As Workbook Public filename1, filename2 As String Sub test1() Dim i_time As Long i_time = timeGetTime() Call makeDirectory booksDB.Worksheets("Sheet2").Activate Call input1_office Workbooks(filename2 & ".xlsx").Save Workbooks(filename2 & ".xlsx").Close MsgBox Format$(timeGetTime - i_time) & " ミリ秒" End Sub Sub test2() Dim i_time As Long i_time = timeGetTime() Call makeDirectory booksDB.Worksheets("Sheet2").Activate Call collation1_office Workbooks(filename2 & ".xlsx").Close MsgBox Format$(timeGetTime - i_time) & " ミリ秒" End Sub Sub collation1_office() 'J列に新たな判定を入れる そこがfalseだったら橙色にでもする Dim codeASKoffice, namestaoffice As String Dim i As Long Dim flgcola As String flgcola = "" booksDB.Worksheets("Sheet2").Activate codeASKoffice = Mid(Range("B7"), 1, 5) If Range("F8") = "" Then namestaoffice = Range("F7") Else namestaoffice = Range("F8") End If Workbooks(filename2 & ".xlsx").Activate Worksheets("事業所名").Activate For i = 4 To Cells(Rows.Count, 2).End(xlUp).Row If Cells(i, 2) = codeASKoffice _ And Cells(i, 4) = namestaoffice Then flgcola = Cells(i, 5) Exit For End If Next booksDB.Worksheets("Sheet2").Activate If flgcola = "" Then Range("J7") = "該当なし" Else Range("J7") = flgcola End If End Sub Sub input1_office() '事業所名は修正しないので修正前のみ If Range("I7") = False Then 'I7に最初の判定が入っているとしたら Dim db_office(3) As String '仮にASK事業所のセルがB7、e-staはF7、F8とする db_office(0) = Mid(Range("B7"), 1, 5) 'コード db_office(1) = Mid(Range("B7"), 7) 'ASk名称 db_office(2) = Range("F7") 'e-sta正式名称 db_office(3) = Range("F8") 'e-sta右の単位 Debug.Print db_office(3) 'アクティブにするかオープンにするか、開いた直後に入れればOKか '判定入れる If Range("H7") = True And Range("I7") = False Then Workbooks(filename2 & ".xlsx").Activate Worksheets("事業所名").Activate With Cells(Rows.Count, 2).End(xlUp) .Offset(1, 0) = db_office(0) .Offset(1, 1) = db_office(1) If db_office(3) = "" Then .Offset(1, 2) = db_office(2) Else .Offset(1, 2) = db_office(3) End If .Offset(1, 3) = "True" End With Else If Range("H7") <> True And Range("I7") = False Then Workbooks(filename2 & ".xlsx").Activate Worksheets("事業所名").Activate With Cells(Rows.Count, 2).End(xlUp) .Offset(1, 0) = db_office(0) .Offset(1, 1) = db_office(1) If db_office(3) = "" Then .Offset(1, 2) = db_office(2) Else .Offset(1, 2) = db_office(3) End If .Offset(1, 3) = "False" End With End If End If End If End Sub Sub input2_office() Dim db_office(3) As String Dim est1, est2 As Long est1 = InStr(ActiveCell, "e-sta:事業所名") est2 = InStr(ActiveCell, "e-sta:右の単位") db_office(0) = Mid(ActiveCell, 5, 6) db_office(1) = Mid(ActiveCell, 11, est1 - 12) db_office(2) = Mid(ActiveCell, est1 + 11, est2 - est1 - 12) db_office(3) = Mid(ActiveCell, est2 + 11, Len(ActiveCell) - est2) Debug.Print db_office(3) 'アクティブにするかオープンにするか、開いた直後に入れればOKか Workbooks(filename2 & ".xlsx").Activate Worksheets("事業所名").Activate With Cells(Rows.Count, 2).End(xlUp) .Offset(1, 0) = db_office(0) .Offset(1, 1) = db_office(1) If db_office(3) = "" Then .Offset(1, 2) = db_office(2) Else .Offset(1, 2) = db_office(3) End If End With End Sub Sub makeDirectory() Set booksDB = Workbooks("DateBase化.xlsm") filename2 = booksDB.Worksheets("Sheet1").Cells(5, 2) Dim x As Long 'MsgBox ThisWorkbook.Application.CheckSpelling(Cells(3, 2)) Debug.Print ThisWorkbook.Path x = 5 'Dir (ThisWorkbook.Path) 'For x = 5 To 40 booksDB.Worksheets("Sheet1").Activate 'Cells(5, 2)にCLコードがあるとしたら Dim foldername1 As String foldername1 = ThisWorkbook.Path & "\" & Left(Cells(x, 2), 4) Debug.Print foldername1 Dim wbook As Workbook 'MsgBox Dir(ThisWorkbook.Path & "\" & foldername1, vbDirectory) If Dir(foldername1, vbDirectory) = "" Then MkDir (foldername1) End If filename1 = foldername1 & "\" & booksDB.Worksheets("Sheet1").Cells(x, 2) & ".xlsx" Dim newbk As String newbk = ActiveWorkbook.Name Debug.Print newbk If Dir(filename1) = "" Then Workbooks.Add '作成したブックはアクティブ！ newbk = ActiveWorkbook.Name 'ここにテンプレ作るサブルーチン入れる Call temp1 Workbooks(newbk).SaveAs _ filename:=filename1 'ここからCLコードファイルはfilename1という名前になる Else For Each wbook In Workbooks 'Debug.Print wbook.Name If wbook.Name = filename2 Then wbook.Activate Exit For End If Next wbook Sleep 1 If ActiveWorkbook.Name <> filename2 Then Workbooks.Open filename:=filename1 End If End If Debug.Print booksDB.Worksheets("Sheet1").Cells(x, 2) & ".xlsx" Debug.Print filename1 With Workbooks(booksDB.Worksheets("Sheet1").Cells(x, 2) & ".xlsx") booksDB.Worksheets("Sheet1").Cells(x, 3).Value = .BuiltinDocumentProperties("Last save time").Value End With 'Next End Sub Sub temp1() Application.ScreenUpdating = False With Worksheets.Add() .Name = "事業所名" .Cells(3, 2) = "事業所コード" .Cells(3, 3) = "ASK名称" .Cells(3, 4) = "e-sta名称･単位" .Cells(3, 5) = "判定" End With With Worksheets.Add(after:=Worksheets("事業所名")) .Name = "部課名" .Cells(3, 2) = "部課コード" .Cells(3, 3) = "ASK正式名称" .Cells(3, 4) = "e-sta略称 " .Cells(3, 5) = "e-sta正式名称" .Cells(3, 6) = "判定" .Cells(3, 7) = "修正コード" .Cells(3, 8) = "修正名称" End With With Worksheets.Add(after:=Worksheets("部課名")) .Name = "担当者名" .Cells(3, 2) = "担当者コード" .Cells(3, 3) = "ASK氏名" .Cells(3, 4) = "e-sta氏名" .Cells(3, 5) = "判定" .Cells(3, 6) = "修正コード" .Cells(3, 7) = "修正名称" End With Dim ws As Worksheet, flag As Boolean For Each ws In Worksheets If ws.Name = "合計" Then flag = True Next ws If flag = True Then Application.DisplayAlerts = False Worksheets("Sheet1").Delete Application.DisplayAlerts = True End If Application.ScreenUpdating = True End Sub
お気に入りの記事を「いいね！」で応援しよう
Last updated
2017.11.19 23:28:19
コメント(0) | コメントを書く
[お勉強] カテゴリの最新記事
|
