|
|
|
2017.11.14
カテゴリ：お勉強
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 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 Next End Sub 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 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 '------------------------------------------------- '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 お気に入りの記事を「いいね！」で応援しよう
Last updated
2017.11.14 03:30:20
コメント(0) | コメントを書く
[お勉強] カテゴリの最新記事
|
