Option Explicit
 
Public Sub タスク検索及び転記()
    Const SrcFolder As String = "C:\Users\user\Documents\ツール\ダウンロード場所\ファイル名変更場所\"
    Const TrgBook As String = "C:\Users\user\Documents\ツール\時間管理シート.xlsx"
    Dim srcName As String       'コピー元ブック名
    Dim taskName As String      'タスク名
    Dim sbk As Workbook         'コピー元ブック
    Dim sws As Worksheet        'コピー元シート
    Dim tbk As Workbook         'コピー先ブック
    Dim tws As Worksheet        'コピー先シート
    Dim maxRow As Long          '日付（A列）最終行
    Dim lastRow As Long         '該当タスク列最終行
    Dim wrow As Long            '作業用行
    Dim wcol As Long            '作業用列
    Dim trgday As Date          '本日の日付
    Dim trgRow As Long          '本日の日付の行
    Dim trgCol As Long          '本日の日付のタスク対応列
    'コピー元ブック取得
    srcName = Dir(SrcFolder & "*.xls")
    If Len(srcName) <= 18 Then
        MsgBox ("該当ファイルが無いか又はファイル名が短すぎます")
    End If
    taskName = Left(srcName, Len(srcName) - 18)
    'コピー元 ブック＆シート設定
    Set sbk = Workbooks.Open(SrcFolder & srcName)
    Set sws = sbk.Worksheets("Sheet1")
    'コピー先　ブック＆シート設定
    Set tbk = Workbooks.Open(TrgBook)
    Set tws = tbk.Worksheets("Sheet1")
    'コピー先の行＆列を決定する
    maxRow = tws.Cells(Rows.Count, "A").End(xlUp).Row
    trgday = Date
    trgRow = 0
    trgCol = 0
    '本日の日付検索
    For wrow = 1 To maxRow
        '本日の日付に一致すれば、その行を記憶する
        If trgday = tws.Cells(wrow, "A").Value Then
            trgRow = wrow
            Exit For
        End If
    Next
    '該当日付なし
    If trgRow = 0 Then
        MsgBox (trgday & "に該当する日付はありません")
        Exit Sub
    End If
    'タスクの検索
    For wcol = 2 To 4
        'タスクが部分一致すれば、その列を記憶する
        If InStr(1, tws.Cells(wrow, wcol).Value, taskName, vbTextCompare) > 0 Then
            trgCol = wcol
            Exit For
        End If
    Next
    If trgCol = 0 Then
        MsgBox (taskName & "が部分一致するタスクはありません")
        Exit Sub
    End If
    '該当列の最終行検索
    lastRow = 0
    wrow = trgRow + 1
    '空きセルが
    Do While True
        '次の日付に達したら打ち切る
        If tws.Cells(wrow, 1).Value <> "" Then Exit Do
        '該当タスク列に空きセルが有れば、その行を記憶する
        If tws.Cells(wrow, trgCol).Value = "" Then
            lastRow = wrow
            Exit Do
        End If
        wrow = wrow + 1
    Loop
    If lastRow = 0 Then
        MsgBox (trgday & "の" & trgCol & "列に空きセルなし")
        Exit Sub
    End If
    sws.Cells(2, 3).Copy tws.Cells(lastRow, trgCol)
    tws.Activate
    tws.Cells(lastRow, trgCol).Select
    MsgBox (lastRow & "行 " & trgCol & "列へコピー完了")
End Sub
 

