• 締切済み

vba スケジュール更新マクロ研究中（長文です）

いつもお世話になります。 私の会社では、スケジュール管理するにあたり、1日を3つに分けています。 つまり、「午前」「午後」「夜間」「午前午後」「午後夜間」「全日」の6種になります。 只今私は、スケジュールが更新されたときに、上書きして変更点をメッセージボックスで返すマクロを考えています。 （趣味の範囲ですので締め切りはないのですが、なんせVBA始めて1ヶ月目なもんですから四苦八苦してます＞＜） そこで、とりあえず下記のような「更新前のスケジュール区分を検知してメッセージで返す」ところまで出来ました。 （もう少しスッキリできないものかと思っております。） ここに「更新版と見比べて変更し、メッセージで返す」という働きを足していこうと思っています。 が、別々にコードが書けても、それを合体させようとなると、どうやったらいいのか皆目見当が付きません。 難解に思われるのは、結合セルと入力済みデータの扱いです。 例えば、とある1日に対して、「午前」「午後」「夜間」と別々の予定が入ってたとします。 予定に変更が出て「夜間」が「全日」になってしまったとします。 コードに「生き残っているのは夜間だ」という判断をさせることは出来ませんよね？ （というのも、区分が変更された場合、文字列が一致しているとは限らないのです。） 対話型にして、チェックボックスみたいな形で選択させるのがいいのでしょうか？ オーバースペックで耳から煙が出そうです・・・ とりあえず下記がコードです。 "strage1"を古いスケジュール、"strage2"を更新版としています。 つたない記述ですが、ヒントをご教授くださいませ。 ------------------------------------ Sub 何を書き換えたかMsgBox2() Dim i As Integer, j As Integer Dim myMsg As String Dim myold As Worksheet, mynew As Worksheet Set myold = Sheets("strage1") Set mynew = Sheets("strage2") j = 5 For j = j To 35 i = 6 　　For i = i To 8 　　　　If IsEmpty(myold.Cells(j, i)) And Not IsEmpty(mynew.Cells(j, i)) Then 　　　　　　myMsg = myMsg & mynew.Cells(j, i) & "が追加になりました" & vbCrLf 　　　　ElseIf Not IsEmpty(myold.Cells(j, i)) And IsEmpty(mynew.Cells(j, i)) Then 　　　　　　myMsg = myMsg & myold.Cells(j, i) & "がキャンセルになりました" & vbCrLf 　　　　ElseIf myold.Cells(j, i) <> mynew.Cells(j, i) Then 　　　　　　myMsg = myMsg & myold.Cells(j, i).Value & "から" & mynew.Cells(j, i) & "に変更しました" & vbCrLf 　　　　End If 　　　　　　myold.Cells(j, i).Value = mynew.Cells(j, i) 　　Next Next MsgBox myMsg End Sub --------------------------------------------- Sub 区分識別3() Dim i As Integer Dim myMsg As String i = 5 For i = i To 35 If Cells(i, 6) <> "" Then 　　If Cells(i, 6).MergeArea.Count = 3 Then 　　　　myMsg = myMsg & i - 4 & "日、全日枠の" & Cells(i, 6).Value & "です。" & vbCrLf 　　ElseIf Cells(i, 6).MergeArea.Count = 2 Then 　　　　myMsg = myMsg & i - 4 & "日、午前午後枠の" & Cells(i, 6).Value & "です。" & vbCrLf 　　Else 　　　　myMsg = myMsg & i - 4 & "日、午前枠の" & Cells(i, 6).Value & "です。" & vbCrLf 　　End If End If If Cells(i, 7) <> "" Then 　　If Cells(i, 7).MergeArea.Count = 2 Then 　　　　myMsg = myMsg & i - 4 & "日、午後夜間枠の" & Cells(i, 7).Value & "です。" & vbCrLf 　　Else 　　　　myMsg = myMsg & i - 4 & "日、午後枠の" & Cells(i, 7).Value & "です。" & vbCrLf 　　End If End If If Cells(i, 8) <> "" Then 　　myMsg = myMsg & i - 4 & "日、夜間枠の" & Cells(i, 8).Value & "です。" & vbCrLf End If Next MsgBox myMsg End Sub ------------------------------------------------------- 以上です。 よろしくお願いいたします。

