[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『FreeBusyを01で取得して、0の時間帯だけをまとめて表示したい』（estariol）
お世話になっております。
OutlookのFreeBusyで特定のアカウントの約2か月分（57日分）の予定を01表示で取得しました。
0が空き時間で、1が予定ありです。
時間帯は08:00〜19:00で、30分単位なので1日が22文字分です。
このうち、空き時間の部分だけを集めて、最終的には次のようにexcelのシートに書き込みたいと思っています。
A B C D E F 1 6月 27日 月曜日 8:00end9:00 9:30end10:30 17:00end19:00 2 6月 28日 火曜日 8:00end9:00 13:00end14:30 18:00end19:00 3 6月 29日 水曜日 8:00end9:30 13:00end14:00 18:30end19:00 （以下略）
自力ではマクロでそこまでたどり着けなくて、22文字を1文字ずつに分けて時間帯に入れてみたのですが、そこからもどうすればよいのかわかりません。
現在のコードでは次のような状態です。
A B C D E F G ... W X Y 1 8:00 8:30 9:00 9:30 ... 17:30 18:00 18:30 2 6月 27日 月曜日 0 0 1 0 ... 0 0 0 3 6月 28日 火曜日 0 0 1 1 ... 1 0 0 4 6月 29日 水曜日 0 0 0 1 ... 1 1 0 （以下略）
現在のコード
Public Sub GetFreeBusyInfo()
Dim olApp As Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim myFBInfo As String
Dim myFBInfo2 As String
Dim days(1 To 57) As Variant
Dim day As Variant
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("freebusy")
wsSheet.Activate
Set olApp = New Outlook.Application
Set myNameSpace = olApp.GetNamespace("MAPI")
Set myRecipient = myNameSpace.CreateRecipient("sample@example.com")
On Error GoTo ErrorHandler
myFBInfo = myRecipient.FreeBusy(Date, 30, False)
myFBInfo2 = myRecipient.FreeBusy(DateAdd("d", 29, Date), 30, False)
'1日分48文字が28日分つながっているので、必要な22文字分を切り出しています
days(1) = Mid(myFBInfo, 17, 22)
days(2) = Mid(myFBInfo, 65, 22)
days(3) = Mid(myFBInfo, 113, 22)
days(4) = Mid(myFBInfo, 161, 22)
days(5) = Mid(myFBInfo, 209, 22)
days(6) = Mid(myFBInfo, 257, 22)
days(7) = Mid(myFBInfo, 305, 22)
days(8) = Mid(myFBInfo, 353, 22)
days(9) = Mid(myFBInfo, 401, 22)
days(10) = Mid(myFBInfo, 449, 22)
days(11) = Mid(myFBInfo, 497, 22)
days(12) = Mid(myFBInfo, 545, 22)
days(13) = Mid(myFBInfo, 593, 22)
days(14) = Mid(myFBInfo, 641, 22)
days(15) = Mid(myFBInfo, 689, 22)
days(16) = Mid(myFBInfo, 737, 22)
days(17) = Mid(myFBInfo, 785, 22)
days(18) = Mid(myFBInfo, 833, 22)
days(19) = Mid(myFBInfo, 881, 22)
days(20) = Mid(myFBInfo, 929, 22)
days(21) = Mid(myFBInfo, 977, 22)
days(22) = Mid(myFBInfo, 1025, 22)
days(23) = Mid(myFBInfo, 1073, 22)
days(24) = Mid(myFBInfo, 1121, 22)
days(25) = Mid(myFBInfo, 1169, 22)
days(26) = Mid(myFBInfo, 1217, 22)
days(27) = Mid(myFBInfo, 1265, 22)
days(28) = Mid(myFBInfo, 1313, 22)
days(29) = Mid(myFBInfo, 1361, 22)
days(30) = Mid(myFBInfo2, 17, 22)
days(31) = Mid(myFBInfo2, 65, 22)
days(32) = Mid(myFBInfo2, 113, 22)
days(33) = Mid(myFBInfo2, 161, 22)
days(34) = Mid(myFBInfo2, 209, 22)
days(35) = Mid(myFBInfo2, 257, 22)
days(36) = Mid(myFBInfo2, 305, 22)
days(37) = Mid(myFBInfo2, 353, 22)
days(38) = Mid(myFBInfo2, 401, 22)
days(39) = Mid(myFBInfo2, 449, 22)
days(40) = Mid(myFBInfo2, 497, 22)
days(41) = Mid(myFBInfo2, 545, 22)
days(42) = Mid(myFBInfo2, 593, 22)
days(43) = Mid(myFBInfo2, 641, 22)
days(44) = Mid(myFBInfo2, 689, 22)
days(45) = Mid(myFBInfo2, 737, 22)
days(46) = Mid(myFBInfo2, 785, 22)
days(47) = Mid(myFBInfo2, 833, 22)
days(48) = Mid(myFBInfo2, 881, 22)
days(49) = Mid(myFBInfo2, 929, 22)
days(50) = Mid(myFBInfo2, 977, 22)
days(51) = Mid(myFBInfo2, 1025, 22)
days(52) = Mid(myFBInfo2, 1073, 22)
days(53) = Mid(myFBInfo2, 1121, 22)
days(54) = Mid(myFBInfo2, 1169, 22)
days(55) = Mid(myFBInfo2, 1217, 22)
days(56) = Mid(myFBInfo2, 1265, 22)
days(57) = Mid(myFBInfo2, 1313, 22)
Application.ScreenUpdating = False
With wsSheet
.Range("A2").CurrentRegion.Clear
.Cells(1, 4).Value = "8:00"
.Cells(1, 5).Value = "8:30"
.Cells(1, 6).Value = "9:00"
.Cells(1, 7).Value = "9:30"
.Cells(1, 8).Value = "10:00"
.Cells(1, 9).Value = "10:30"
.Cells(1, 10).Value = "11:00"
.Cells(1, 11).Value = "11:30"
.Cells(1, 12).Value = "12:00"
.Cells(1, 13).Value = "12:30"
.Cells(1, 14).Value = "13:00"
.Cells(1, 15).Value = "13:30"
.Cells(1, 16).Value = "14:00"
.Cells(1, 17).Value = "14:30"
.Cells(1, 18).Value = "15:00"
.Cells(1, 19).Value = "15:30"
.Cells(1, 20).Value = "16:00"
.Cells(1, 21).Value = "16:30"
.Cells(1, 22).Value = "17:00"
.Cells(1, 23).Value = "17:30"
.Cells(1, 24).Value = "18:00"
.Cells(1, 25).Value = "18:30"
.Cells(2, 1).Value = Format(Date, "m月")
.Cells(2, 2).Value = Format(Date, "d日")
.Cells(2, 3).Value = Format(Date, "aaaa")
.Cells(3, 1).Value = Format(DateAdd("d", 1, Date), "m月")
.Cells(3, 2).Value = Format(DateAdd("d", 1, Date), "d日")
.Cells(3, 3).Value = Format(DateAdd("d", 1, Date), "aaaa")
.Cells(4, 1).Value = Format(DateAdd("d", 2, Date), "m月")
.Cells(4, 2).Value = Format(DateAdd("d", 2, Date), "d日")
.Cells(4, 3).Value = Format(DateAdd("d", 2, Date), "aaaa")
.Cells(5, 1).Value = Format(DateAdd("d", 3, Date), "m月")
.Cells(5, 2).Value = Format(DateAdd("d", 3, Date), "d日")
.Cells(5, 3).Value = Format(DateAdd("d", 3, Date), "aaaa")
.Cells(6, 1).Value = Format(DateAdd("d", 4, Date), "m月")
.Cells(6, 2).Value = Format(DateAdd("d", 4, Date), "d日")
.Cells(6, 3).Value = Format(DateAdd("d", 4, Date), "aaaa")
.Cells(7, 1).Value = Format(DateAdd("d", 5, Date), "m月")
.Cells(7, 2).Value = Format(DateAdd("d", 5, Date), "d日")
.Cells(7, 3).Value = Format(DateAdd("d", 5, Date), "aaaa")
.Cells(8, 1).Value = Format(DateAdd("d", 6, Date), "m月")
.Cells(8, 2).Value = Format(DateAdd("d", 6, Date), "d日")
.Cells(8, 3).Value = Format(DateAdd("d", 6, Date), "aaaa")
.Cells(9, 1).Value = Format(DateAdd("d", 7, Date), "m月")
.Cells(9, 2).Value = Format(DateAdd("d", 7, Date), "d日")
.Cells(9, 3).Value = Format(DateAdd("d", 7, Date), "aaaa")
.Cells(10, 1).Value = Format(DateAdd("d", 8, Date), "m月")
.Cells(10, 2).Value = Format(DateAdd("d", 8, Date), "d日")
.Cells(10, 3).Value = Format(DateAdd("d", 8, Date), "aaaa")
.Cells(11, 1).Value = Format(DateAdd("d", 9, Date), "m月")
.Cells(11, 2).Value = Format(DateAdd("d", 9, Date), "d日")
.Cells(11, 3).Value = Format(DateAdd("d", 9, Date), "aaaa")
.Cells(12, 1).Value = Format(DateAdd("d", 10, Date), "m月")
.Cells(12, 2).Value = Format(DateAdd("d", 10, Date), "d日")
.Cells(12, 3).Value = Format(DateAdd("d", 10, Date), "aaaa")
.Cells(13, 1).Value = Format(DateAdd("d", 11, Date), "m月")
.Cells(13, 2).Value = Format(DateAdd("d", 11, Date), "d日")
.Cells(13, 3).Value = Format(DateAdd("d", 11, Date), "aaaa")
.Cells(14, 1).Value = Format(DateAdd("d", 12, Date), "m月")
.Cells(14, 2).Value = Format(DateAdd("d", 12, Date), "d日")
.Cells(14, 3).Value = Format(DateAdd("d", 12, Date), "aaaa")
.Cells(15, 1).Value = Format(DateAdd("d", 13, Date), "m月")
.Cells(15, 2).Value = Format(DateAdd("d", 13, Date), "d日")
.Cells(15, 3).Value = Format(DateAdd("d", 13, Date), "aaaa")
.Cells(16, 1).Value = Format(DateAdd("d", 14, Date), "m月")
.Cells(16, 2).Value = Format(DateAdd("d", 14, Date), "d日")
.Cells(16, 3).Value = Format(DateAdd("d", 14, Date), "aaaa")
.Cells(17, 1).Value = Format(DateAdd("d", 15, Date), "m月")
.Cells(17, 2).Value = Format(DateAdd("d", 15, Date), "d日")
.Cells(17, 3).Value = Format(DateAdd("d", 15, Date), "aaaa")
.Cells(18, 1).Value = Format(DateAdd("d", 16, Date), "m月")
.Cells(18, 2).Value = Format(DateAdd("d", 16, Date), "d日")
.Cells(18, 3).Value = Format(DateAdd("d", 16, Date), "aaaa")
.Cells(19, 1).Value = Format(DateAdd("d", 17, Date), "m月")
.Cells(19, 2).Value = Format(DateAdd("d", 17, Date), "d日")
.Cells(19, 3).Value = Format(DateAdd("d", 17, Date), "aaaa")
.Cells(20, 1).Value = Format(DateAdd("d", 18, Date), "m月")
.Cells(20, 2).Value = Format(DateAdd("d", 18, Date), "d日")
.Cells(20, 3).Value = Format(DateAdd("d", 18, Date), "aaaa")
.Cells(21, 1).Value = Format(DateAdd("d", 19, Date), "m月")
.Cells(21, 2).Value = Format(DateAdd("d", 19, Date), "d日")
.Cells(21, 3).Value = Format(DateAdd("d", 19, Date), "aaaa")
.Cells(22, 1).Value = Format(DateAdd("d", 20, Date), "m月")
.Cells(22, 2).Value = Format(DateAdd("d", 20, Date), "d日")
.Cells(22, 3).Value = Format(DateAdd("d", 20, Date), "aaaa")
.Cells(23, 1).Value = Format(DateAdd("d", 21, Date), "m月")
.Cells(23, 2).Value = Format(DateAdd("d", 21, Date), "d日")
.Cells(23, 3).Value = Format(DateAdd("d", 21, Date), "aaaa")
.Cells(24, 1).Value = Format(DateAdd("d", 22, Date), "m月")
.Cells(24, 2).Value = Format(DateAdd("d", 22, Date), "d日")
.Cells(24, 3).Value = Format(DateAdd("d", 22, Date), "aaaa")
.Cells(25, 1).Value = Format(DateAdd("d", 23, Date), "m月")
.Cells(25, 2).Value = Format(DateAdd("d", 23, Date), "d日")
.Cells(25, 3).Value = Format(DateAdd("d", 23, Date), "aaaa")
.Cells(26, 1).Value = Format(DateAdd("d", 24, Date), "m月")
.Cells(26, 2).Value = Format(DateAdd("d", 24, Date), "d日")
.Cells(26, 3).Value = Format(DateAdd("d", 24, Date), "aaaa")
.Cells(27, 1).Value = Format(DateAdd("d", 25, Date), "m月")
.Cells(27, 2).Value = Format(DateAdd("d", 25, Date), "d日")
.Cells(27, 3).Value = Format(DateAdd("d", 25, Date), "aaaa")
.Cells(28, 1).Value = Format(DateAdd("d", 26, Date), "m月")
.Cells(28, 2).Value = Format(DateAdd("d", 26, Date), "d日")
.Cells(28, 3).Value = Format(DateAdd("d", 26, Date), "aaaa")
.Cells(29, 1).Value = Format(DateAdd("d", 27, Date), "m月")
.Cells(29, 2).Value = Format(DateAdd("d", 27, Date), "d日")
.Cells(29, 3).Value = Format(DateAdd("d", 27, Date), "aaaa")
.Cells(30, 1).Value = Format(DateAdd("d", 28, Date), "m月")
.Cells(30, 2).Value = Format(DateAdd("d", 28, Date), "d日")
.Cells(30, 3).Value = Format(DateAdd("d", 28, Date), "aaaa")
.Cells(31, 1).Value = Format(DateAdd("d", 29, Date), "m月")
.Cells(31, 2).Value = Format(DateAdd("d", 29, Date), "d日")
.Cells(31, 3).Value = Format(DateAdd("d", 29, Date), "aaaa")
.Cells(32, 1).Value = Format(DateAdd("d", 30, Date), "m月")
.Cells(32, 2).Value = Format(DateAdd("d", 30, Date), "d日")
.Cells(32, 3).Value = Format(DateAdd("d", 30, Date), "aaaa")
.Cells(33, 1).Value = Format(DateAdd("d", 31, Date), "m月")
.Cells(33, 2).Value = Format(DateAdd("d", 31, Date), "d日")
.Cells(33, 3).Value = Format(DateAdd("d", 31, Date), "aaaa")
.Cells(34, 1).Value = Format(DateAdd("d", 32, Date), "m月")
.Cells(34, 2).Value = Format(DateAdd("d", 32, Date), "d日")
.Cells(34, 3).Value = Format(DateAdd("d", 32, Date), "aaaa")
.Cells(35, 1).Value = Format(DateAdd("d", 33, Date), "m月")
.Cells(35, 2).Value = Format(DateAdd("d", 33, Date), "d日")
.Cells(35, 3).Value = Format(DateAdd("d", 33, Date), "aaaa")
.Cells(36, 1).Value = Format(DateAdd("d", 34, Date), "m月")
.Cells(36, 2).Value = Format(DateAdd("d", 34, Date), "d日")
.Cells(36, 3).Value = Format(DateAdd("d", 34, Date), "aaaa")
.Cells(37, 1).Value = Format(DateAdd("d", 35, Date), "m月")
.Cells(37, 2).Value = Format(DateAdd("d", 35, Date), "d日")
.Cells(37, 3).Value = Format(DateAdd("d", 35, Date), "aaaa")
.Cells(38, 1).Value = Format(DateAdd("d", 36, Date), "m月")
.Cells(38, 2).Value = Format(DateAdd("d", 36, Date), "d日")
.Cells(38, 3).Value = Format(DateAdd("d", 36, Date), "aaaa")
.Cells(39, 1).Value = Format(DateAdd("d", 37, Date), "m月")
.Cells(39, 2).Value = Format(DateAdd("d", 37, Date), "d日")
.Cells(39, 3).Value = Format(DateAdd("d", 37, Date), "aaaa")
.Cells(40, 1).Value = Format(DateAdd("d", 38, Date), "m月")
.Cells(40, 2).Value = Format(DateAdd("d", 38, Date), "d日")
.Cells(40, 3).Value = Format(DateAdd("d", 38, Date), "aaaa")
.Cells(41, 1).Value = Format(DateAdd("d", 39, Date), "m月")
.Cells(41, 2).Value = Format(DateAdd("d", 39, Date), "d日")
.Cells(41, 3).Value = Format(DateAdd("d", 39, Date), "aaaa")
.Cells(42, 1).Value = Format(DateAdd("d", 40, Date), "m月")
.Cells(42, 2).Value = Format(DateAdd("d", 40, Date), "d日")
.Cells(42, 3).Value = Format(DateAdd("d", 40, Date), "aaaa")
.Cells(43, 1).Value = Format(DateAdd("d", 41, Date), "m月")
.Cells(43, 2).Value = Format(DateAdd("d", 41, Date), "d日")
.Cells(43, 3).Value = Format(DateAdd("d", 41, Date), "aaaa")
.Cells(44, 1).Value = Format(DateAdd("d", 42, Date), "m月")
.Cells(44, 2).Value = Format(DateAdd("d", 42, Date), "d日")
.Cells(44, 3).Value = Format(DateAdd("d", 42, Date), "aaaa")
.Cells(45, 1).Value = Format(DateAdd("d", 43, Date), "m月")
.Cells(45, 2).Value = Format(DateAdd("d", 43, Date), "d日")
.Cells(45, 3).Value = Format(DateAdd("d", 43, Date), "aaaa")
.Cells(46, 1).Value = Format(DateAdd("d", 44, Date), "m月")
.Cells(46, 2).Value = Format(DateAdd("d", 44, Date), "d日")
.Cells(46, 3).Value = Format(DateAdd("d", 44, Date), "aaaa")
.Cells(47, 1).Value = Format(DateAdd("d", 45, Date), "m月")
.Cells(47, 2).Value = Format(DateAdd("d", 45, Date), "d日")
.Cells(47, 3).Value = Format(DateAdd("d", 45, Date), "aaaa")
.Cells(48, 1).Value = Format(DateAdd("d", 46, Date), "m月")
.Cells(48, 2).Value = Format(DateAdd("d", 46, Date), "d日")
.Cells(48, 3).Value = Format(DateAdd("d", 46, Date), "aaaa")
.Cells(49, 1).Value = Format(DateAdd("d", 47, Date), "m月")
.Cells(49, 2).Value = Format(DateAdd("d", 47, Date), "d日")
.Cells(49, 3).Value = Format(DateAdd("d", 47, Date), "aaaa")
.Cells(50, 1).Value = Format(DateAdd("d", 48, Date), "m月")
.Cells(50, 2).Value = Format(DateAdd("d", 48, Date), "d日")
.Cells(50, 3).Value = Format(DateAdd("d", 48, Date), "aaaa")
.Cells(51, 1).Value = Format(DateAdd("d", 49, Date), "m月")
.Cells(51, 2).Value = Format(DateAdd("d", 49, Date), "d日")
.Cells(51, 3).Value = Format(DateAdd("d", 49, Date), "aaaa")
.Cells(52, 1).Value = Format(DateAdd("d", 50, Date), "m月")
.Cells(52, 2).Value = Format(DateAdd("d", 50, Date), "d日")
.Cells(52, 3).Value = Format(DateAdd("d", 50, Date), "aaaa")
.Cells(53, 1).Value = Format(DateAdd("d", 51, Date), "m月")
.Cells(53, 2).Value = Format(DateAdd("d", 51, Date), "d日")
.Cells(53, 3).Value = Format(DateAdd("d", 51, Date), "aaaa")
.Cells(54, 1).Value = Format(DateAdd("d", 52, Date), "m月")
.Cells(54, 2).Value = Format(DateAdd("d", 52, Date), "d日")
.Cells(54, 3).Value = Format(DateAdd("d", 52, Date), "aaaa")
.Cells(55, 1).Value = Format(DateAdd("d", 53, Date), "m月")
.Cells(55, 2).Value = Format(DateAdd("d", 53, Date), "d日")
.Cells(55, 3).Value = Format(DateAdd("d", 53, Date), "aaaa")
.Cells(56, 1).Value = Format(DateAdd("d", 54, Date), "m月")
.Cells(56, 2).Value = Format(DateAdd("d", 54, Date), "d日")
.Cells(56, 3).Value = Format(DateAdd("d", 54, Date), "aaaa")
.Cells(57, 1).Value = Format(DateAdd("d", 55, Date), "m月")
.Cells(57, 2).Value = Format(DateAdd("d", 55, Date), "d日")
.Cells(57, 3).Value = Format(DateAdd("d", 55, Date), "aaaa")
.Cells(58, 1).Value = Format(DateAdd("d", 56, Date), "m月")
.Cells(58, 2).Value = Format(DateAdd("d", 56, Date), "d日")
.Cells(58, 3).Value = Format(DateAdd("d", 56, Date), "aaaa")
End With
Dim i As Long
Const mylen As Long = 22
Dim InContactCount As Long
Dim wd() As String
InContactCount = 2
For Each day In days
ReDim wd(mylen)
For i = 1 To mylen
wd(i) = Mid(day, i, 1)
Cells(InContactCount, i + 3) = wd(i)
Next i
InContactCount = InContactCount + 1
Next day
Dim lRow As Long
Dim j As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For j = lRow To 2 Step -1
Select Case Cells(j, 3).Value
Case "日曜日"
Cells(j, 3).EntireRow.Delete
Case "土曜日"
Cells(j, 3).EntireRow.Delete
End Select
Next j
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Cannot access the information. "
End Sub
Daysのところや、月、日、曜日のところなども、もっとすっきりさせたいのですが力及ばず…。
土日はカットしたいのですが、祝日は込みで構いません。
欲を言えばマクロで計算して結果だけ書き出せれば最高ですが、現在の01を書き出したシートを使って結果を別シートに書き込むのでも大丈夫です。
スクリーンリーダーで読ませてわかりやすい形にしたいので、視覚的な解決法は使えません。
うまく説明できているかわかりませんが、皆様のお知恵を貸していただけましたら大変ありがたく存じます。どうぞよろしくお願いいたします。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
一から考えるのはしんどいので、
＞ myFBInfo = myRecipient.FreeBusy(Date, 30, False)
＞ myFBInfo2 = myRecipient.FreeBusy(DateAdd("d", 29, Date), 30, False)
↑
そこで取得できた2つの文字列のサンプルを掲示して貰えませんか？
(当方は、そこからどうすればいいか考えますが・・)
（半平太） 2022/06/27(月) 16:53
しかし、どうしてもそうしたテキストにしたいというのであれば、変換するよりないですね。
・1を消去したうえで、
・一行ごとに、SpecialCellsで定数が入っているセル範囲を取得し、
・その各Areaごとに、開始時刻、終了時刻（Areaの最後のセルの時刻+30分後）を取り出す
ことでできると思います。
（γ） 2022/06/27(月) 17:01
Function Sample(FreebusyString As String) As String
Const T_BEGIN As Date = "8:00"
Const T_UNIT As Date = "0:30"
Dim str1 As String
Dim str2 As String
Dim i As Long
For i = 1 To Len(FreebusyString)
If Mid(FreebusyString, i, 1) = 0 Then
If str1 = "" Then
str1 = Format(T_BEGIN + T_UNIT * (i - 1), "h:mm") & "end"
End If
Else
If str1 <> "" Then
str2 = str2 & str1 & Format(T_BEGIN + T_UNIT * (i - 1), "h:mm") & " "
str1 = ""
End If
End If
Next i
If str1 <> "" Then
str2 = str2 & str1 & Format(T_BEGIN + T_UNIT * (i - 1), "h:mm")
End If
Sample = str2
End Function
（作業員） 2022/06/27(月) 18:52
問い合わせに対する回答がないのですが、とりあえず回答しておきます。 よくチェックしていないので、ミスがあるかもしれません。 バックアップを取って確認してみて下さい。
追加したのは、
Call 空き時間帯の抽出 ' ■追加部分
のプロシージャです。
その他の部分も、ループを使って手を入れてみました。
なお、空き情報だけが必要なので、 1の時は書き込まないように変更していますので、注意してください。
=========== ここから
Dim wsSheet As Worksheet
Public Sub GetFreeBusyInfo()
Const mylen As Long = 22
Dim olApp As Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim myFBInfo As String
Dim myFBInfo2 As String
Dim day As Variant
Dim k As Long
Dim d As Date
Dim d1 As Long
Dim d2 As Long
Dim i As Long
Dim r As Long
Dim s As String
Set wsSheet = ThisWorkbook.Worksheets("freebusy")
Set olApp = New Outlook.Application
Set myNameSpace = olApp.GetNamespace("MAPI")
Set myRecipient = myNameSpace.CreateRecipient("sample@example.com")
On Error GoTo ErrorHandler
myFBInfo = myRecipient.FreeBusy(Date, 30, False)
myFBInfo2 = myRecipient.FreeBusy(DateAdd("d", 29, Date), 30, False)
d1 = Len(myFBInfo) / 48
d2 = Len(myFBInfo2) / 48
ReDim days(1 To d1+d2) As Variant
'それぞれの日の空き情報文字列(11時間分)
For k = 1 To d1
days(k) = Mid(myFBInfo, 48 * (k - 1) + 17, 22)
Next
For k = d1 + 1 To d1 + d2
days(k) = Mid(myFBInfo, 48 * (k - d1 - 1) + 17, 22)
Next
Application.ScreenUpdating = False
With wsSheet
.Range("A2").CurrentRegion.Clear
'時刻見出しの作成
For k = 1 To 23
.Cells(1, k + 3).Value = Format(TimeSerial(8, 0, 0) + (k - 1) * TimeSerial(0, 30, 0), "h:mm")
Next
'日付見出しの作成
For k = 1 To d1 + d2
d = DateAdd("d", (k - 1), Date)
.Cells(k + 1, 1).Value = Format(d, "m月")
.Cells(k + 1, 2).Value = Format(d, "d日")
.Cells(k + 1, 3).Value = Format(d, "aaaa")
Next
'空き:0の時だけ、各セルに書き込む
r = 2
For Each day In days
For i = 1 To mylen
s = Mid(day, i, 1)
If s = "0" Then
.Cells(r, i + 3) = s
End If
Next i
r = r + 1
Next
'土日のデータを削除
Dim lRow As Long
Dim j As Long
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
For j = lRow To 2 Step -1
Select Case .Cells(j, 3).Value
Case "日曜日", "土曜日"
.Cells(j, 3).EntireRow.Delete
End Select
Next
End With
Call 空き時間帯の抽出 ' ■追加部分
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Cannot access the information. "
End Sub
Function 空き時間帯の抽出()
Dim lastRow As Long, lastCol As Long
Dim rng As Range
Dim r As Range
Dim ar As Range
Dim pos As Long
Dim k As Long
With wsSheet
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
'書き込み先の書式を設定
.Cells(2, 27).Resize(50, 10 * 2).NumberFormatLocal = "h:mm"
'空き時間帯の見出し(最大10個とした。要調整）
For k = 1 To 10
.Cells(1, 27).Offset(, 2 * (k - 1)) = "空き" & k
Next
'空き時間の開始時刻と終了時刻を書き込み
Set rng = .Range("D2", .Cells(lastRow, lastCol - 1))
For Each r In rng.Rows
pos = 27
For Each ar In r.SpecialCells(xlCellTypeConstants).Areas
.Cells(r.Row, pos) = .Cells(1, ar(1).Column).Value
.Cells(r.Row, pos + 1) = .Cells(1, ar(ar.Count).Column + 1).Value
pos = pos + 2
Next
Next
End With
End Function
=========== ここまで
（γ） 2022/06/27(月) 21:16
〉半平太様
1日分（8:00-19:00）を切り出したものの２日分です。
MyFBInfoとMyFBInfo2は対象の日付が違うだけ（当日から28日分と29日後から28日分）なので、これでよろしいでしょうか？
0010011111011111110000
0011111111000111000000
よろしくお願いいたします。
（estariol） 2022/06/28(火) 08:31
Sub Sample2()
Dim myWb As Workbook
Dim myWs As Worksheet
Dim myFreeBusy() As String
Dim myVar1() As String
Dim myVar2() As Variant
Dim myDate As Date
Dim myDaysCount As Long
Dim iDate As Date
Dim i As Long, j As Long, k As Long
Set myWb = ThisWorkbook
Set myWs = myWb.Worksheets("freebusy")
myDate = Date
myDaysCount = 57
On Error GoTo ErrorHandler
myFreeBusy = GetFreebusy01("sample@example.com", "8:00", "19:00", myDaysCount)
ReDim myVar1(1 To 3, 1 To myDaysCount)
ReDim myVar2(1 To myDaysCount)
For i = LBound(myVar1, 2) To UBound(myVar1, 2)
iDate = DateAdd("d", i - LBound(myVar1, 2), myDate)
If Weekday(iDate, vbSaturday) > 2 Then
j = j + 1
myVar1(1, j) = Format(iDate, "m月")
myVar1(2, j) = Format(iDate, "d日")
myVar1(3, j) = Format(iDate, "aaaa")
myVar2(j) = Split(Sample(myFreeBusy(i)))
End If
Next
ReDim Preserve myVar1(1 To 3, 1 To j)
ReDim Preserve myVar2(1 To j)
With myWs
.Activate
With .Cells(1, 1)
Application.ScreenUpdating = False
.CurrentRegion.ClearContents
.Resize(UBound(myVar1, 2), UBound(myVar1, 1)).Value = Application.Transpose(myVar1)
For k = LBound(myVar2) To UBound(myVar2)
.Resize(, UBound(myVar2(k)) + 1).Offset(k - 1, UBound(myVar1, 1)).Value = myVar2(k)
Next
Application.ScreenUpdating = True
End With
End With
Exit Sub
ErrorHandler:
MsgBox "Cannot access the information. "
End Sub
Function GetFreebusy01(MailAddress As String, BeginTime As String, EndTime As String, DaysCount As Long) As String()
Dim olApp As Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim myFBInfo As String
Dim myVar() As String
Dim Bt As Long
Dim Et As Long
Dim i As Long
Set olApp = New Outlook.Application
Set myNameSpace = olApp.GetNamespace("MAPI")
Set myRecipient = myNameSpace.CreateRecipient(MailAddress)
ReDim myVar(1 To DaysCount)
Bt = TimeValue(BeginTime) * 48 + 1
Et = (TimeValue(EndTime) - TimeValue(BeginTime)) * 48
For i = LBound(myVar) To UBound(myVar)
myFBInfo = myRecipient.FreeBusy(DateAdd("d", i - LBound(myVar), Date), 1, False)
myVar(i) = Mid(myFBInfo, Bt, Et)
Next
GetFreebusy01 = myVar
End Function
（作業員） 2022/06/28(火) 11:15
お二人のご提案をそれぞれ試させていただいたところ、どちらもうまく行きました！
比較することで自分の間違いも見つけることができ、大変勉強になりました。
初めて使う機能も多いので、よく理解して使わせていただきたいと思います。
本当にありがとうございました。
半平太様もお気にかけていただき、ありがとうございます！
（estariol） 2022/06/28(火) 13:42
Function Sample(FreebusyString As String, BeginTime As String, UnitTime As String) As String()
Dim T_Begin As Date
Dim T_Unit As Date
Dim var() As String
Dim i As Long, bt As Long, et As Long
ReDim var(0): var(0) = "BUSY"
T_Begin = TimeValue(BeginTime)
T_Unit = TimeValue(UnitTime)
Do
bt = InStr(et + 1, FreebusyString, "0")
If bt = 0 Then Exit Do
et = InStr(bt + 1, FreebusyString, "1")
If et = 0 Then et = Len(FreebusyString) + 1
ReDim Preserve var(i)
var(i) = Format(T_Begin + (bt - 1) * T_Unit, "h:mm") & "end" & _
Format(T_Begin + (et - 1) * T_Unit, "h:mm")
i = i + 1
Loop
Sample = var
End Function
Sampleを根本的に見直しました。
Sample2のここはこう直してください。
myVar2(j) = Sample(myFreeBusy(i),"8:00","0:30")
（作業員） 2022/06/28(火) 14:30
できました！追加の質問にまで答えてくださり、本当に助かりました。
ありがとうございます。
（estariol） 2022/06/28(火) 15:45
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.