Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

2097 / 76807

←次へ　｜　前へ→


	【80354】カレンダーに予定を自動入力したい

VBA初心者 - 19/1/31(木) 12:44 -


	引用なし

	パスワード

初めまして。メーカー系の会社に勤めていて、最近VBAを勉強し始めた者です。
エクセルの表を使って業務予定を管理しているのですが、カレンダーでも予定を管理したいと思っています。
その際にエクセルに入力した予定をそのままカレンダーに反映させることは出来ないかと考え、下のようなVBAを作ってみたのですが上手く動きません。
なぜ動かないのか教えていただきたいです。
また、「もっとこうした方がいいよ」などのアドバイス等ありましたら
宜しくお願い致します。

Sub カレンダー入力()

Dim A As Date 　‘日付
Dim B As Long　 ‘シリアル値
Dim Z As Long　 ‘行数

Dim i As Integer　‘sheet1の最終行変数

Dim myRange As Range　‘カレンダー選択範囲
Dim myObj As Range　　‘シリアル値が一致しているセル
Dim keyWord As String　‘一致しているシリアル値
Dim firstcell As Range　‘一致しているシリアル値の最初のセル
Dim Q As Range　‘一致しているシリアル値の真下のセル

For Z = 1 To i

i = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row　'sheet1の最終行数を格納

A = Worksheets("Sheet1").Cells(Z, 1).Value　‘日付を読み取る

B = CLng(A) ‘日付をシリアル値に変更
　
Set myRange = Range("E1:K10")　‘検索したいカレンダーの範囲を選択

keyWord = B　
　　
Set myObj = myRange.Find(keyWord, LookAt:=xlWhole)　‘シリアル値が一致しているセルを探す
　　
　　If Not myObj Is Nothing Then　‘一致したシリアル値が1つだけでなかった場合
　　　
　　　Set firstcell = myObj　'最初のセルを選択
　　
　　　Do
　　
　　　Set myObj = Cells.FindNext(myObj)　'次に一致したセルを選択

　　　Range(myObj).Offset(1, 0).Activate　'その真下のセルを選択
　　　
　　　Q = Range(myObj).Offset(1, 0).Activate　
　　　
　　　　　　
　　　　　　If Q = "" Then　‘真下のセルが空白だった時
　　　　　
　　　　　　Set Q = Worksheets("Sheet1").Cells(Z, 2).Value　‘sheet1の値を入れる
　　　　　　

　　　　　　Else
　　　　　　　
　　　　　　　If VarType(ActiveCell.Offset(1, 0)) = 3 Then　‘既に文字が入っていた場合
　　　　　　　　 Set Q = Worksheets("Sheet1").Cells(Z, 2).Value & vbLf & Str(Q)　
　　　　　　　
　　　　　　　Else
　　　　　　　　 Set Q = Worksheets("Sheet1").Cells(Z, 2).Value & vbLf & Str(Q)
　　　　　　　　
　　　　　　　End If
　　　　　　
　　　　　 End If
　　　
　　　　Loop While myObj.Address <> firstcell.Address

　　 End If
　　　　
Next Z　　
　　　
End Sub

1 hits

▼

【80354】カレンダーに予定を自動入力したい VBA初心者 19/1/31(木) 12:44