回答 全件
二重ループ廻して、ループ終了後にメッセージだすのであれば細かな処理は難…

みんなの回答

  • bin-chan
  • ベストアンサー率33% (1403/4213)
回答No.1

二重ループ廻して、ループ終了後にメッセージだすのであれば細かな処理は難しいかも。 strage1（旧）、strage2（新）に加え、差分シート（Storage3？)を設けるのはどうでしょう。 Set myCheck = Sheets("storage3") If IsEmpty(myold.Cells(j, i)) And Not IsEmpty(mynew.Cells(j, i)) Then 　　myCheck.Cells(j, i) = mynew.Cells(j, i) & "が追加になりました" ElseIf Not IsEmpty(myold.Cells(j, i)) And IsEmpty(mynew.Cells(j, i)) Then 　　myCheck.Cells(j, i) = myold.Cells(j, i) & "がキャンセルになりました" ElseIf myold.Cells(j, i) <> mynew.Cells(j, i) Then 　　myCheck.Cells(j, i) = myold.Cells(j, i).Value & "から" & mynew.Cells(j, i) & "に変更しました" のように。 で 　　　　Next 　　Next 　　MsgBox myMsg End Sub を 　　　　Next i 　　Next j 　　''''MsgBox myMsg 　　call 区分識別3 End Sub にする。 なお > j = 5 > For j = j To 35 > i = 6 > 　　For i = i To 8 は For j = 5 To 35 　　For i = 6 To 8 で良いですよ。

upside-down
質問者

お礼

早速の回答ありがとうございます。 なるほど差分シートですかー データを一旦別シートに入れて、メッセージは出さずに、区分識別コードへ流す・・・ということでしょうか。 Callはまだ勉強してないキーワードでした＾＾； Gotoかなぁと思っていたのですが、あんまり評判がよくないので手を出しかねていました。 ForNextの修正文ありがとうございます。 参考書どおりに書いてしまってますね私＾＾； 大変参考になりました。

全文を見る
すると、全ての回答が全文表示されます。
  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • VBAコードでメッセージがうまく返せません

    独学でVBAを始めて1ヶ月の初心者です。 下記のコードについて質問です。 シート"strage２"のA1からA15のデータをシート"strage1"と比較し、違ったら更新します。 更新したデータだけを、まとめてメッセージボックスで返したいのです。 しかし、返してくるのは一番最後に処理した値だけなのです。 何が間違いでしょうか？ ご指南よろしくお願いいたします。 --------------------------- Sub 何を書き換えたかMsgBox() Dim i As Integer Dim myMsg As String i = 1 For i = i To 15 If Sheets("strage1").Cells(i, 1) <> Sheets("strage2").Cells(i, 1) Then myMsg = Sheets("strage1").Cells(i, 1).Value & "から" & Sheets("strage2").Cells(i, 1) & "に変更しました" & vbCrLf Sheets("strage1").Cells(i, 1).Value = Sheets("strage2").Cells(i, 1) Else End If Next i MsgBox myMsg End Sub -------------------------------------- 以上です。よろしくお願いします。

  • エクセル２００３のマクロが２０１０で使えない

    ＰＣ買い換えで、今まで使えていたマクロに下記のようなメッセージが表示されて 使えなくなりました。他人が作成したマクロでまた、私はＶＢＡに詳しくありません。 ！はこのマシンで利用できないため、オブジェクトをこのマシンで読み込めませんでした。 コンパイルエラー　変数が定義されていません。 以下記述の一部です。 Private Sub UserForm_Initialize()　　　　　　　　　　　　　　　　　　　　←ここが黄色に Dim c As Control, i As Integer, j As Integer With data i = 1 Do Until .Cells(i + 1, 1).Value = "" i = i + 1 list01.AddItem .Cells(i, 2).Value For j = 1 To 6 list01.List(i - 2, j) = .Cells(i, j + 2).Value Next j list01.List(i - 2, 7) = .Cells(i, 1).Value Loop i = 1 Do Until .Cells(i + 1, 29).Value = "" i = i + 1 comb02.AddItem .Cells(i, 29).Value comb02.List(i - 2, 1) = .Cells(i, 30).Value comb02.List(i - 2, 2) = .Cells(i, 31).Value comb02.List(i - 2, 3) = .Cells(i, 32).Value comb02.List(i - 2, 4) = .Cells(i, 33).Value comb02.List(i - 2, 5) = Mid(.Cells(i, 29).Value, Len(.Cells(i, 29).Value) - 4, 2) comb02.List(i - 2, 6) = Right(.Cells(i, 29).Value, 2) Loop i = 1 Do Until .Cells(i + 1, 37).Value = "" i = i + 1 comb01.AddItem .Cells(i, 37).Value Loop cal01.Value = .Cells(2, 23).Value　　　　　　　　　　　　　　　　　　　← cal01が青く ymdStart = .Cells(2, 26).Value ymdEnd = .Cells(3, 26).Value Controls("opt0" & .Cells(3, 23)).Value = True chk01.Value = .Cells(4, 23).Value For Each c In Controls If Left(c.Name, 4) = "list" Or Left(c.Name, 4) = "text" Or Left(c.Name, 4) = "comb" Then c.ForeColor = .Cells(13, 25).Value c.BackColor = .Cells(16, 25).Value End If Next c End With With list01 If .ListCount = 0 Then If MsgBox("職員が登録されていません。", 48, ThisWorkbook.Name) = 1 Then End If Else ReDim GroupTable(.ListCount - 1, 1) i = 0 For j = 0 To .ListCount - 1 If .List(i, 0) <> .List(j, 0) Then i = j End If GroupTable(j, 0) = i Next j i = .ListCount - 1 For j = .ListCount - 1 To 0 Step -1 If .List(i, 0) <> .List(j, 0) Then i = j End If GroupTable(j, 1) = i Next j End If End With but07.ControlTipText = ThisWorkbook.Name & "の上書き保存" MsgMode = True Call cal01_Click Call opt04to05_Change End Sub どうしていいかわかりませんので、よろしくお願いします。 Windows7 Professional SP1 64

  • 判定してセルを塗りつぶすマクロについて

    判定してセルを塗りつぶすマクロについて教えて下さい。 現在下記のようなマクロがあります。 Sub オニオン判定() Dim i As Integer, j As Integer, r As Integer Dim k As Double Range(Cells(17, 9), Cells(26, 14)).Interior.ColorIndex = 0 Range(Cells(30, 9), Cells(39, 14)).Interior.ColorIndex = 0 k = Cells(5, 2) 'B5セルの値 For j = 9 To 14 For i = 17 To 26 For r = 30 To 39 If Abs(Cells(i, j).Value - Cells(r, j).Value) <= 0.05 Then Cells(r, j).Interior.Color = vbYellow Cells(i, j).Interior.Color = vbYellow End If Next  Next   Next End Sub 対象のIf Abs(Cells(i, j).Value - Cells(r, j).Value) <= 0.05 Then で、それぞれ見比べて、0.05以上のずれがあるとセルが塗りつぶされないというマクロなのですが これを、If Abs(Cells(i, j).Value - Cells(r, j).Value) = 0 Thenという条件も追加して その時はセルを青に塗りつぶし、逆に0.05以上のずれがあるセルは赤に塗りつぶす。 みたいなマクロを書きたいです。 If Abs(Cells(i, j).Value - Cells(r, j).Value) = 0 Thenは一度追加してみましたが 上手く機能しませんでした。 やりたい事 ・数値が動いているけど、0.05以内の時は黄色 ・数値変動が0の場合は青 ・数値変動が0.05以上の場合は赤 です。 宜しくお願いします。

  • VBAエクセル空白セル0の入力

    C列が空白となるまで、F列・・・L列の空白セルに0を代入する。 という処理を行いたく以下コードで実行をして ファイル種類をCSVにて、保存した後名前の変更で拡張子をTXTにすると データ入力された列の以降がカンマの羅列が「,,,,,,,,(改行)」の繰り返しで表示されてしまいます。 (CSV保存の後、視覚的に空白部分を行選択して削除するとなくなります。) どうすれば、このカンマが表示されなくなるでしょうか。 うまく説明できてないですが、アドバイス御願いします。 Dim i As Long i = 3 Do Until Cells(i, 3).Value = "" If Cells(i, 6).Value = "" Then Cells(i, 6).Value = "0" End If If Cells(i, 7).Value = "" Then Cells(i, 7).Value = "0" End If If Cells(i, 8).Value = "" Then Cells(i, 8).Value = "0" End If If Cells(i, 9).Value = "" Then Cells(i, 9).Value = "0" End If If Cells(i, 10).Value = "" Then Cells(i, 10).Value = "0" End If If Cells(i, 11).Value = "" Then Cells(i, 11).Value = "0" End If If Cells(i, 12).Value = "" Then Cells(i, 12).Value = "0" End If i = i + 1 Loop

  • ２つのVBAを組み合わせる方法

    お世話になります、２つのVBAを組み合わせる方法で迷っています。 １つ目が Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True End Sub です。 ２つめが Private Sub Worksheet_Change(ByVal Target As Range)　 Application.EnableEvents = True If Intersect(Target, Range("R8:R38")) Is Nothing Then Exit Sub Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End Sub です。２つのPrivate Sub Worksheet_Change(ByVal Target As Range)イベントのVBAですが、どのようにして組み合わせれば良いのでしょうか？

  • VBAでの質問

    お世話になります。 下記の記述で、「←」の矢印の記述で、 Cells.（５，２）がブランクでなければ、 「→」から進めたいのですが、 どの様に記述すれば宜しいでしょうか ご教示お願いします。 Sub 表記入() Dim Data As Range Dim i As Integer Dim j As Integer Dim k As Integer Set Data = Sheets("集計").Range("A2").CurrentRegion j = 16 k = 0 With Sheets("表") For i = 3 To Data.Rows.Count If Data.Cells(i, 51) <> "" Then .Cells(5, 2) = Data.Cells(i, 3)　　← .Cells(5, 7) = Data.Cells(i, 4) → .Cells(j, 2) = Data.Cells(i, 10) .Cells(j, 6) = Data.Cells(i, 11) & Data.Cells(i, 12) .Cells(j, 14) = Data.Cells(i, 51) Else End If k = k + 1 If k = 10 Then j = j + 18 k = 0 Else j = j + 1 End If End If Next i End With End Sub

  • VBA　マクロについて

    自作のカレンダーに自動で日付を判定、入力してくれる ロジックを作っていたのですが、 2、4、6、9、11月以外は31日分表示されるはずが。。。 表示されませんでした。 恐らくロジックがおかしくて i=31 が通っていないものと 思われますが、ちょっとよく分かりません。 初心者で低レベルな質問ですけど、どなたかお願いします。 Sub AutoCarender() '自動でカレンダーの日付を入力するプログラム Dim month, i As Integer '表示させたい月 month = 3 If (month = 2) Then i = 28 ElseIf (month = 4 Or 6 Or 9 Or 11) Then i = 30 Else i = 31 End If Dim tate, yoko As Integer Dim week As Integer week = (Weekday(2009 / month / 1, 2)) yoko = Choose(week, 1, 3, 5, 7, 9, 11, 13) tate = 3 For j = 1 To i '"シートの名前"を指定 Worksheets("Sheet1").Cells(tate, yoko).Value = j yoko = yoko + 2 If (yoko > 13) Then yoko = 1 tate = tate + 2 End If Next End Sub

  • ExcelのVBAがオーバーフローに！？

    読んで頂きありがとうございます。 以前に質問しました時に回答を頂き凄く助かっていたのですが、何故か「オーバーフロー」と表示されてしまいます。 ひょっとしたら桁なのかも知れません。 下記のVBAを教えて頂きしようしていました。 Option Explicit Sub Test() Dim c(), p(), q(), i, j, l, r, k As Long r = Range("B2").End(xlDown).Row l = Range("D2").End(xlDown).Row ReDim c(r - 2), p(r - 2), q(r - 2) For i = 1 To r - 2 c(i) = Cells(i + 2, 2).Value p(i) = Cells(i + 2, 3).Value q(i) = i + 2 Next i For i = 1 To r - 3 For j = i + 1 To r - 2 If c(i) > c(j) Then k = c(i) c(i) = c(j) c(j) = k k = p(i) p(i) = p(j) p(j) = k k = q(i) q(i) = q(j) q(j) = k End If Next j Next i For i = 1 To r - 2 Cells(i + 2, 7).Value = c(i) For j = 3 To r If Cells(j, 4).Value = c(i) Then Cells(i + 2, 8).Value = p(i) - Cells(j, 5).Value If p(i) - Cells(j, 5).Value <> 0 Then Range("B" & q(i)).Interior.ColorIndex = 6 Range("D" & j).Interior.ColorIndex = 6 End If Exit For End If Next j Next i For i = 3 To r k = 0 For j = 3 To l If Cells(i, 2).Value = Cells(j, 4).Value Then k = 1 Exit For End If Next j If k = 0 Then Range("B" & i).Interior.ColorIndex = 35 End If Next i For i = 3 To l k = 0 For j = 3 To r If Cells(i, 4).Value = Cells(j, 2).Value Then k = 1 Exit For End If Next j If k = 0 Then Range("D" & i).Interior.ColorIndex = 35 End If Next i End Sub デパックのClickすると15行目辺りの「k = c(i)」が黄色くなります。 正直言ってマクロとか全く解りませんが、コピーして使っていました。 どこをどう変更すれば良いのか教えて頂ければ助かります。 よろしくお願いします。

  • このマクロ、どこがおかしいですか？

    i5とj5のセルの文字が同じ場合はセル同士を結合して一つ下の行へ行き、i5とj5のセルに何も書かれていないときはそのまま一つ下の列へ行き、行った先のセルでも同じように処理(i6とj6のセルの文字が同じ場合はセル同士を結合して一つ下の行へ行き、i6とj6のセルに何も書かれていないときはそのまま一つ下の列へ行き)を繰り返し、と言うことをi33とj33のセルまで続けたいと思っています。 Sub よろしくお願いします() Dim i As Integer For i = 5 To 33 Cells(i, 9).Select If Cells(i, 9).Value = Cells(i, 10).Value Then Range(Cells(i, 9), Cells(i, 10)).Merge Selection.Offset(i + 1).Select ElseIf Cells(i, 9).Value = "" Then Selection.Offset(i + 1).Select Next i End If End Sub と書いたのですが、『Nextに対応するForがありません』と言われてしまいます。どうすれば思い通りにできるでしょうか？ 極めて初心者で、伝わりにくい点があるかもしれません。よろしくお願いします。

  • すべてのシートでマクロを実行したい

    以下のプログラムでは、選択したシートのみマクロが動作しています。ネット検索で見よう見まねで作ったため何がまちがっているのかわかりません。ご教示いただけるとありがたいです。 ・月の予定表で利用者が休みの日に斜線を引くマクロ ・入力ミスを防ぐためシート保護をしている Sub すべてのシート() Dim s As Worksheet For Each s In Worksheets s.Select Call 斜線 Next End Sub Sub 斜線() ActiveSheet.Unprotect Password:="1234" For i = 1 To Range("E10").End(xlDown).Row Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlNone If Range("E10").Value = 0 Then Exit Sub If Cells(i, "E").Value = "日" And Range("BP9").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "月" And Range("BP10").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "火" And Range("BP11").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "水" And Range("BP12").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "木" And Range("BP13").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "金" And Range("BP14").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "土" And Range("BP15").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "AY").Value = "祝日" And Range("BP16").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If Next i ActiveSheet.Protect Password:="1234" End Sub

臆病な自分は正当な権利を守れる？交渉における自己主張の方法
このQ&Aのポイント
  • 精神疾患の持病を持つ障害者として働く中で、普通の暮らしを送っていた自分に不意の困難が訪れていることに気づいた。
  • 自分の精神的な脆さによって相手に不利益を押し付けられることが多く、自己主張ができない状況に悩んでいる。
  • 自分が交渉やネゴシエーションを行う場面で、相手を打ちのめすことは望んでいないが、最低限自分の権利を守る方法はあるのかアドバイスを求めている。
回答を見る

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する