スキルアップ・問題解決なら、モーグにおまかせ！

お世話になっています。
アウトルック予定表に登録されているタイトルと本文をエクセルシートの該当の日付に転記していきたいのですが…
エクセルシートの該当の日付を探して予定表の内容を転記させるのがわからない点
２行ごとに下に転記させていく点
がうまくいきません。
 
・アウトルックの個々の予定表には下記のように入力されています。
　例）10月1日の場合
　タイトル欄：タイトル１
　本文欄：３人
 
・エクセルシートは下記のような形です。
 
   　A　　　　　　B
　　　　 A社
1　10月1日　 タイトル１
2    　　　　３人
3　10月2日    
4    
5　10月3日　　　タイトル２
6　　　　　　　４人
7　　　　　　　タイトル３
8　　　　　　　１人
9 10月4日    
10    
11 10月5日　　タイトル３
12　　　　　　　２人
 
・下記が色々と参考しながら作成したコードで実行はされますが上記の２点がわからず該当のエクセルシートの表にうまく当てはめることができません。
 
Sub Outlookの予定表をエクセルシートへ転記()
 
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Folder
    Dim olConItems As Outlook.Items
    Dim olItem As AppointmentItem
     
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim lnContactCount As Long
    Dim strDummy As String
     
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets(1)
    wsSheet.Activate
     
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
    Set olConItems = olFolder.Items
    lnContactCount = 2
     
    Dim objAppt As AppointmentItem
    Dim strStart As String
    Dim strEnd As String
     
    strStart = Format("2022/10/1", "yyyy/mm/dd")
    strEnd = Format("2022/10/7", "yyyy/mm/dd")
    strEnd = DateAdd("d", 1, strEnd)
      
    Set olItem = olConItems.Find("[End] < """ & strEnd & """ AND [Start] >= """ & strStart & """")
     
    While TypeName(olItem) = "AppointmentItem"
        If olItem.Start >= strStart And olItem.End < strEnd Then
            With olItem
                Cells(lnContactCount, 2).Value = .Subject
                Cells(lnContactCount + 1, 2).Value = .Body
            End With
            lnContactCount = lnContactCount + 1
        End If
        Set olItem = olConItems.FindNext
    Wend
      
    Set olItem = Nothing
    Set olConItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
         
End Sub
[/code][/quote]
 
うまくエクセルの表に転記できずお手上げ状態です。
勉強不足でわかっていない点多々あるかと思いますがアドバイスお願いいたします。

    While TypeName(olItem) = "AppointmentItem"
        If olItem.Start >= strStart And olItem.End < strEnd Then
            With olItem
                Cells(lnContactCount, 2).Value = .Subject
                Cells(lnContactCount + 1, 2).Value = .Body
            End With
            lnContactCount = lnContactCount + 1
        End If
        Set olItem = olConItems.FindNext
    Wend

    While TypeName(olItem) = "AppointmentItem"
        If olItem.Start >= strStart And olItem.End < strEnd Then
            With olItem
                Cells(lnContactCount, 1).Value = .Start
                Cells(lnContactCount, 2).Value = .Subject
                Cells(lnContactCount + 1, 2).Value = .Body
            End With
            lnContactCount = lnContactCount + 1
        End If
        Set olItem = olConItems.FindNext
    Wend

一応、参考になる情報も載せておきますね。
https://extan.jp/?p=1663

引用:
アウトルック予定表に登録されているタイトルと本文を
エクセルシートの該当の日付に転記していきたい

引用:
エクセルシートの該当の日付を探して予定表の内容を転記させる

引用:
strStart = Format("2022/10/1", "yyyy/mm/dd")
strEnd = Format("2022/10/7", "yyyy/mm/dd")

動作確認していないので恐縮ですが、メモします。
 
olItem.Start ,olItem.Endの型を調べて下さい。
たぶんDate型だろうと思います（そうでなければ、CDateでDate型に変換します）。
さらにその整数部分（日付部分）だけをとって（最初からCLngでもよいかも）、
シートのA列を対象に、
Application.Matchで検索すれば日付照合は可能です。
（第三引数は0を指定）
 
なお、例示では、
10月3日だけが2件書き込めるように見えますが、
あらかじめ件数が分かるわけはないので、そのあたりが疑問です。
skさんがご指摘のことを私も感じました。
 
・複数件数あれば、右の列に追記するような方式にするか、
・予め日付を書くのはやめて、開始日等自体を書き出す方式にするか
でしょうか。ご検討ください。

みなさまありがとうございます。早速たくさんの方からアドバイスいただき助かります。
 
エクセルシートは下記のようなイメージで先に作成しておかなければならない仕様です。
日付を検索し該当の予定表がある場合のみ転記し、無い場合はそのまま空欄になります。
（ある場合、１日に２件３件となる場合もあり、下方向に転記させる形にしたいのですが、何件あるかはご指摘の通りわからないのでとりあえず２件分の枠を作成しましたが３件以上の場合どう転記させたらいいかも悩んでいます。）
 
 

	A	　　　　B
1		　　　A社
2	2022/10/1	
3		
4		
5		
6	2022/10/2	
7		
8		
9		
10	2022/10/3	
11		
12		
13		
14	2022/10/4	
15		
16		
17		
18	2022/10/5	
19		
20		
21		
22	2022/10/6	
23		
24		
25		
26	2022/10/7	
27		
28		
29		

Sub Outlookの予定表をエクセルシートへ転記()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Folder
    Dim olConItems As Outlook.Items
    Dim olItem  As AppointmentItem
    
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim lnContactCount As Long
    Dim strDummy As String
    
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets(1)
        
    wsSheet.Activate
    
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
    Set olConItems = olFolder.Items
    
    lnContactCount = 2
    
    Dim objAppt As AppointmentItem
    Dim strStart As String
    Dim strEnd As String
    
    strStart = Format("2022/10/01", "yyyy/mm/dd")
    strEnd = Format("2022/10/07", "yyyy/mm/dd")
    strEnd = DateAdd("d", 1, strEnd)
  
  
    Set olItem = olConItems.Find("[End] < """ & strEnd & """ AND [Start] >= """ & strStart & """")
    
    While TypeName(olItem) = "AppointmentItem"
        If olItem.Start >= strStart And olItem.End < strEnd Then
            If Application.Match(strStart, wsSheet.Cells("A2:A30"), 0) Then
            
             With olItem
                Cells(lnContactCount, 1).Value = .Start
                Cells(lnContactCount, 2).Value = .Subject
                Cells(lnContactCount + 1, 2).Value = .Body
             End With
            lnContactCount = lnContactCount + 1
           End If
        End If
        Set olItem = olConItems.FindNext
    Wend
      
    Set olItem = Nothing
    Set olConItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
  
End Sub

前回の発言で書いた方針に沿って、以下の前提でコードを作成してみました。
 
・A列の日付は、行を空けずに連続して書いておき（連続していなくても可）、
・該当する件名と、本文をB列、C列に書き込みます。
・同日に別のデータがあれば、D,E列に追記し、
・さらにデータがあれば、その右に追記する
という前提で、コードを作ってみました。
 
そちらでコードを作成する際の参考にしてください。
 

Sub Outlookの予定表をエクセルシートへ転記()

   Dim olApp As Outlook.Application
   Dim olNamespace As Outlook.Namespace
   Dim olFolder As Folder
   Dim olConItems As Outlook.Items
   Dim olItem As AppointmentItem

   Dim wbBook As Workbook
   Dim ws As Worksheet
   Dim pos As Variant
   Dim strDummy As String

   Set wbBook = ThisWorkbook
   Set ws = wbBook.Worksheets(1)
   ws.Activate

   Set olApp = New Outlook.Application
   Set olNamespace = olApp.GetNamespace("MAPI")
   Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
   Set olConItems = olFolder.Items

   Dim objAppt As AppointmentItem
   Dim strStart As String
   Dim strEnd As String

   strStart = "2022/10/20"         '"yyyy/mm/dd"形式で指定 ■要修正
   strEnd = "2022/10/31"           '■要修正
   strEnd = DateAdd("d", 1, strEnd)  'そのままにしています

   Set olItem = olConItems.Find("[End] < """ & strEnd & """ AND [Start] >= """ & strStart & """")

   While TypeName(olItem) = "AppointmentItem"
      If olItem.Start >= strStart And olItem.End < strEnd Then
         With olItem
            pos = Application.Match(CLng(olItem.Start), ws.Columns(1), 0)
            If Not IsError(pos) Then
              ws.Cells(pos, Columns.Count).End(xlToLeft).Offset(0, 1).Value = .Subject
              ws.Cells(pos, Columns.Count).End(xlToLeft).Offset(0, 1).Value = .Body
            Else
              MsgBox olItem.Start & "の日付がマッチしませんでした"
            End If
         End With
      End If
      Set olItem = olConItems.FindNext
   Wend

   Set olItem = Nothing
   Set olConItems = Nothing
   Set olFolder = Nothing
   Set olNamespace = Nothing
   Set olApp = Nothing
End Sub

引用:
エクセルシートは下記のようなイメージで先に作成しておかなければならない仕様です。
日付を検索し該当の予定表がある場合のみ転記し、無い場合はそのまま空欄になります。

引用:

	A	　　　　B
1		　　　A社
2	2022/10/1	

アドバイスありがとうございます。
日付を選択し、予定表のデータを転記することができました。
またうまく意図が説明できず、色々くみ取っていただきありがとうございます。
 
このコードを参考に下記のような下↓方向に追加していく形の表を毎週作成して保存していくように使用する予定です。
（B1に入ってる社名は転記には関係ないもので検索は日付のみです。）
 
＜作成したいエクセル表の形式＞

	A	　　　　　　　B
1		　　　　　　　A社
2	2022/10/20	
3		
4		
5		
6	2022/10/21	　　会議�@
7		　　　　　第１会議室
8		
9		
10	2022/10/22	
11		
12		
13		
14	2022/10/23	　　会議�A
15		　　　　　第２会議室
16		　　　　　　会議�B
17		　　　　　第３会議室
18	2022/10/24	
19		
20		
21		
22	2022/10/25	　　会議�B
23		　　　　　第４会議室
24		
25		
26	2022/10/26	
27		
28		
29		

   While TypeName(olItem) = "AppointmentItem"
      If olItem.Start >= strStart And olItem.End < strEnd Then
         With olItem
            pos = Application.Match(CLng(olItem.Start), ws.Columns(1), 0)
            If Not IsError(pos) Then
　　　　　　　ws.Cells[u]([color=red]pos, Columns.Count).End(xlToLeft).Offset(0, 1)[/color][/u].Value = .Subject
              ws.Cells([u][color=red]pos, Columns.Count).End(xlToLeft).Offset(0, 1[/color])[/u].Value = .Body
            Else
              MsgBox olItem.Start & "の日付がマッチしませんでした"
            End If
         End With
      End If
      Set olItem = olConItems.FindNext
   Wend
　　
　　Dim wb As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets(1)'右方向に２件目以上を書き出したシート
    Set ws2 = ThisWorkbook.Worksheets(2)'下方向に２件目以上を転記したい完成形のシート
    Dim i As Long
    i = 1
      If ws1.Cells(i, "D") = "" Then Exit Sub　'2件以上予定がある場合、D列に転記されている
         If ws1.Cells(i, "D") = 1 Then
             ws2.Cells(i, "C").Insert (xlDown)
             i = i + 1
          End If
        i = i + 1
                  
End Sub

日ごとの件数が可変で、所要行数があらかじめ定められないのですから、
日付にマッチする方式はやめたほうが楽でしょう。
 
で、どうするかと言えば、

2022/10/22  タイトル
2022/10/22  本文
2022/10/23  タイトル
2022/10/23  本文
2022/10/23  タイトル
2022/10/23  本文

2022/10/27
2022/10/27

2022/10/22  タイトル
2022/10/22  本文

ありがとうございます。
アドバイスを参考にエクセルの表自体を見直したいと思います。
タイトル、本文の２行ごとの方式を試行錯誤してみます。
（必要ない部分の色を白に変えるという発想が自分には思いつかないので勉強になりました。）
 
まだしばらくこの表の完成のために時間を要することになると思いますが、質問の仕方が漠然としていたため、今後はその中でわからない点をピンポイントに絞って質問したいと思います。
 

引用:
B1に入ってる社名は転記には関係ないもので検索は日付のみです。

引用:
このコードを参考に下記のような下↓方向に追加していく形の表を
毎週作成して保存していくように使用する予定です。

ありがとうございます！
希望していた形式に作成することができました。
まずは取り急ぎお礼申し上げます。
これから一つ一つ構文を解析して勉強していきたいと思います。
 
掲示板の皆さまから色々なアドバイスをいただき、とても勉強になりました。
ありがとうございました。