何人かの人のご都合を伺って、全員が空いている時間帯で、会議を開く、などのときに使う「ご都合伺いマクロ」です。
このエクセルファイルにご都合をご記入頂き、回収し、同じシートに、全員分をコピペして、「日付でソート」すると、皆様の空いている時間帯が分かります。
「氏名でソート」のマクロもおいておきます。
下図のシートには、右上にボタンをおいて、ボタンを押せば、マクロを実行するようにしていました。
「日付でソート」のマクロ
Sub 日付でソート()
Dim i As Long
Dim a As Long
Dim r As Long
Dim c As Long
Dim s As Long
a = 0
For i = 5 To 400 '＜----------------------------------------シートでの行番号
Worksheets("ご都合").Activate '---このシートでの操作
If Cells(i, "A").Value = "" Then 'A列が空欄ならば、もうiは回さない。
Exit For
End If
a = a + 1 'どの行まで、日付が入っているかを数えている。
Next i
Range(Cells(5, 1), Cells(5 + a, 10)).Select
Selection.Sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin '日付の列（A）でソートする、という指定。
With ActiveWorkbook.Worksheets("ご都合").Sort
.SetRange Range(Cells(5, 1), Cells(5 + a, 10))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'----------------------ソートした後に、日付の境目に、横線を入れる、という作業。
r = 5 '行
c = 1 '列
s = 0 'カウンタ
Range("A5").Select '最上行の日付
Do Until ActiveCell.Value = "" '選択した列を下に見て行き、空白行まで行って、カウントしている。
If ActiveCell = Cells(r + 1, c) Then 'ACが次の行と同じかどうかを判断。
ActiveCell.Offset(1).Select
s = s + 1
r = r + 1
Else: Range(ActiveCell, Cells(r, 8)).Select 'ACの下に線を引く。
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
ActiveCell.Offset(1).Select
s = 0
r = r + 1
End If
Loop
End Sub
「氏名でソート」のマクロ
Sub 氏名でソート()
Dim i As Long
Dim a As Long
a = 0
For i = 5 To 400 '＜---------------------------------------シートでの行番号
Worksheets("ご都合").Activate '---このシートでの操作となる。
If Cells(i, "A").Value = "" Then 'A列が空欄ならば、もうiは回さない。
Exit For
End If
a = a + 1
Next i
Range(Cells(5, 1), Cells(5 + a, 10)).Select
Selection.Sort Key1:=Range("H4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
With ActiveWorkbook.Worksheets("ご都合").Sort
.SetRange Range(Cells(5, 1), Cells(5 + a, 10))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
