新着記事一覧 | LICEO STUDENTE

仕事忙しい

何かの競争みたく忙しい。学校の試験中のようなレベルで集中しないとならない。やり切った時の達成感はある。

2020.10.16

コメント(1)

日記の継続出来てないなぁ…

手帳には、振り返りをメモしているんですけどね。手書きしたものをこちらに入力するのが手間なのと、ブログだと体裁を整えようと意識してしまうので作業を始める心理的ハードルが上がってしまう。 →・手書きの内容を確認、まとめるつもりで入力する？・一先ずは、体裁は意識しない。習慣化を優先する。 …何のために日記付けようと思ったんだっけ？コストと釣り合ってる？

2020.10.04

コメント(0)

15時くらいに帰宅しようと思ってた

システムエラーの原因究明だったり、打ち合わせだったりで、家に帰ったのが23時だった。職場近くのホテルに宿泊するか悩んだ。明後日…明日は、数学塾の講義がある。何も勉強していない。受講料は80分、18000円ほど。もったいない。

2020.09.10

コメント(0)

統計検定中止

11月に控えていた統計検定一級の試験が中止になった。勉強出来ていなかったので、正直、助かった。しかし、社内評価のため、別の資格を取得しなければならない。来年、2月のE資格は受験することは確定しているのだが、他にも取得する必要がある。次は無理のない計画を立てるよう心掛けたい。

2020.09.04

コメント(0)

日記を書いてみようか

今年の11月下旬に私を待ち構えているものがある。統計検定の試験だ。自信はない。昨年末から意識していたが、学習に専念することはなかった。いつも目の前の仕事を優先してしまった。そちらの方が、気持ちも楽だった。忙しいことを勉強が出来ない大義名分のように使ってしまっていた。だが、「時間がない」なんて言い訳として通用しない。あぁ、眠い。

2020.09.03

コメント(0)

やることの整理と生活の見直し

とりあえず、整理のために書き出す。体裁等は後々整える。そのうち、何かしらの発信ができるようになりたい為、文章に書き起こす練習、ネタの備忘録として記す。やること○統計検定2級の勉強・期限：2020年1月11日・学習計画見直すところから○PHPのポートフォリオをサーバーにアップロード・急ぎで○タイムマネジメント・やばい！！！！！○HTMLの勉強・とりあえず、入門書をさっと目を通す。なるはやで！○タスクの優先順位・毎日コツコツやるもの・急ぎで完了させるもの○本屋に注文していたものを受け取りに行く・いつでも良いが、今日中に撮りに行った方が気が楽生活について○起床が遅い・光目覚ましを注文した・・・1月3日に到着予定・家族、友人複数人にモーニングコールのお願いをした○勉強以外に時間を浪費してしまっている・何をしているかセルフモニタリングする・タイムマネジメント○人間関係に関して、コストを掛けすぎている・時間がない。控える。○食事は、概ね良い・自炊して、お肉も野菜も食べている○運動不足・一旦、後回し？・何時にどのくらいやるか決めて、筋トレ再開する？○目の疲れ・眼精疲労用の目薬の購入を検討する○指、手首の疲れについて・質の高いキーボードを購入した・プログラミングと統計の勉強の時間の割合で疲労度合いを調整する○腰の痛みについて・サポーターを購入した。近日中（本日）に到着予定。・良い椅子を購入したい。手ごろな価格の物を探す今思いつくのはこのくらい---2020/1/2 18:14

2020.01.02

コメント(0)

webスクレイピング？練習

Sub abista11tr() Dim i_time As Long i_time = timeGetTime() Dim objIE As InternetExplorer Call ieView(objIE, "") Dim htmlDoc As HTMLDocument Set htmlDoc = objIE.document Dim colTR, colTH, colTD, ele As IHTMLElement Dim i As Long i = 1 Set colTR = htmlDoc.getElementsByTagName("tr") For Each ele In colTR Set colTH = ele.getElementsByTagName("th") Debug.Print colTH(0).innerText If colTH(0).innerText = "勤務地" Then Cells(i, 1) = colTH(0).innerText Set colTD = ele.getElementsByTagName("td") Cells(i, 2) = colTD(0).innerText 'Cells(i, 1) = ele.innerText i = i + 1 End If Next ele i = 1 Set colTR = htmlDoc.getElementsByTagName("tr") For Each ele In colTR Set colTH = ele.getElementsByTagName("th") Debug.Print colTH(0).innerText If colTH(0).innerText = "仕事内容" Then Cells(i, 3) = colTH(0).innerText Set colTD = ele.getElementsByTagName("td") Cells(i, 4) = colTD(0).innerText 'Cells(i, 1) = ele.innerText i = i + 1 End If Next ele i = 1 Set colTR = htmlDoc.getElementsByTagName("tr") For Each ele In colTR Set colTH = ele.getElementsByTagName("th") Debug.Print colTH(0).innerText If colTH(0).innerText = "雇用形態" Then Cells(i, 5) = colTH(0).innerText Set colTD = ele.getElementsByTagName("td") Cells(i, 6) = colTD(0).innerText 'Cells(i, 1) = ele.innerText i = i + 1 End If Next ele i = 1 Set colTR = htmlDoc.getElementsByTagName("tr") For Each ele In colTR Set colTH = ele.getElementsByTagName("th") Debug.Print colTH(0).innerText If colTH(0).innerText = "給与" Then Cells(i, 7) = colTH(0).innerText Set colTD = ele.getElementsByTagName("td") Cells(i, 8) = colTD(0).innerText 'Cells(i, 1) = ele. i = i + 1 End If Next ele i = 1 Set colTR = htmlDoc.getElementsByTagName("tr") For Each ele In colTR Set colTH = ele.getElementsByTagName("th") Debug.Print colTH(0).innerText If colTH(0).innerText = "勤務時間" Then Cells(i, 9) = colTH(0).innerText Set colTD = ele.getElementsByTagName("td") Cells(i, 10) = colTD(0).innerText 'Cells(i, 1) = ele.innerText i = i + 1 End If Next ele MsgBox Format$(timeGetTime - i_time) & " ミリ秒" End Sub

2017.11.19

コメント(1)

DB化構想20171119

Option ExplicitPrivate Declare Function timeGetTime Lib "winmm.dll" () As Long#If VBA7 ThenPrivate Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)#ElsePrivate Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)#End If Public booksDB As Workbook Public filename1, filename2 As StringSub 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 SubSub 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 SubSub 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 SubSub 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 SubSub 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 SubSub 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 SubSub 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

2017.11.19

コメント(0)

Mgr承認メモ　2017/11/19

