|
|
|
2017.11.19
カテゴリ：お勉強
前回から変わってないかも
Option Explicit #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 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 If End Sub Sub 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 Next End Sub Sub 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 Next End Sub Sub 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 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 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 If End Sub Sub 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 Next End Sub Sub 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 Next End Sub Sub 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
'============================= userform1 Option Explicit Private 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 = ActiveCell End Sub Private Sub CommandButton1_Click() ActiveCell.Interior.Color = 5296274 '緑 Unload Me End Sub Private 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 Me End Sub Private Sub CommandButton3_Click() With ActiveCell.Interior .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.499984740745262 End With Unload Me End Sub Private Sub CommandButton4_Click() End '終了 End Sub Private 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 Sub Private 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 '============================userform2 Option Explicit Private 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 Hide End Sub 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 お気に入りの記事を「いいね！」で応援しよう
Last updated
2017.11.19 23:26:29
コメント(0) | コメントを書く
[お勉強] カテゴリの最新記事
|