T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIOOCv+OCueOCr+aknOe0ouWPiuOBs+i7ouiomCgpCiAgICBDb25zdCBTcmNGb2xkZXIgQXMgU3RyaW5nID0gIkM6XFVzZXJzXHVzZXJcRG9jdW1lbnRzXOODhOODvOODq1zjg4Djgqbjg7Pjg63jg7zjg4nloLTmiYBc44OV44Kh44Kk44Or5ZCN5aSJ5pu05aC05omAXCIKICAgIENvbnN0IFRyZ0Jvb2sgQXMgU3RyaW5nID0gIkM6XFVzZXJzXHVzZXJcRG9jdW1lbnRzXOODhOODvOODq1zmmYLplpPnrqHnkIbjgrfjg7zjg4gueGxzeCIKICAgIERpbSBzcmNOYW1lIEFzIFN0cmluZyAgICAgICAn44Kz44OU44O85YWD44OW44OD44Kv5ZCNCiAgICBEaW0gdGFza05hbWUgQXMgU3RyaW5nICAgICAgJ+OCv+OCueOCr+WQjQogICAgRGltIHNiayBBcyBXb3JrYm9vayAgICAgICAgICfjgrPjg5Tjg7zlhYPjg5bjg4Pjgq8KICAgIERpbSBzd3MgQXMgV29ya3NoZWV0ICAgICAgICAn44Kz44OU44O85YWD44K344O844OICiAgICBEaW0gdGJrIEFzIFdvcmtib29rICAgICAgICAgJ+OCs+ODlOODvOWFiOODluODg+OCrwogICAgRGltIHR3cyBBcyBXb3Jrc2hlZXQgICAgICAgICfjgrPjg5Tjg7zlhYjjgrfjg7zjg4gKICAgIERpbSBtYXhSb3cgQXMgTG9uZyAgICAgICAgICAn5pel5LuY77yIQeWIl++8ieacgOe1guihjAogICAgRGltIGxhc3RSb3cgQXMgTG9uZyAgICAgICAgICfoqbLlvZPjgr/jgrnjgq/liJfmnIDntYLooYwKICAgIERpbSB3cm93IEFzIExvbmcgICAgICAgICAgICAn5L2c5qWt55So6KGMCiAgICBEaW0gd2NvbCBBcyBMb25nICAgICAgICAgICAgJ+S9nOalreeUqOWIlwogICAgRGltIHRyZ2RheSBBcyBEYXRlICAgICAgICAgICfmnKzml6Xjga7ml6Xku5gKICAgIERpbSB0cmdSb3cgQXMgTG9uZyAgICAgICAgICAn5pys5pel44Gu5pel5LuY44Gu6KGMCiAgICBEaW0gdHJnQ29sIEFzIExvbmcgICAgICAgICAgJ+acrOaXpeOBruaXpeS7mOOBruOCv+OCueOCr+WvvuW/nOWIlwogICAgJ+OCs+ODlOODvOWFg+ODluODg+OCr+WPluW+lwogICAgc3JjTmFtZSA9IERpcihTcmNGb2xkZXIgJiAiKi54bHMiKQogICAgSWYgTGVuKHNyY05hbWUpIDw9IDE4IFRoZW4KICAgICAgICBNc2dCb3ggKCLoqbLlvZPjg5XjgqHjgqTjg6vjgYznhKHjgYTjgYvlj4jjga/jg5XjgqHjgqTjg6vlkI3jgYznn63jgZnjgY7jgb7jgZkiKQogICAgRW5kIElmCiAgICB0YXNrTmFtZSA9IExlZnQoc3JjTmFtZSwgTGVuKHNyY05hbWUpIC0gMTgpCiAgICAn44Kz44OU44O85YWDIOODluODg+OCr++8huOCt+ODvOODiOioreWumgogICAgU2V0IHNiayA9IFdvcmtib29rcy5PcGVuKFNyY0ZvbGRlciAmIHNyY05hbWUpCiAgICBTZXQgc3dzID0gc2JrLldvcmtzaGVldHMoIlNoZWV0MSIpCiAgICAn44Kz44OU44O85YWI44CA44OW44OD44Kv77yG44K344O844OI6Kit5a6aCiAgICBTZXQgdGJrID0gV29ya2Jvb2tzLk9wZW4oVHJnQm9vaykKICAgIFNldCB0d3MgPSB0YmsuV29ya3NoZWV0cygiU2hlZXQxIikKICAgICfjgrPjg5Tjg7zlhYjjga7ooYzvvIbliJfjgpLmsbrlrprjgZnjgosKICAgIG1heFJvdyA9IHR3cy5DZWxscyhSb3dzLkNvdW50LCAiQSIpLkVuZCh4bFVwKS5Sb3cKICAgIHRyZ2RheSA9IERhdGUKICAgIHRyZ1JvdyA9IDAKICAgIHRyZ0NvbCA9IDAKICAgICfmnKzml6Xjga7ml6Xku5jmpJzntKIKICAgIEZvciB3cm93ID0gMSBUbyBtYXhSb3cKICAgICAgICAn5pys5pel44Gu5pel5LuY44Gr5LiA6Ie044GZ44KM44Gw44CB44Gd44Gu6KGM44KS6KiY5oa244GZ44KLCiAgICAgICAgSWYgdHJnZGF5ID0gdHdzLkNlbGxzKHdyb3csICJBIikuVmFsdWUgVGhlbgogICAgICAgICAgICB0cmdSb3cgPSB3cm93CiAgICAgICAgICAgIEV4aXQgRm9yCiAgICAgICAgRW5kIElmCiAgICBOZXh0CiAgICAn6Kmy5b2T5pel5LuY44Gq44GXCiAgICBJZiB0cmdSb3cgPSAwIFRoZW4KICAgICAgICBNc2dCb3ggKHRyZ2RheSAmICLjgavoqbLlvZPjgZnjgovml6Xku5jjga/jgYLjgorjgb7jgZvjgpMiKQogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgICfjgr/jgrnjgq/jga7mpJzntKIKICAgIEZvciB3Y29sID0gMiBUbyA0CiAgICAgICAgJ+OCv+OCueOCr+OBjOmDqOWIhuS4gOiHtOOBmeOCjOOBsOOAgeOBneOBruWIl+OCkuiomOaGtuOBmeOCiwogICAgICAgIElmIEluU3RyKDEsIHR3cy5DZWxscyh3cm93LCB3Y29sKS5WYWx1ZSwgdGFza05hbWUsIHZiVGV4dENvbXBhcmUpID4gMCBUaGVuCiAgICAgICAgICAgIHRyZ0NvbCA9IHdjb2wKICAgICAgICAgICAgRXhpdCBGb3IKICAgICAgICBFbmQgSWYKICAgIE5leHQKICAgIElmIHRyZ0NvbCA9IDAgVGhlbgogICAgICAgIE1zZ0JveCAodGFza05hbWUgJiAi44GM6YOo5YiG5LiA6Ie044GZ44KL44K/44K544Kv44Gv44GC44KK44G+44Gb44KTIikKICAgICAgICBFeGl0IFN1YgogICAgRW5kIElmCiAgICAn6Kmy5b2T5YiX44Gu5pyA57WC6KGM5qSc57SiCiAgICBsYXN0Um93ID0gMAogICAgd3JvdyA9IHRyZ1JvdyArIDEKICAgICfnqbrjgY3jgrvjg6vjgYwKICAgIERvIFdoaWxlIFRydWUKICAgICAgICAn5qyh44Gu5pel5LuY44Gr6YGU44GX44Gf44KJ5omT44Gh5YiH44KLCiAgICAgICAgSWYgdHdzLkNlbGxzKHdyb3csIDEpLlZhbHVlIDw+ICIiIFRoZW4gRXhpdCBEbwogICAgICAgICfoqbLlvZPjgr/jgrnjgq/liJfjgavnqbrjgY3jgrvjg6vjgYzmnInjgozjgbDjgIHjgZ3jga7ooYzjgpLoqJjmhrbjgZnjgosKICAgICAgICBJZiB0d3MuQ2VsbHMod3JvdywgdHJnQ29sKS5WYWx1ZSA9ICIiIFRoZW4KICAgICAgICAgICAgbGFzdFJvdyA9IHdyb3cKICAgICAgICAgICAgRXhpdCBEbwogICAgICAgIEVuZCBJZgogICAgICAgIHdyb3cgPSB3cm93ICsgMQogICAgTG9vcAogICAgSWYgbGFzdFJvdyA9IDAgVGhlbgogICAgICAgIE1zZ0JveCAodHJnZGF5ICYgIuOBriIgJiB0cmdDb2wgJiAi5YiX44Gr56m644GN44K744Or44Gq44GXIikKICAgICAgICBFeGl0IFN1YgogICAgRW5kIElmCiAgICBzd3MuQ2VsbHMoMiwgMykuQ29weSB0d3MuQ2VsbHMobGFzdFJvdywgdHJnQ29sKQogICAgdHdzLkFjdGl2YXRlCiAgICB0d3MuQ2VsbHMobGFzdFJvdywgdHJnQ29sKS5TZWxlY3QKICAgIE1zZ0JveCAobGFzdFJvdyAmICLooYwgIiAmIHRyZ0NvbCAmICLliJfjgbjjgrPjg5Tjg7zlrozkuoYiKQpFbmQgU3ViCg==