前回から変わってないかもOption Explicit#If VBA7 ThenPrivate Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)#ElsePrivate Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)#End IfPublic allStr As String 'ダブりなし見比べ全文　2017/11/15追加'Public skpFlg As Boolean 'スキップしたらtrue　2017/11/15追加Public Uname As String 'ユーザーネーム　作業担当者の指名プログラム的に良くないようだ　2017/11/13追加Sub bookopen() Dim bookname As String bookname = Dir(ThisWorkbook.Path & "\操作対象ブックフォルダ\*") Debug.Print "ブックネーム=" & bookname Dim wbook As Workbook For Each wbook In Workbooks Debug.Print wbook.name If wbook.name = bookname Then wbook.Activate Exit For End If Next wbook Sleep 1 If ActiveWorkbook.name <> bookname Then Workbooks.Open Filename:=ThisWorkbook.Path & _ "\操作対象ブックフォルダ\" & bookname End IfEnd SubSub escaFlag() '2017/11/14追加'エスカフラグを立てる'その行に赤色に塗りつぶしてあるセルがあったら'フラグefがtrueになる Dim ei, ej, ef As Boolean For ei = 2 To Cells(Rows.Count, 2).End(xlUp).row ef = False For ej = 5 To Cells(1, Columns.Count).End(xlToLeft).Column If Cells(ei, ej).Interior.Color = 255 Then ef = True End If Next If ef = True Then Cells(ei, 4) = "有" 'Cells(ei,Y)でYはフラグを立てる行 Else Cells(ei, 4) = "無" 'Cells(ei,Y)でYはフラグを立てる行 End If NextEnd SubSub MgTest20171115() Application.ScreenUpdating = True '今回はなくてもOK 'Dim bookname As String 'bookname = Dir(ThisWorkbook.Path & "\操作対象ブックフォルダ\*") 'Workbooks.Open Filename:=ThisWorkbook.Path & _ "\操作対象ブックフォルダ\" & bookname Call bookopen UserForm2.Show '　2017/11/13追加 Dim sti, stj As Long Dim i, j As Long sti = ActiveCell.row stj = ActiveCell.Column If sti < 2 Then sti = 2 End If If stj < 5 Then stj = 5 End If Cells(sti, stj).Activate For j = 5 To Cells(1, Columns.Count).End(xlToLeft).Column For i = 2 To Cells(Rows.Count, j).End(xlUp).row If Cells(i, j).Interior.Pattern = xlNone _ And Cells(i, j).Interior.TintAndShade = 0 _ And Cells(i, j).Interior.PatternTintAndShade = 0 _ And Cells(i, j) <> "" And InStr(Uname, Cells(i, 1)) <> 0 _ Then '塗りつぶしなしだったら 'If skpFlg = False Then 'スキップしてなかったら Cells(i, j).Activate UserForm1.Show i = ActiveCell.row j = ActiveCell.Column Call skip1(i, j) 'スキップ　2017/11/15追加 'End If End If Next NextEnd SubSub skip1(ByVal i As Long, ByVal j As Long) '値が重複しているものは色付きにして飛ばす 'skpFlg = False 'allStr = allStr + Cells(i, j) Dim chei, chej As Long For chei = 2 To Cells(Rows.Count, 1).End(xlUp).row For chej = 5 To Cells(1, Columns.Count).End(xlToLeft).Column If Cells(chei, chej).Interior.Pattern = xlNone _ And Cells(chei, chej).Interior.TintAndShade = 0 _ And Cells(chei, chej).Interior.PatternTintAndShade = 0 _ And Cells(chei, chej) = Cells(i, j) Then If Cells(i, j).Interior.Color = 255 Or Cells(i, j).Interior.Color = 65535 Then If Cells(1, chej).Value = "顧客事業所名" _ Or Cells(1, chej).Value = "顧客事業所" _ Or Cells(1, chej).Value = "事業所単位" _ Or Cells(1, chej).Value = "就業先部課名" Then 'エスカ条件 Cells(chei, chej).Interior.Color = 255 '赤 Else Cells(chei, chej).Interior.Color = 65535 '黄色 End If Else Cells(chei, chej).Interior.Color _ = Cells(i, j).Interior.Color End If End If Next Next 'skpFlg = True Call escaFlag End SubOption Explicit#If VBA7 ThenPrivate Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)#ElsePrivate Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)#End IfPublic allStr As String 'ダブりなし見比べ全文　2017/11/15追加'Public skpFlg As Boolean 'スキップしたらtrue　2017/11/15追加Public Uname As String 'ユーザーネーム　作業担当者の指名プログラム的に良くないようだ　2017/11/13追加Sub bookopen() Dim bookname As String bookname = Dir(ThisWorkbook.Path & "\操作対象ブックフォルダ\*") Debug.Print "ブックネーム=" & bookname Dim wbook As Workbook For Each wbook In Workbooks Debug.Print wbook.name If wbook.name = bookname Then wbook.Activate Exit For End If Next wbook Sleep 1 If ActiveWorkbook.name <> bookname Then Workbooks.Open Filename:=ThisWorkbook.Path & _ "\操作対象ブックフォルダ\" & bookname End IfEnd SubSub escaFlag() '2017/11/14追加'エスカフラグを立てる'その行に赤色に塗りつぶしてあるセルがあったら'フラグefがtrueになる Dim ei, ej, ef As Boolean For ei = 2 To Cells(Rows.Count, 2).End(xlUp).row ef = False For ej = 5 To Cells(1, Columns.Count).End(xlToLeft).Column If Cells(ei, ej).Interior.Color = 255 Then ef = True End If Next If ef = True Then Cells(ei, 4) = "有" 'Cells(ei,Y)でYはフラグを立てる行 Else Cells(ei, 4) = "無" 'Cells(ei,Y)でYはフラグを立てる行 End If NextEnd SubSub MgTest20171115() Application.ScreenUpdating = True '今回はなくてもOK 'Dim bookname As String 'bookname = Dir(ThisWorkbook.Path & "\操作対象ブックフォルダ\*") 'Workbooks.Open Filename:=ThisWorkbook.Path & _ "\操作対象ブックフォルダ\" & bookname Call bookopen UserForm2.Show '　2017/11/13追加 Dim sti, stj As Long Dim i, j As Long sti = ActiveCell.row stj = ActiveCell.Column If sti < 2 Then sti = 2 End If If stj < 5 Then stj = 5 End If Cells(sti, stj).Activate For j = 5 To Cells(1, Columns.Count).End(xlToLeft).Column For i = 2 To Cells(Rows.Count, j).End(xlUp).row If Cells(i, j).Interior.Pattern = xlNone _ And Cells(i, j).Interior.TintAndShade = 0 _ And Cells(i, j).Interior.PatternTintAndShade = 0 _ And Cells(i, j) <> "" And InStr(Uname, Cells(i, 1)) <> 0 _ Then '塗りつぶしなしだったら 'If skpFlg = False Then 'スキップしてなかったら Cells(i, j).Activate UserForm1.Show i = ActiveCell.row j = ActiveCell.Column Call skip1(i, j) 'スキップ　2017/11/15追加 'End If End If Next NextEnd SubSub skip1(ByVal i As Long, ByVal j As Long) '値が重複しているものは色付きにして飛ばす 'skpFlg = False 'allStr = allStr + Cells(i, j) Dim chei, chej As Long For chei = 2 To Cells(Rows.Count, 1).End(xlUp).row For chej = 5 To Cells(1, Columns.Count).End(xlToLeft).Column If Cells(chei, chej).Interior.Pattern = xlNone _ And Cells(chei, chej).Interior.TintAndShade = 0 _ And Cells(chei, chej).Interior.PatternTintAndShade = 0 _ And Cells(chei, chej) = Cells(i, j) Then If Cells(i, j).Interior.Color = 255 Or Cells(i, j).Interior.Color = 65535 Then If Cells(1, chej).Value = "顧客事業所名" _ Or Cells(1, chej).Value = "顧客事業所" _ Or Cells(1, chej).Value = "事業所単位" _ Or Cells(1, chej).Value = "就業先部課名" Then 'エスカ条件 Cells(chei, chej).Interior.Color = 255 '赤 Else Cells(chei, chej).Interior.Color = 65535 '黄色 End If Else Cells(chei, chej).Interior.Color _ = Cells(i, j).Interior.Color End If End If Next Next 'skpFlg = True Call escaFlag End Sub'=============================userform1Option ExplicitPrivate Sub UserForm_Initialize() Dim ar, ac As Long ar = ActiveCell.row ac = ActiveCell.Column Me.Label1.Caption = Cells(1, ac).Value Me.Label2.Caption = Cells(ar, 3).Value With TextBox1 .MultiLine = True '複数行 .EnterKeyBehavior = True 'Enterキー .TabKeyBehavior = True 'Tabキー .Text = ActiveCell End With 'Me.TextBox1.Text = ActiveCellEnd SubPrivate Sub CommandButton1_Click() ActiveCell.Interior.Color = 5296274 '緑 Unload MeEnd SubPrivate Sub CommandButton2_Click() Dim ac As Long ac = ActiveCell.Column If Cells(1, ac).Value = "顧客事業所名" _ Or Cells(1, ac).Value = "顧客事業所" _ Or Cells(1, ac).Value = "事業所単位" _ Or Cells(1, ac).Value = "就業先部課名" _ Then 'エスカ条件 'エスカの場合の色付け ActiveCell.Interior.Color = 255 '赤 Else ActiveCell.Interior.Color = 65535 '黄色 End If Unload MeEnd SubPrivate Sub CommandButton3_Click() With ActiveCell.Interior .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.499984740745262 End With Unload MeEnd SubPrivate Sub CommandButton4_Click() End '終了End SubPrivate Sub CommandButton5_Click() '戻るボタン Dim i, j As Long Dim ar, ac As Long ar = ActiveCell.row ac = ActiveCell.Column If ActiveCell.Address = "$E$2" Then End End If If ar = 2 Then ar = Cells(Rows.Count, ac - 1).End(xlUp).row + 1 ac = ac - 1 End If For j = ac To 5 Step -1 For i = ar - 1 To 2 Step -1 If Cells(i, j) <> "" Then Cells(i, j).Activate Unload Me UserForm1.Show Exit For Exit For End If Next Next End SubPrivate Sub CommandButton6_Click() Dim i, j As Long Dim ar, ac As Long ar = ActiveCell.row ac = ActiveCell.Column i = Cells(Rows.Count, 1).End(xlUp).row j = Cells(1, Columns).End(xlToLeft).Columns If ar = i And ac = j Then End End If If ar = i Then ar = 1 ac = ac - 1 End If For j = 4 To Cells(1, Columns.Count).End(xlToLeft).Column For i = 2 To Cells(Rows.Count, j).End(xlUp).row If Cells(i, j) <> "" Then Cells(i, j).Activate UserForm1.Show i = ActiveCell.row j = ActiveCell.Column End If Next Next End Sub'============================userform2Option ExplicitPrivate Sub CommandButton1_Click() Dim i As Long Dim allName As String allName = "" If ComboBox1.Text = "全員" Then For i = 2 To Cells(Rows.Count, 1).End(xlUp).row If InStr(allName, Cells(i, 1)) = 0 Then allName = allName + Cells(i, 1) End If Next Uname = allName Else Uname = ComboBox1.Text End If HideEnd SubPrivate Sub UserForm_Initialize() Dim i As Long Dim allName As String allName = "" For i = 2 To Cells(Rows.Count, 1).End(xlUp).row If InStr(allName, Cells(i, 1)) = 0 Then ComboBox1.AddItem Cells(i, 1) allName = allName + Cells(i, 1) End If Next ComboBox1.AddItem "全員"End Sub

2017.11.19

コメント(0)

DB化構想20171117

Option ExplicitSub makeDirectory() 'MsgBox ThisWorkbook.Application.CheckSpelling(Cells(3, 2)) Debug.Print ThisWorkbook.Path 'Dir (ThisWorkbook.Path) 'Cells(5, 2)にCLコードがあるとしたら Dim foldername1 As String foldername1 = ThisWorkbook.Path & "\" & Left(Cells(5, 2), 4) Debug.Print foldername1 'MsgBox Dir(ThisWorkbook.Path & "\" & foldername1, vbDirectory) If Dir(foldername1, vbDirectory) = "" Then MkDir (foldername1) End If Dim filename1 As String filename1 = foldername1 & "\" & Cells(5, 2) & ".xlsx" Dim newbk As String newbk = ActiveWorkbook.Name If Dir(filename1) = "" Then Workbooks.Add '開いたブックはアクティブ！ newbk = ActiveWorkbook.Name Workbooks(newbk).SaveAs _ filename:=filename1 'ここからCLコードファイルはfilename1という名前になる Else Workbooks.Open filename:=filename1 End If End Sub

2017.11.17

コメント(0)

Mgr承認メモ　2017/11/15

Option Explicit#If VBA7 ThenPrivate Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)#ElsePrivate Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)#End IfPublic allStr As String 'ダブりなし見比べ全文　2017/11/15追加'Public skpFlg As Boolean 'スキップしたらtrue　2017/11/15追加Public Uname As String 'ユーザーネーム　作業担当者の指名プログラム的に良くないようだ　2017/11/13追加Sub bookopen() Dim bookname As String bookname = Dir(ThisWorkbook.Path & "\操作対象ブックフォルダ\*") Debug.Print "ブックネーム=" & bookname Dim wbook As Workbook For Each wbook In Workbooks Debug.Print wbook.name If wbook.name = bookname Then wbook.Activate Exit For End If Next wbook Sleep 1 If ActiveWorkbook.name <> bookname Then Workbooks.Open Filename:=ThisWorkbook.Path & _ "\操作対象ブックフォルダ\" & bookname End IfEnd SubSub escaFlag() '2017/11/14追加'エスカフラグを立てる'その行に赤色に塗りつぶしてあるセルがあったら'フラグefがtrueになる Dim ei, ej, ef As Boolean For ei = 2 To Cells(Rows.Count, 2).End(xlUp).row ef = False For ej = 5 To Cells(1, Columns.Count).End(xlToLeft).Column If Cells(ei, ej).Interior.Color = 255 Then ef = True End If Next If ef = True Then Cells(ei, 4) = "有" 'Cells(ei,Y)でYはフラグを立てる行 Else Cells(ei, 4) = "無" 'Cells(ei,Y)でYはフラグを立てる行 End If NextEnd SubSub MgTest20171115() Application.ScreenUpdating = True '今回はなくてもOK 'Dim bookname As String 'bookname = Dir(ThisWorkbook.Path & "\操作対象ブックフォルダ\*") 'Workbooks.Open Filename:=ThisWorkbook.Path & _ "\操作対象ブックフォルダ\" & bookname Call bookopen UserForm2.Show '　2017/11/13追加 Dim sti, stj As Long Dim i, j As Long sti = ActiveCell.row stj = ActiveCell.Column If sti < 2 Then sti = 2 End If If stj < 5 Then stj = 5 End If Cells(sti, stj).Activate For j = 5 To Cells(1, Columns.Count).End(xlToLeft).Column For i = 2 To Cells(Rows.Count, j).End(xlUp).row If Cells(i, j).Interior.Pattern = xlNone _ And Cells(i, j).Interior.TintAndShade = 0 _ And Cells(i, j).Interior.PatternTintAndShade = 0 _ And Cells(i, j) <> "" And InStr(Uname, Cells(i, 1)) <> 0 _ Then '塗りつぶしなしだったら 'If skpFlg = False Then 'スキップしてなかったら Cells(i, j).Activate UserForm1.Show i = ActiveCell.row j = ActiveCell.Column Call skip1(i, j) 'スキップ　2017/11/15追加 'End If End If Next NextEnd SubSub skip1(ByVal i As Long, ByVal j As Long) '値が重複しているものは色付きにして飛ばす 'skpFlg = False 'allStr = allStr + Cells(i, j) Dim chei, chej As Long For chei = 2 To Cells(Rows.Count, 1).End(xlUp).row For chej = 5 To Cells(1, Columns.Count).End(xlToLeft).Column If Cells(chei, chej).Interior.Pattern = xlNone _ And Cells(chei, chej).Interior.TintAndShade = 0 _ And Cells(chei, chej).Interior.PatternTintAndShade = 0 _ And Cells(chei, chej) = Cells(i, j) Then If Cells(i, j).Interior.Color = 255 Or Cells(i, j).Interior.Color = 65535 Then If Cells(1, chej).Value = "顧客事業所名" _ Or Cells(1, chej).Value = "顧客事業所" _ Or Cells(1, chej).Value = "事業所単位" _ Or Cells(1, chej).Value = "就業先部課名" Then 'エスカ条件 Cells(chei, chej).Interior.Color = 255 '赤 Else Cells(chei, chej).Interior.Color = 65535 '黄色 End If Else Cells(chei, chej).Interior.Color _ = Cells(i, j).Interior.Color End If End If Next Next 'skpFlg = True Call escaFlag End Sub'============================'ユーザーフォーム1　戻ると色付け条件あたり変えたかも'============================Option ExplicitPrivate Sub UserForm_Initialize() Dim ar, ac As Long ar = ActiveCell.row ac = ActiveCell.Column Me.Label1.Caption = Cells(1, ac).Value Me.Label2.Caption = Cells(ar, 3).Value With TextBox1 .MultiLine = True '複数行 .EnterKeyBehavior = True 'Enterキー .TabKeyBehavior = True 'Tabキー .Text = ActiveCell End With 'Me.TextBox1.Text = ActiveCellEnd SubPrivate Sub CommandButton1_Click() ActiveCell.Interior.Color = 5296274 '緑 Unload MeEnd SubPrivate Sub CommandButton2_Click() Dim ac As Long ac = ActiveCell.Column If Cells(1, ac).Value = "顧客事業所名" _ Or Cells(1, ac).Value = "顧客事業所" _ Or Cells(1, ac).Value = "事業所単位" _ Or Cells(1, ac).Value = "就業先部課名" _ Then 'エスカ条件 'エスカの場合の色付け ActiveCell.Interior.Color = 255 '赤 Else ActiveCell.Interior.Color = 65535 '黄色 End If Unload MeEnd SubPrivate Sub CommandButton3_Click() With ActiveCell.Interior .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.499984740745262 End With Unload MeEnd SubPrivate Sub CommandButton4_Click() End '終了End SubPrivate Sub CommandButton5_Click() '戻るボタン Dim i, j As Long Dim ar, ac As Long ar = ActiveCell.row ac = ActiveCell.Column If ActiveCell.Address = "$E$2" Then End End If If ar = 2 Then ar = Cells(Rows.Count, ac - 1).End(xlUp).row + 1 ac = ac - 1 End If For j = ac To 5 Step -1 For i = ar - 1 To 2 Step -1 If Cells(i, j) <> "" Then Cells(i, j).Activate Unload Me UserForm1.Show Exit For Exit For End If Next Next End SubPrivate Sub CommandButton6_Click() Dim i, j As Long Dim ar, ac As Long ar = ActiveCell.row ac = ActiveCell.Column i = Cells(Rows.Count, 1).End(xlUp).row j = Cells(1, Columns).End(xlToLeft).Columns If ar = i And ac = j Then End End If If ar = i Then ar = 1 ac = ac - 1 End If For j = 4 To Cells(1, Columns.Count).End(xlToLeft).Column For i = 2 To Cells(Rows.Count, j).End(xlUp).row If Cells(i, j) <> "" Then Cells(i, j).Activate UserForm1.Show i = ActiveCell.row j = ActiveCell.Column End If Next Next End Sub

2017.11.16

コメント(0)

Mgr承認メモ2017/11/14

Option Explicit#If VBA7 ThenPrivate Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)#ElsePrivate Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)#End IfPublic Uname As String 'プログラム的に良くないようだ　2017/11/13追加Sub MgTest() Application.ScreenUpdating = True '今回はなくてもOK 'Dim bookname As String 'bookname = Dir(ThisWorkbook.Path & "\操作対象ブックフォルダ\*") 'Workbooks.Open Filename:=ThisWorkbook.Path & _ "\操作対象ブックフォルダ\" & bookname Call bookopen UserForm2.Show '　2017/11/13追加 Dim sti, stj As Long Dim i, j As Long sti = ActiveCell.row stj = ActiveCell.Column If sti < 2 Then sti = 2 End If If stj < 5 Then stj = 5 End If Cells(sti, stj).Activate For j = 5 To Cells(1, Columns.Count).End(xlToLeft).Column For i = 2 To Cells(Rows.Count, j).End(xlUp).row If Cells(i, j) <> "" And InStr(Uname, Cells(i, 1)) <> 0 Then If Cells(i, j).Interior.Pattern = xlNone _ And Cells(i, j).Interior.TintAndShade = 0 _ And Cells(i, j).Interior.PatternTintAndShade = 0 _ Then '塗りつぶしなしだったら Cells(i, j).Activate UserForm1.Show i = ActiveCell.row j = ActiveCell.Column End If End If Next NextEnd SubSub bookopen() Dim bookname As String bookname = Dir(ThisWorkbook.Path & "\操作対象ブックフォルダ\*") Debug.Print "ブックネーム=" & bookname Dim wbook As Workbook For Each wbook In Workbooks Debug.Print wbook.name If wbook.name = bookname Then wbook.Activate Exit For End If Next wbook Sleep 1 If ActiveWorkbook.name <> bookname Then Workbooks.Open Filename:=ThisWorkbook.Path & _ "\操作対象ブックフォルダ\" & bookname End IfEnd SubSub escaFlag() '2017/11/14追加'エスカフラグを立てる'その行に赤色に塗りつぶしてあるセルがあったら'フラグefがtrueになる Dim ei, ej, ef As Boolean For ei = 2 To Cells(Rows.Count, 2).End(xlUp).row ef = False For ej = 5 To Cells(1, Columns.Count).End(xlToLeft).Column If Cells(ei, ej).Interior.Color = 255 Then ef = True End If Next If ef = True Then Cells(ei, 4) = "有" 'Cells(ei,Y)でYはフラグを立てる行 Else Cells(ei, 4) = "無" 'Cells(ei,Y)でYはフラグを立てる行 End If NextEnd SubOption ExplicitPrivate Sub CommandButton1_Click() Dim i As Long Dim allName As String allName = "" If ComboBox1.Text = "全員" Then For i = 2 To Cells(Rows.Count, 1).End(xlUp).row If InStr(allName, Cells(i, 1)) = 0 Then allName = allName + Cells(i, 1) End If Next Uname = allName Else Uname = ComboBox1.Text End If HideEnd Sub'-------------------------------------------------'UserForm2'-------------------------------------------------Private Sub UserForm_Initialize() Dim i As Long Dim allName As String allName = "" For i = 2 To Cells(Rows.Count, 1).End(xlUp).row If InStr(allName, Cells(i, 1)) = 0 Then ComboBox1.AddItem Cells(i, 1) allName = allName + Cells(i, 1) End If Next ComboBox1.AddItem "全員"End Sub

2017.11.14

コメント(0)

役職変更メモ20171112

Option ExplicitPrivate Declare Function timeGetTime Lib "winmm.dll" () As Long#If VBA7 ThenPrivate Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)#ElsePrivate Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)#End If'----------------------------------------------------------------'①指定URLを表示するサブルーチン「ieView」Sub ieView(objIE As InternetExplorer, _ urlName As String, _ Optional viewFlg As Boolean = True) 'IE(InternetExplorer)のオブジェクトを作成する Set objIE = CreateObject("InternetExplorer.Application") 'IE(InternetExplorer)を表示・非表示 objIE.Visible = viewFlg '指定したURLのページを表示する objIE.navigate urlName 'IEが完全表示されるまで待機 Call ieCheck(objIE)End Sub'----------------------------------------------------------------'②Webページ完全読込待機処理サブルーチン「ieCheck」Sub ieCheck(objIE As InternetExplorer) Dim timeOut As Date timeOut = Now + TimeSerial(0, 0, 20) Do While objIE.Busy = True Or objIE.readyState <> 4 DoEvents Sleep 1 If Now > timeOut Then objIE.Refresh timeOut = Now + TimeSerial(0, 0, 20) End If Loop timeOut = Now + TimeSerial(0, 0, 20) Do While objIE.document.readyState <> "complete" DoEvents Sleep 1 If Now > timeOut Then objIE.Refresh timeOut = Now + TimeSerial(0, 0, 20) End If LoopEnd Sub'----------------------------------------------------------------'▼サブルーチンを利用して複数サイトをIEで起動させるマクロSub sample() Dim objIE As InternetExplorer Dim objIE2 As InternetExplorer '本サイトをIEで起動 Call ieView(objIE, "http://www.yahoo.co.jp/") 'yahooサイトをIEで起動 Call ieView(objIE2, "http://www.yahoo.co.jp/")End SubSub 担当者情報変更_役職() Dim celval As String celval = Worksheets("担当者情報").Cells(1, 1).Value Call estVal(celval) Dim objIE As InternetExplorer 'サイトをIEで起動 Call ieView(objIE, "http://www.yahoo.co.jp/") Dim htmlDoc As HTMLDocument 'HTMLドキュメントオブジェクトを準備 Set htmlDoc = objIE.document 'objIEで読み込まれているHTMLドキュメントをセット Dim elForm As IHTMLElement, elBtn As IHTMLElement, elPlaceholder As IHTMLElement 'IHTMLElementオブジェクトを準備 'Set elForm = htmlDoc.getElementsByName("sf1")(0) 'formをセット Set elBtn = htmlDoc.getElementById("srchbtn") Set elPlaceholder = htmlDoc.getElementById("srchtxt") '検索窓をセット elPlaceholder.Value = celval '検索窓にキーワードを入力 'elForm.submit '送信 elBtn.Click End SubSub estVal(celval As String) Debug.Print Mid(celval, InStr(celval, "e-sta:") + 6) celval = Mid(celval, InStr(celval, "e-sta:") + 6)End Sub

2017.11.12

コメント(0)

判定メモ20171112

'判定は無理だと思うんだよなOption ExplicitPrivate Declare Function timeGetTime Lib "winmm.dll" () As Long#If VBA7 ThenPrivate Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)#ElsePrivate Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)#End IfSub decision01() Dim i_time As Long '開始時間 i_time = timeGetTime() Application.ScreenUpdating = False Dim i, j As Long Dim ASKword, estaWord As String Dim ASKwordCount, estawordCount, estawordLast As Long Dim judge1 As Long ASKword = Worksheets("判定").Range("B2") estaWord = Worksheets("判定").Range("B4") '先ずはASKとe-sta両方のスペースの除去 '半角にして、" "(半角スペース)を '""にして取り除く '半角にする ASKword = StrConv(ASKword, vbNarrow) estaWord = StrConv(estaWord, vbNarrow) 'Substuteで" "→"" ASKword = WorksheetFunction.Substitute(ASKword, " ", "") estaWord = WorksheetFunction.Substitute(estaWord, " ", "") '略称となりうる文字列を含んでいるか探す 'それと略していない形の文字列をもう一方で探す '存在していたら、同じ組織の単位として扱う 'Dim ASKword, estaWord, ryk As String Dim Count1, Count2 As Long 'ASKword = Worksheets("判定").Range("B2") 'estaWord = Worksheets("判定").Range("B4") With Worksheets("組織単位略称一覧") For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row Count1 = InStr(ASKword, .Cells(i, 2)) If Count1 <> 0 Then Count2 = InStr(estaWord, StrConv(.Cells(i, 3), vbNarrow)) If Count2 <> 0 Then ASKword = WorksheetFunction.Substitute(ASKword, .Cells(i, 2), .Cells(i, 3)) Else End If Else End If Next End With With Worksheets("組織単位略称一覧") For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row Count1 = InStr(estaWord, .Cells(i, 2)) If Count1 <> 0 Then Count2 = InStr(ASKword, StrConv(.Cells(i, 3), vbNarrow)) If Count2 <> 0 Then estaWord = WorksheetFunction.Substitute(estaWord, .Cells(i, 2), .Cells(i, 3)) Else End If Else End If Next End With ASKword = StrConv(ASKword, vbNarrow) estaWord = StrConv(estaWord, vbNarrow) Debug.Print "ASK : " & ASKword & " e-sta : " & estaWord 'ここで一旦判定してみる If ASKword = estaWord Then Debug.Print "一致" End End If With Worksheets("判定") ASKwordCount = Len(ASKword) 'ASK文字数 estawordCount = Len(estaWord) 'e-sta文字数 Debug.Print "ASK:" & ASKwordCount & " e-sta:" & estawordCount 'e-staの最後の文字があるところを探す estawordLast = InStr(1, ASKword, Right(estaWord, 1)) '最後の文字が入っていなかったら不一致 If estawordLast = 0 Then 'ここ必要ないかも　一応、判定一回目 Debug.Print "不一致" Debug.Print Format$(timeGetTime - i_time) & " ミリ秒" Application.ScreenUpdating = True End End If Debug.Print "e-staの最後の文字はASKの" & estawordLast & "文字目" Debug.Print "比較対象は" & Left(ASKword, InStr(1, ASKword, Right(estaWord, 1))) For i = 1 To ASKwordCount judge1 = InStr(1, ASKword, Right(estaWord, i)) Next If judge1 = 1 Then Debug.Print "一致" Else Debug.Print "次の処理へ" End If End With '処理時間 Debug.Print Format$(timeGetTime - i_time) & " ミリ秒" Application.ScreenUpdating = TrueEnd SubFunction 略称を戻す(ByVal ASKword As String, ByVal estaWord As String) '略称となりうる文字列を含んでいるか探す 'それと略していない形の文字列をもう一方で探す '存在していたら、同じ組織の単位として扱う 'Dim ASKword, estaWord, ryk As String Dim i, j, Count1, Count2 As Long 'ASKword = Worksheets("判定").Range("B2") 'estaWord = Worksheets("判定").Range("B4") With Worksheets("組織単位略称一覧") For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row Count1 = InStr(ASKword, .Cells(i, 2)) If Count1 <> 0 Then Count2 = InStr(estaWord, StrConv(.Cells(i, 3), vbNarrow)) If Count2 <> 0 Then ASKword = WorksheetFunction.Substitute(ASKword, .Cells(i, 2), .Cells(i, 3)) Else End If Else End If Next End With With Worksheets("組織単位略称一覧") For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row Count1 = InStr(estaWord, .Cells(i, 2)) If Count1 <> 0 Then Count2 = InStr(ASKword, StrConv(.Cells(i, 3), vbNarrow)) If Count2 <> 0 Then estaWord = WorksheetFunction.Substitute(estaWord, .Cells(i, 2), .Cells(i, 3)) Else End If Else End If Next End With ASKword = StrConv(ASKword, vbNarrow) estaWord = StrConv(estaWord, vbNarrow) Debug.Print "ASK : " & ASKword & " e-sta : " & estaWord Dim refdate(1) As Variant refdate(0) = ASKword refdate(1) = estaWord 略称を戻す = refdate()End FunctionSub decision03() Dim i_time As Long '開始時間 i_time = timeGetTime() Application.ScreenUpdating = False Dim i, j As Long Dim ASKword, estaWord As String Dim ASKwordCount, estawordCount, estawordLast As Long Dim judge1 As Long ASKword = Worksheets("判定").Range("B2") estaWord = Worksheets("判定").Range("B4") '先ずはASKとe-sta両方のスペースの除去 '文字コードASCにして、" "(半角スペース)を '""にして取り除く 'ASCで囲む ASKword = StrConv(ASKword, vbNarrow) estaWord = StrConv(estaWord, vbNarrow) 'Substuteで" "→"" ASKword = WorksheetFunction.Substitute(ASKword, " ", "") estaWord = WorksheetFunction.Substitute(estaWord, " ", "") Call 略称を戻す(ASKword, estaWord) Dim refdate(1) As Variant ASKword = refdate(0) estaWord = refdate(1) 'ここで一旦判定してみる If ASKword = estaWord Then Debug.Print "一致" End End If With Worksheets("判定") ASKwordCount = Len(ASKword) 'ASK文字数 estawordCount = Len(estaWord) 'e-sta文字数 Debug.Print "ASK:" & ASKwordCount & " e-sta:" & estawordCount 'e-staの最後の文字があるところを探す estawordLast = InStr(1, ASKword, Right(estaWord, 1)) '最後の文字が入っていなかったら不一致 If estawordLast = 0 Then 'ここ必要ないかも　一応、判定 Debug.Print "不一致" Debug.Print Format$(timeGetTime - i_time) & " ミリ秒" Application.ScreenUpdating = True End End If Debug.Print "e-staの最後の文字は" & estawordLast & "文字目" Debug.Print "比較対象は" & Left(ASKword, InStr(1, ASKword, Right(estaWord, 1))) For i = 1 To ASKwordCount judge1 = InStr(1, ASKword, Right(estaWord, i)) Next If judge1 = 1 Then Debug.Print "一致" Else Debug.Print "次の処理へ" End If End With '処理時間 Debug.Print Format$(timeGetTime - i_time) & " ミリ秒" Application.ScreenUpdating = TrueEnd SubSub decision02()'部課の単位を探して挟む''''' Dim i_time As Long '開始時間 i_time = timeGetTime() Application.ScreenUpdating = False Dim i, j As Long Dim ASKword, estaWord As String Dim ASKwordCount, estawordCount, estawordLast As Long Dim judge1 As Long ASKword = Worksheets("判定").Range("B2") estaWord = Worksheets("判定").Range("B4") With Worksheets("判定") ASKwordCount = Len(ASKword) estawordCount = Len(estaWord) Debug.Print "ASK:" & ASKwordCount & " e-sta:" & estawordCount 'e-staの最後の文字があるところを探す estawordLast = InStr(1, ASKword, Right(estaWord, 1)) '最後の文字が入っていなかったら不一致 If estawordLast = 0 Then 'ここ必要ないかも Debug.Print "不一致" Debug.Print Format$(timeGetTime - i_time) & " ミリ秒" Application.ScreenUpdating = True End End If Debug.Print "e-staの最後の文字は" & estawordLast & "文字目" Debug.Print "比較対象は" & Left(ASKword, InStr(1, ASKword, Right(estaWord, 1))) For i = 1 To ASKwordCount judge1 = InStr(1, ASKword, Right(estaWord, i)) Next If judge1 = 1 Then Debug.Print "一致" Else Debug.Print "次の処理へ" End If End With '処理時間 Debug.Print Format$(timeGetTime - i_time) & " ミリ秒" Application.ScreenUpdating = True End SubFunction 略称を戻す1(ByVal ASKword As String, ByVal estaWord As String) '略称となりうる文字列を含んでいるか探す 'それと略していない形の文字列をもう一方で探す '存在していたら、同じ組織の単位として扱う 'Dim ASKword, estaWord, ryk As String Dim i, j, Count1, Count2 As Long 'ASKword = Worksheets("判定").Range("B2") 'estaWord = Worksheets("判定").Range("B4") With Worksheets("組織単位略称一覧") For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row Count1 = InStr(ASKword, .Cells(i, 2)) If Count1 <> 0 Then Count2 = InStr(estaWord, StrConv(.Cells(i, 3), vbNarrow)) If Count2 <> 0 Then ASKword = WorksheetFunction.Substitute(ASKword, .Cells(i, 2), .Cells(i, 3)) Else End If Else End If Next End With With Worksheets("組織単位略称一覧") For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row Count1 = InStr(estaWord, .Cells(i, 2)) If Count1 <> 0 Then Count2 = InStr(ASKword, StrConv(.Cells(i, 3), vbNarrow)) If Count2 <> 0 Then estaWord = WorksheetFunction.Substitute(estaWord, .Cells(i, 2), .Cells(i, 3)) Else End If Else End If Next End With ASKword = StrConv(ASKword, vbNarrow) estaWord = StrConv(estaWord, vbNarrow) Debug.Print "ASK : " & ASKword & " e-sta : " & estaWord Dim refdate(1) As Variant refdate(0) = ASKword refdate(1) = estaWord 略称を戻す = refdateEnd FunctionSub 組織単位を探す()End Sub

2017.11.12

コメント(0)

Mgr承認メモ

セキュリティの関係で、この方法(;´Д｀)メール使えない。USB使えない。手書き面倒。'-------------------------------'Module1のコード'-------------------------------Option Explicit#If VBA7 ThenPrivate Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)#ElsePrivate Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)#End IfSub MgTest() Application.ScreenUpdating = True '今回はなくてもOK 'Dim bookname As String 'bookname = Dir(ThisWorkbook.Path & "\操作対象ブックフォルダ\*") 'Workbooks.Open Filename:=ThisWorkbook.Path & _ "\操作対象ブックフォルダ\" & bookname Call bookopen Dim sti, stj As Long Dim i, j As Long sti = ActiveCell.row stj = ActiveCell.Column If sti < 2 Then sti = 2 End If If stj < 4 Then stj = 4 End If Cells(sti, stj).Activate For j = 4 To Cells(1, Columns.Count).End(xlToLeft).Column For i = 2 To Cells(Rows.Count, j).End(xlUp).row If Cells(i, j) <> "" Then If Cells(i, j).Interior.Pattern = xlNone _ And Cells(i, j).Interior.TintAndShade = 0 _ And Cells(i, j).Interior.PatternTintAndShade = 0 _ Then '塗りつぶしなしだったら Cells(i, j).Activate UserForm1.Show i = ActiveCell.row j = ActiveCell.Column End If End If Next NextEnd SubSub bookopen() Dim bookname As String bookname = Dir(ThisWorkbook.Path & "\操作対象ブックフォルダ\*") Debug.Print "ブックネーム=" & bookname Dim wbook As Workbook For Each wbook In Workbooks Debug.Print wbook.Name If wbook.Name = bookname Then wbook.Activate Exit For End If Next wbook Sleep 1 If ActiveWorkbook.Name <> bookname Then Workbooks.Open Filename:=ThisWorkbook.Path & _ "\操作対象ブックフォルダ\" & bookname End IfEnd Sub'-------------------------------'-------------------------------'UserForm1のコード'-------------------------------Option ExplicitPrivate Sub UserForm_Initialize() Dim ar, ac As Long ar = ActiveCell.row ac = ActiveCell.Column Me.Label1.Caption = Cells(1, ac).Value Me.Label2.Caption = Cells(ar, 2).Value With TextBox1 .MultiLine = True '複数行 .EnterKeyBehavior = True 'Enterキー .TabKeyBehavior = True 'Tabキー .Text = ActiveCell End With 'Me.TextBox1.Text = ActiveCellEnd SubPrivate Sub CommandButton1_Click() ActiveCell.Interior.Color = 5296274 '緑 Unload MeEnd SubPrivate Sub CommandButton2_Click() Dim ac As Long ac = ActiveCell.Column If Cells(1, ac).Value = "顧客事業所名" Or _ Cells(1, ac).Value = "顧客事業所" Or _ Cells(1, ac).Value = "事業所単位" _ Then 'エスカ条件 'エスカの場合の色付け ActiveCell.Interior.Color = 255 '赤 Else ActiveCell.Interior.Color = 65535 '黄色 End If Unload MeEnd SubPrivate Sub CommandButton3_Click() With ActiveCell.Interior .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.499984740745262 End With Unload MeEnd SubPrivate Sub CommandButton4_Click() End '終了End SubPrivate Sub CommandButton5_Click() Dim i, j As Long Dim ar, ac As Long ar = ActiveCell.row ac = ActiveCell.Column If ActiveCell.Address = "$D$2" Then End End If If ar = 2 Then ar = Cells(Rows.Count, ac - 1).End(xlUp).row + 1 ac = ac - 1 End If For j = ac To 3 Step -1 For i = ar - 1 To 2 Step -1 If Cells(i, j) <> "" Then Cells(i, j).Activate Unload Me UserForm1.Show Exit For Exit For End If Next Next End SubPrivate Sub CommandButton6_Click() Dim i, j As Long Dim ar, ac As Long ar = ActiveCell.row ac = ActiveCell.Column i = Cells(Rows.Count, 1).End(xlUp).row j = Cells(1, Columns).End(xlToLeft).Columns If ar = i And ac = j Then End End If If ar = i Then ar = 1 ac = ac - 1 End If For j = 4 To Cells(1, Columns.Count).End(xlToLeft).Column For i = 2 To Cells(Rows.Count, j).End(xlUp).row If Cells(i, j) <> "" Then Cells(i, j).Activate UserForm1.Show i = ActiveCell.row j = ActiveCell.Column End If Next Next End Sub

2017.11.12

コメント(0)

英単語・熟語メモ

take one's last breath 息を引き取る

2016.08.19

コメント(2)

パーソナリティ心理学　メモ2

ボガード　遺伝要因　能力行動主義

2016.07.26

コメント(0)

パーソナリティ心理学　メモ

社会スキーマザイアンス効果ストックホルム効果　長い間一緒にいることを強制された→立てこもり事件　人質は犯人に好意を抱いた　警察を非難した心理的距離認知不協和コストがあるほうが報酬が得られる集団心理所属集団準拠集団　自分に類似している同調行動３人から集団と同等　３人のそれぞれの性質は無関係集団規範　内在化　認知に影響シェリフの実験暗室　光点ミルグラムの服従実験（アイヒマン実験）傍観者効果責任分散評価懸念　聴衆抑制多数の無知　多元的無知集団極性化現象　集団の判断に任せてしまうリスキーシフト　指揮者はリスクの高い判断をしやすい　ｅｘ.　キューバ危機なんちゃらシフト　集団では保守的、リスクの低い判断が下されやすい

2016.07.26

コメント(0)

ヘーゲル　『法の哲学』

「自由な意志」が「所有」の根源にある。「所有」を行うものを「人格」と呼ぶ。基本的に「所有」するものと「行使」するものは同一のものである。「所有」には「主観的な意志」の持続的な「表明」が必要である。

2016.05.09

コメント(0)

メモ

就中　なかんずく　特に　とりわけホメロス　叙事詩　紀元前8世紀　最古　神々登場シュリーマン(1822-90)の調査研究によって歴史的資料として再評価『イリアス』　『オデュッセイア』　トロイア戦争スパルタの王妃ヘレネとトロイアの王子パリスが不倫、駆け落ちスパルタ王が兄のアルゴス王のアガメムノン（重要人物）に泣きつくトロイア遠征『イリアス』　戦争シーン『オデュッセイア』　オデュッセウスの帰り道（10年）のお話し

2016.04.16

コメント(0)

今の彼女さんと付き合っていて楽（？）なところ

デートに時間・お金を掛けずに済む。前の彼女は時間が空きさえすれば、会いたいと言ってきたので、それと比べれば寂しくなるほど自分の時間が取れる。デート代も月２０万くらい掛かっていたのが、出ていかないから自分の生活費くらいしか掛からない。毎日、連絡とらなくても何も言われない。むしろ、毎日、連絡とろうとしても何も返事ない。

2016.03.15

コメント(0)

Japanese Alphabets

Japanese Alphabet Hiragana : There are about　50 characters. あ　い　う　え　おa i u e o か　き　く　け　こka ki ku ke ko さ　し　す　せ　そsa shi su se so た　ち　つ　て　とta chi tsu te to な　に　ぬ　ね　のna ni nu ne no は　ひ　ふ　へ　ほha hi fu he ho ま　み　む　め　もma mi mu me mo や　　ゆ　よya　yu　yo ら　り　る　れ　ろra ri ru re ro わ　を　んwa 　wo　 n This site is useful. : https://www.coscom.co.jp/hiragana-katakana/kanatable-j.html

2016.03.05

コメント(0)

心が麻痺した

想い人の幸せを本当に願うのであれば、その人のことを愛してはならず、中立的な関係性を保たなければならない。そのような恋愛って…何と言えばよいのだろう… なんだかわからなくなってきた…

2016.03.04

コメント(0)

27th February Saturday 2016

今更だけど、人生に無駄はないと思う。というか、無駄がある人生を送れるほど余裕なんてない。よく無駄なに過ごしたというけれど、その無駄がなければ、今のその人はいない。その無駄を否定するのであれば、どこかその人自身を否定してしまうところがある。「何々ができたはずなのに」とかいっても、実際はその人の精神的な成熟度、あるいはその時点での状況がその人の能力を制限していたという事はよくあると思う。極端な話、そのことを無理に行っていたら、その人の心が壊れてしまっていたかもしれない。そのために、保身に走ったとしても仕方がない。見方によっては、それはそれで一人の人間を守っている。だから、自分が怠惰だったからとか弱かったからとかいうことで、自分を責めても、それは思い通りにならなかったことを惜しがっているだけのように思える。実際は、本当に自分には出来なかった、不可能であったということを受け入れなければならない。そして、現在、そのような気持ちに苛まされているのであれば、同じようなことが起らないよう努力すべきだ。それは、後々、誰か、自分かも知れないし、他者かも知れない誰かを助けることにつながるのではないであろうか。

2016.02.27

コメント(0)

わたくしに

破滅的になるな

2016.02.12

コメント(0)

23th February Tuesday 2016 Lesson

How to ask : What are ~?Pattern 1 What are O? O wa nan desuka?What=nani, nanare=desu, desuka(Question form) ex.What are this(=kore)?kore wa nan desuka? What are your(anata-no) favorite(=okiniirino, sukina) manga?anata-no okiniiri-no manga wa nan desuka? Pattern 2 What are (adjective)?(adjective) (i, na) mono wa nan desu ka? What=nani, nanare=desu, desuka(Question form) (thing) = mono ex.What are heavy(omoi )? sea(umi)-sand(suna) and(to) sorrow(kanashimi): Omoi mono wa nan desuka? umi no suna to kanashimi: What are brief? today and tomorrow:Mijikai mono wa nan desuka? kyou to ashita: What are frail(hakanai)? Spring(haru) blossoms(hana) and youth(seisyun):Hakanai mono wa nan desuka? haru no hana to seisyun: What are deep(fukai)? the ocean(oh-unabara, taiyou) and truth(shinri) :Fukai mono wa nan desuka? oh-unabara to shinri: -by Christina Rosseti Can you make;What are ...?

2016.02.10

コメント(0)

教室で・・・

教師が何かしらの説明をした後、「わからない人いるか？」と聞くのはうまい方法ではないと思う。みんなが手をあげていない状況で、手をあげられるか。いじめに関する実態調査のアンケートなども教室でやらせるのもよろしくない。いじめているやつが見ているかもしれないのに書けるか。また、回収の仕方も後ろの席から前にまわすという方法をとったら、前の席の子に読まれる可能性がある。そこで素直に答えられると思っているのか。

2015.12.31

コメント(0)

乳幼児心理学-1

・対象の永続性概念(1) 遮蔽物により対象物が見えなくなっても存在する(2) 見えなくなっても物理的属性、空間的属性は変化せず保持される(3) 物理的法則が適用されるピアジェ(Pajet, 1954)生後８ヵ月までの幼児には、(1)は見られなかった生後9か月をすぎると、(1)は見られた1歳半をすぎると、(3)まで見られたベイラジオン(Baillargeon et al., 1985)注視時間を指標とし、「期待違反法」用いた。生後5ヶ月の乳児でも基本的な永続性概念を理解していることが示唆された。

2015.12.28

コメント(0)

乳幼児心理学-1

・対象の永続性概念(1) 遮蔽物により対象物が見えなくなっても存在する(2) 見えなくなっても物理的属性、空間的属性は変化せず保持される(3) 物理的法則が適用されるピアジェ(Pajet, 1954)生後８ヵ月までの幼児には、(1)は見られなかった生後9か月をすぎると、(1)は見られた1歳半をすぎると、(3)まで見られたベイラジオン(Baillargeon et al., 1985)注視時間を指標とし、「期待違反法」用いた。生後5ヶ月の乳児でも基本的な永続性概念を理解していることが示唆された。

2015.12.28

コメント(0)

ペルソナとゼーレ

ペルソナ・・・公的自己意識ゼーレ・・・私的自己意識という感じで良いのかな・・・

2015.12.27

コメント(0)

I Don't Love You / My Chemical Romance

高校生の頃によく聴いた曲だけど、先日聴いたら、歌詞の意味がよくわからなかったから、自分で訳してみた。公式の和訳もあるけれど、なんだか違和感を感じるんだよな。 -------------------------------------------------------------- I Don't Love You / My Chemical Romance Well, when you go君が去っていくとき So, never think I'll make you try to stay僕が引き止めようとするなんて絶対に思わないでくれ And maybe when you get backもし君が戻ってきたとしても I'll be off to find another wayもう僕は別の道を探しに出ている When after all this time that you still owe君とこんなに一緒にいるのに You're still a good for nothing I don't know相も変わらず君は僕には理解できない程にどうしようもないままだ So take your gloves and get outもう君の手袋を持って出て行ってくれ Better get out while you can出て行っていったほうが良い、君がそうできるうちに When you go and would you even turn to sayその時は、振り返りこう言っておいてくれないか "I don't love you like I did yesterday?"”私はもうあなたを愛していないの、昨日までのようには” Sometimes I cry so hard from pleading僕は言い訳をしながら大泣きすることがある So sick and tired of all the needless beating無駄に傷つけることすべて、もう嫌なんだ、うんざりする But baby when they knock you down and outだけど、ベイビー、僕の言葉（？）が君を徹底的に打ちのめすようなとき It's where you ought to stayそこが君のいるべきところなんだ Well after all the blood that you still oweこんなに血を流しても Another dollar's just another blowまた大切なはずのものを得ても、また酷く傷つけるものになるだけ So fix your eyes and get upだから、目を覚まして、立ち上がるんだ Better get up while you can, whoa whoa立ち上がるべきだ、今のうちに When you go and would you even turn to say" I don't love you like I did yesterday?"Well come on, come on! When you go, would you have the guts to say立ち去るとき、勇気を出して言ってくれないか？ "I don't love you like I loved you yesterday?"”もうあなたを愛していないの、あなたを愛していた昨日までのようには” I don't love you like I loved you yesterdayI don't love you like I loved you yesterday ----------------------------------------------------------------------- 「泥沼の依存関係が悲しくて、疲れてしまった。けれど、自分からは離れることができない。だから、君のほうから去って行ってくれ。」というような感じの曲なのかな。赤字のところは、やっぱりよくわからなかった。

2015.12.25

コメント(0)

発達心理学　社会的認知

・社会的認知観察学習を通して、社会的文脈を解読、理解する働き・社会的規則「禁止」と「要請」の二つのチャンネルを通して伝えられる「禁止」は道徳的規則、「要請」は自己管理、慣習的規則を主として伝える。

2015.12.25

コメント(0)

耳鼻科で処方されたお薬

・メイアクトMS錠100mg細菌による感染症の治療に用いる・ムコダイン錠250mg痰の切れをよくする出にくい鼻汁の排出を促す

2015.12.25

コメント(0)

認知神経科学に関して覚えていないこと

・PETラジオアイソトープを用いる・概日リズムをつかさどる脳の部位網膜視床下部路　視床下部の視交叉上核光刺激による概日リズムの同期　網膜第3次細胞　神経節細胞にあるメラノプシンがマスタークロック・脳波 12Hz~ β波 12~8Hz　α波4~8Hz　シータ波~4Hz　デルタ波紡錘波　14Hz程 0.5~1秒連続　振幅が小、大、小という波形を示すK複合波 0.5~1秒の緩やかな波形に続き、紡錘波が現れる

2015.12.12

コメント(0)

妊娠に伴う女性の心理的危機-1

・ガブリエル・グロジャー=チッペルトの4段階1．混乱期　妊娠12週まで身体的な変化に戸惑う急激に「成熟した女性」としてのアイデンティティを迫られる 2．適応期　妊娠12~20週自らが妊娠していること、母親になることの認識が深まる 3．焦点期　妊娠20~32週胎児が急速に発育する母親の意識が胎児に焦点化する妊娠の受容が促進される 4．予期、準備期妊娠32週～分娩子宮や乳房の膨隆、体重の増加、便秘、腹痛、不眠など様々な身体症状を呈する出産に対する不安が高まる・マタニティーブルーズ産後3~5日に発症し、分娩後6~8週の間に見られるホルモンの急激な変動により、涙もろさや憂うつ感を呈する飽くまで一過性(2週間ほど)の情動の混乱状態である・産後うつ病大うつ病の症状が2週間以上続く産後うつ病でなくても、出産後の女性には身体的・精神的な不安定さがあるため、見逃されやすい子どもの発達リスクにも大きくかかわる

2015.12.11

コメント(0)

具体的な聴き方

1．相手の話を途中で遮らない助言や指図、非難、評価などは後回しにする 2．話題を変えない相手が提示した話題は、相手にとって重要な話題である 3．道徳的判断や倫理的批判を途中ではしない 4．話し手の感情を否定しない十分に感情を表出させる話の腰を折らない何故、どのようにそのような感情なのかを察する具体的な根拠をあげて励ましたり、助言などをする 5．時間の圧力をかけない本当に時間がないのなら、むしろ、その場では聴かずに、きちんと聴きたいからこそ別の機会を設けたいという事を伝える

2015.12.11

コメント(0)

聴くときの構え

受容的な構え(set)、心構え(mental set) 但し、受容的であることは、必ずしも同意するというとことではない賛成、反対に関わらず、相手の言葉を受け入れる・選択的知覚(selective perception)を用いないこと・とにかく最後まで聴く

2015.12.11

コメント(0)

質問について

・質問するタイミング 1．反射した後に付け加えるように質問する2．相手の話が途切れた時に発する・開かれた質問をする返答が「YES」「NO」に限られるものは閉じられた質問である5W1Hで質問すると、相手に返答の幅を与えられる・話すきっかけを与える際にも開かれた質問をするex. 「昨日は、どうだった？」、「ちょっと元気なさそうじゃない、何かあったの？」

2015.12.11

コメント(0)

反射

・相槌ex.「うんうん」、「へぇ」、「そうか」、「なるほどね」、「ほんとう？」、・・・・相手が言った言葉の一部をそのまま返す・別の語句に言い換える・全体を要約して相手に返す※話し手の感情をとらえること※感情に関する言葉、語句、感情を伝える非言語チャネルにも注目し、捉えられたものはできる限り反射する

2015.12.11

コメント(0)

非言語チャネル　メモ

・話し手に近づく・50～150 cm (腕を広げたくらい)の距離をとる・話し手を顔の高さを同じにする・身体を話し手のほうに向ける・リラックスして、軽い前傾姿勢をとる・話し手の目を適度に見る・表情は一般的には微笑み・手はほとんど動かさない（手遊びなどをしない）

2015.12.11

コメント(0)

聴く　解読(decording)

メモ感情の変化に注目すること複数のチャネルからの異なったメッセージは感情の動きの現れである１．音声の解読・声の大きさ、声の強さ、声の高さ・発話の乱れ、言い間違え、吃音、言い淀み、・・・・間、沈黙※沈黙したことに説明がない限りは、不快、否定的感情を表している

2015.12.11

コメント(0)

Demonstrativeness-1

kore これ=something that are nearsore それ=something that are a little farare あれ=something that has distance between it and the speaker or the listener

2015.10.20

コメント(0)

I'm opening the room.But I have no plan today.

How is the weather over there?=sochira(over there) no otenki(whether) wa dou(how) desuka?How is the whether in Yokohama?=Yokohama no otenki wa dou desuka?

2015.10.14

コメント(0)

the inflection of an ending : Five-stage utilization(?)

Example. write=kaku かく　書くthe Stem of word : kaOriginal form: kaku Imperfective form:ka ka-nai Conjunctive form:ka ki-masu, ka i-ta, ka i-te Predicative form:ka i-ta Attributive form:ka ku-toki, ka ku-node Hypothetical form:ka ke-ba Imperative form:ka ke

2015.10.05

コメント(0)

riddle

彼女（仮）から連絡がないよー

2015.10.04

コメント(0)

4th October Sunday 2015

I went to my dentist and was pull wisdom teeth out for orthodontics.And I got a hole one more between my mouth and my nose.My "maxillary sinus" has a hole now.I feel pain even when I move . But I don't want to dose a painkiller because it makes me sleepy.My English vocabulary is poor, so I want to expand mine.Therefore I will try to remember 500 words today....Can I?

2015.10.04

コメント(0)

2nd Octber Friday Lesson

Shall we dance?=watashi to(with,together,...) odori masenka?I "do"=watashi wa do (shi)masueat=tabe (masu)drink=nomi (masu)go=iki (masu)listen=kiki (masu)watch=mi (masu)Have a nice day=yoi ichi(1) nichi(day) woHave a good dream=yoi yume(dream) wo

2015.10.02

コメント(0)

the lesson　26th Sep Sat

simple grammar N1 is A. N2 is also A. = N1 wa A desu. N2 mo A desu.Ex.Naruto is a Ninja. Sasuke is also a Ninja.

2015.09.26

コメント(0)

Today's lesson

Today's lesson-grammarare you ~?= anata wa ~desu ka(question maker)?yes, im ~=hai(yes) watashi(I) wa ~ desuno , im not ~=iie(no), watashi(I) wa ~ dewa arimasen(be not..) ex. Are you a Ninja? = anata wa Ninja desuka? yes, I am a Ninja=hai watashi wa Ninja desuno , I am not a Ninja=iie, washi wa Ninja dewa arimasen

2015.09.25

コメント(0)

Vocabulary Noun-1

teacher = senseistudent = gakuseicompany employee = kaishainbank employee = ginkouindoctor = ishanurse = kangoshiastronaut = uchuuhikoushininja=ninjasamurai=samuraigeisha = geisha

2015.09.25

コメント(0)