[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『予定表自動化』（いちか）
予定表の管理を作成していますが、入力の自動化したいのですが関数ですとセルに文字などを入力するためマクロで行いたいのですがご指導いただけないでしょうか？
A B C D E F G ～ NG
1 プロジェクト名 工程名 工期 出庫日 完成日 出荷日 20184/1 ～ 2018/12/31
2 2/1 3/2 3/15
3
4 2/4 3/20 4/4
5
出庫日に日付を入力したら2/1のセルAL2に出庫の文字を表示させたい 完成日に日付を入力したら3/2のセルBO2に完成の文字を表示させたい 出荷日に日付を入力したら3/15のセルCB2に出荷の文字を表示させたい
横列3以降も同じようにしたいと考えております。
マクロの記録で行ったのですがどのように変更したら宜しいのでしょうか？ Sub Macro1()
Range("D2").Select
ActiveCell.FormulaR1C1 = "2/1/2018"
Range("AL2").Select
ActiveCell.FormulaR1C1 = "出庫"
ActiveCell.Characters(1, 2).PhoneticCharacters = "シュッコ"
Range("E2").Select
ActiveCell.FormulaR1C1 = "3/2/2018"
Range("BO2").Select
ActiveCell.FormulaR1C1 = "完成"
ActiveCell.Characters(1, 2).PhoneticCharacters = "カンセイ"
Range("F2").Select
ActiveCell.FormulaR1C1 = "3/15/2018"
Range("CB2").Select
ActiveCell.FormulaR1C1 = "出荷"
ActiveCell.Characters(1, 2).PhoneticCharacters = "シュッカ"
End Sub
ご指導頂ける方がおりましたら宜しくお願い致します。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
不備もあるでしょうが、たたき台ということで
もう寝ますzzzzzzzzzzzzzzz
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("D:F")) Is Nothing Then Exit Sub
Application.EnableEvents = False
If IsDate(Target.Value) Then
Select Case Target.Column
Case 4
Range("AL" & Target.Row).Value = "出庫"
Case 5
Range("BC" & Target.Row).Value = "完成"
Case 6
Range("CB" & Target.Row).Value = "出荷"
End Select
ElseIf Target.Value = "" Then
Select Case Target.Column
Case 4
Range("AL" & Target.Row).Value = ""
Case 5
Range("BC" & Target.Row).Value = ""
Case 6
Range("CB" & Target.Row).Value = ""
End Select
End If
Application.EnableEvents = True
End Sub
v(=∩_∩=)v
（SoulMan） 2018/03/14(水) 00:42
SoulManありがとうございます。 私が記録したマクロがよろしくありませんでした申し訳ありませんでした。 説明不足でしたので補足させていただきます。 D列は出庫日の日付を入力する。 E列は完成日の日付を入力する。 F列は出荷日の日付を入力する。 G1～NG1には一年分のカレンダーで日付が入力されています。 例えば、D2で2/1と入力したらAL2に出庫が表示され、D3で2/23と入力したらBH3に出庫が表示される。 E2で3/2と入力したらBO2に完成が表示され、E3で4/2と入力したらCT3に完成が表示される。 F2で3/15と入力したらCB2に出荷が表示され、Fで5/1と入力したらDW3に出荷が表示される。 4行以降も同じ処理をしたいのですができますでしょうか？ カレンダーの日付列の下に各行で入力した日付によって、出庫・完成・出荷の文字を表示される位置が変更されますので作成していただきました少し違いました。ごめんなさい。 頂いたマクロも勉強のために参考にさせていただきます。
（いちか） 2018/03/14(水) 23:43
えっえ～っと もうパソコンを閉じちゃったんですけど、 > 4行以降も同じ処理をしたいのですができますでしょうか？ これは、そうなっているでしょ？ 後、アドレスは、 あっあっ、一つ下なんですね Target.row+1 としてひとつ下げて下さい 何とかなりますでしょうか？ （SoulMan） 2018/03/14(水) 23:54
あっ、すみません 全然、違いますね 2行目と3行目で位置が違うんですね 何か規則があるんでしょうか？ いずれにしましても明日以降、か 週末になっちゃいますけど （SoulMan） 2018/03/15(木) 00:00
2行目と3行目が違うのは、作成するものが違いますので部品が出庫されるタイミングで変わってきます。 完成や出荷も違うタイミングになります。 出庫・完成・出荷の予定が変更になると都度変更する際に日付も変更して出庫などの文字も変更しているので自動でできないかと思いましたのでこのサイトでご質問させて頂きました。 宜しくお願いします。 （いちか） 2018/03/15(木) 00:27
上記想像があっているのであれば
（１）Changeイベントで、D、E、Fいずれかの列に入力があったことを感知する。
（２）入力のあった値が日付型であるか確認する
（３）Findメソッドなどでカレンダー表の該当する日付の場所（セル）を調べる
（４）見つかったら「出庫・完成・入荷」のいずれか該当する文字を入れる
って処理をすればいいような気がします。
とりあえず、ネックなのは
G1～NG1には一年分のカレンダーっていうのがどんなものかわからないところですかね。。。
339列あるんで、お休み引いた営業日が1行に羅列されてるとかそんな感じなのでしょうか？
（1行に羅列されてるのであれば、Findメソッドではなく、Mach関数が使えると思います。）
（もこな２） 2018/03/15(木) 02:55
もなこ2様ありがとうございます。 丁寧に説明頂いたのに初心者なので、どのようにしたら良いのか分かりません。 書いてあったことを調べてトライしてみます。 分からない場合にはご指導いただけたらと思いますのでよろしくお願いします。 （いちか） 2018/03/16(金) 23:28
もうちょっと検証した方がいいかもしれませんが、 消す時は一度に消したいでしょ？ もう胸のカラータイマーが限界です。 お前は、ウルトラマンか？ いいえ、I am a SoulMan なんちゃって (^^; あっ、日付は意地悪しないで 1/3 とか 2/3 とかで入力してね では、では、 もう、寝ます。 おやすみなさいzzzzzzzzzzzzzzzzzzzzzzzzzzzzz
Option Explicit
Dim MyDate As Variant
Dim r As Long
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x As Variant
Dim rr As Range
Dim i As Long
Dim j As Long
If Intersect(Selection, Range("D:F")) Is Nothing Then Exit Sub
Application.EnableEvents = False
If Target.Count > 1 Then
For Each rr In Intersect(Selection, Range("D:F"))
If rr.Value = "" Then
If IsArray(MyDate) Then
For i = LBound(MyDate, 1) - 1 To UBound(MyDate, 1) - 1
For j = LBound(MyDate, 2) To UBound(MyDate, 2)
x = Application.Match(CLng(MyDate(i + 1, j)), Rows(1), 0)
If Not IsError(x) Then
Select Case j + 3
Case 4
Cells(r + i, x).Value = ""
Case 5
Cells(r + i, x).Value = ""
Case 6
Cells(r + i, x).Value = ""
End Select
End If
Next
Next
End If
End If
Next
Else
If IsDate(Target.Value) Then
x = Application.Match(CLng(Target.Value), Rows(1), 0)
If Not IsError(x) Then
Select Case Target.Column
Case 4
Cells(Target.Row, x).Value = "出庫"
Case 5
Cells(Target.Row, x).Value = "完成"
Case 6
Cells(Target.Row, x).Value = "出荷"
End Select
Else
MsgBox Target.Value & " を検索出来ませんでした"
End If
ElseIf Target.Value = "" Then
x = Application.Match(CLng(MyDate), Rows(1), 0)
If Not IsError(x) Then
Select Case Target.Column
Case 4
Cells(r, x).Value = ""
Case 5
Cells(r, x).Value = ""
Case 6
Cells(r, x).Value = ""
End Select
End If
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
Dim j As Long
If Intersect(Target, Range("D:F")) Is Nothing Then Exit Sub
If Target.Count > 1 Then
MyDate = Intersect(Selection, Range("D:F")).Value
r = Intersect(Selection, Range("D:F")).Row
If IsArray(MyDate) Then
For i = LBound(MyDate, 1) To UBound(MyDate, 1)
For j = LBound(MyDate, 2) To UBound(MyDate, 2)
If IsDate(MyDate(i, j)) Then
MyDate(i, j) = MyDate(i, j)
End If
Next
Next
End If
Else
MyDate = Target.Value
r = Target.Row
End If
End Sub
v(=∩_∩=)v
（SoulMan） 2018/03/17(土) 01:55
A B C D E F G ～ NG
1 プロジェクト名 工程名 工期 出庫日 完成日 出荷日 20184/1 ～ 2018/12/31
じゃなくて
A B C D E F G ～ NG
1 プロジェクト名 工程名 工期 出庫日 完成日 出荷日 20184/1 ～ 2018/3/31
なんじゃないだろうか・・・
（12/31 → 3/31）
（もこな２） 2018/03/17(土) 10:44
NGの日付は2019/3/31でした。 記入間違えてましたご指摘ありがとうございます。 （いちか） 2018/03/17(土) 11:37
SoulManさまありがとうございます。 私にはまだ記述できるレベルじゃありませんでした。 １つずつ意味を理解して行きたいと思います。 消す時は一度に消すとはどう意味でしょうか？ １つのセルの日付を消したり変更したりすることはあると思います。
（いちか） 2018/03/17(土) 11:49
気になるのは日付を入力するときに年まで入れないと、たとえば今日、3/3と入力すれば、それは「2018/3/3」と解釈される。そうなると、4月1日始まりのその表では、見つからないのでエラーというか、何も処理されないとおもう。。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MySTR As String
Dim 区分 As Variant
区分 = Array("出庫", "完成", "出荷")
Dim 検索列 As Variant
Stop
'入力されたのがＤ～Ｆ列じゃなければ処理終了
If Intersect(Target, Range("D:F")) Is Nothing Then Exit Sub
'入力されたのが単一セルじゃなかったら処理終了（改造すれば複数処理もできるかも）
If Target.Count > 1 Then Exit Sub
'ブランクに変更された場合は処理終了
If Target.Value = "" Then Exit Sub
'入力されたのが日付型じゃなかったら処理終了
If Not IsDate(Target.Value) Then Exit Sub
'Match関数で「入力した日付」をキーに該当する列を検索して変数に格納
'（もし、Match関数がエラーになるなら終了）
検索列 = Application.Match(Target, Range("G1:NG1"), 0)
If IsError(検索列) Then Exit Sub
'書き込み処理（G～NG列全体から、行と列を指定して、そこに値として書き込み）
Range("G:NG").Cells(Target.Row, 検索列).Value = 区分(Target.Column - 4)
End Sub
（もこな２） 2018/03/17(土) 12:23
また、「STOP」は自力でブレークポイント付けてステップ実行できるなら、こちらも要りません。
（もこな２） 2018/03/17(土) 12:41
> 消す時は一度に消すとはどう意味でしょうか？
気付かれていないのなら、私も自信がないのでその方がいいです。
でも、一回だけ、
D4 と F5 ぐらいに入力して、マウス でこの範囲を含む様に選択した状態で Deleteを押してみて下さい。
一つ一つ消すより、いいかなぁ、、、と思っただけですから 指が勝手に動いただけです。(;^_^A
あまりお気になさらないで頑張って下さいね では、では、 v(=∩_∩=)v （SoulMan） 2018/03/17(土) 13:25
SoulManさまありがとうございます。 何度か日付を入力している際にD列とE列は入力した通りにG列～NG列に入力されますがF列の出荷日のところだけ入力すると動作したりしなかったりします。 日付を入力したセルの変更をおこなうのにDeleteを押さないと表示された文字が残ったまま、別なセルにも表示されてしましまた。 何度かセルに日付を入れてセルを選択してDeleteを押したところ、実行値エラー"13" になりました。 x = Application.Match(CLng(MyDate(i + 1, j)), Rows(1), 0)この部分です。 すべてのセルを選択したところ実行値エラー"6"オーバーフローとなりました。 いくつもの問題がでてきてしまい申し訳ない気持ちでいっぱいです。ごめんなさい。
（いちか） 2018/03/18(日) 01:32
もなこ２さま提供していただきありがとうございます。 質問ですが、日付の変更をした際に前の記載された文字は消したりも可能なのでしょうか？
（いちか） 2018/03/18(日) 01:45
おはようございます まだ、お布団の中ですけど、 F列だけと言うのは、わかりませんが、 考えられる理由は、 処理速度が追いついていないんだと思います ゆっくりゆっくりソフトに取り扱ってあげて下さい そして、裏ではイベントがひっきりなしに動いていますから 時々、エクセル君を閉じてメモリーを解放してあげて下さい CPUに物凄く負担がかかっていますから汗 それから、オーバーフローは、選択した範囲が広すぎるか？ または、範囲の中に、セル幅が狭くて表示されない時に #######みたいになった文字があるでしょ？ こんな文字が含まれていると、 配列は、オーバーフローします。 なので、この症状が、出た時は 含まれいる文字の種類に注意してみてください これは、エクセル仕様かSoulMan仕様と言う事になります汗 では、では、
（SoulMan） 2018/03/18(日) 06:39
だから、 一回だけ って言ったのに、、、 何回もやっちゃいましたね(笑) （SoulMan） 2018/03/18(日) 06:53
Worksheet_SelectionChange については、学校の↓で詳しく説明されています。 http://www.excel.studio-kazu.jp/mag2/backnumber/mm20040727.html
Worksheet_Change とWorksheet_SelectionChange の組み合わせ については、 この中の [[20040630213250]] で 夏目雅子似 さんというふざけたHNを使っている人がこの学校では初めて紹介されているみたいです。
でも、この Worksheet_Change とWorksheet_SelectionChange を組み合わせる方法は 後に CP に負担が掛る？ という理由だったと思うのですが、強く否定されることになります。
で、その方のお名前は忘れましたが、代案を提示されていて 私はそのころ既にパソコンを使う仕事から離れていましたので 「あぁぁ、そうなんだぁ、、、」ぐらいでチラッと見た程度だったので検索してみましたが、 わかりませんでした。
ですから、この、Worksheet_Change とWorksheet_SelectionChange の組み合わせ は ある意味、禁じ手 なのかもしれません。
これに関しては、別トピで議論されていると思いますし、その方面には詳しくないので 今は、割愛します。
興味がおありなら、学校内を探索されると代案が見つかるかもしれません。 その際に、私のルーツを知られても、「黙って、、、、しっー！」で、お願いします。!(^^)!
私の場合、記憶が断片的で、本当にあやふやなのです。 指が勝手にというのも冗談でも何でもなくて本当に記憶は断片的でも指が反応するんです。 困ったもんです。(￣▽￣;)
ここだけの話ですけど、IFERROR って関数があるでしょ？
最近しりましたよ(笑) びっくりしました。 「こんな便利な関数があったのか」って、、、、ほんと 時の流れは恐ろしい。
私は、本当は 「関数の人」 だったのです。今では、そのかけらもありませんけど、、、(笑)
では、では、
※本日はお馬さんモード全開で行きますから、音信不通 になると思います。
v(=∩_∩=)v （SoulMan） 2018/03/18(日) 09:19
'注意）最後に記入した日付のみ記載される。
'例）出荷日を記入後同じ日付で完成日を記入すると、"出荷"の文字は消え、"完成"のみとなる。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r対象s As Range
Dim rr As Range
Dim r日付ミス As Range
Set r対象s = Intersect(Target, Range("D2:F1000")) '行1000までを対象
If r対象s Is Nothing Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each rr In r対象s
カレンダーにset rr, r日付ミス
Next
If Not r日付ミス Is Nothing Then
r日付ミス.Interior.Color = vbRed
Application.ScreenUpdating = True
MsgBox "赤塗りの該当日はありません"
r日付ミス.Interior.Pattern = xlNone
End If
Application.EnableEvents = True
End Sub
Sub カレンダーにset(r As Range, rerr As Range)
Dim s予定 As String
Dim r開始日 As Range
Dim r日付表 As Range
Dim r前回 As Range
Dim 日差 As Long
Dim flg As Boolean
With r
If (Not IsDate(.Value)) Or .Value = "" Then flg = True '日付以外は前回データを消すだけのフラグ
Set r開始日 = Range("G1")
Set r日付表 = Range(r開始日, r開始日.End(xlToRight)) '閏年等対応
s予定 = Cells(1, .Column).Value '記入日の１行目の項目文字
s予定 = VBA.Replace(s予定, "日", "") '文字から"日"を除く
On Error Resume Next
Set r前回 = r日付表.Offset(.Row - 1).Find(s予定, , , xlWhole) '記入済みの文字を探す
On Error GoTo 0
If Not r前回 Is Nothing Then r前回.ClearContents 'その文字が書かれたセルの値を消す
If Not flg Then '日付が入った場合の処理
'カレンダーは埋まっているようなので日差を求める
日差 = .Value2 - CDate(r開始日.Value)
If 日差 >= r日付表.Columns.Count Or 日差 < 0 Then
If rerr Is Nothing Then
Set rerr = r
Else
Set rerr = Union(rerr, r)
If Not r前回 Is Nothing Then r前回.Value = s予定 '消した文字を戻す
End If
Else
r開始日.Offset(.Row - 1, 日差).Value = s予定 '日付の記入行に文字を記入
End If
End If
End With
End Sub
（kazuo） 2018/03/18(日) 11:12
答えることは簡単ですが、すぐに答えてしまっては”研究用”として提供した意味がないので、どのような動きをしているのか調べて自分で答えを出してみてください。
※どうしても理解できない部分があればその部分を抜き出して聞いてみるとあっという間に答え返ってくると思いますよ。（もちろん、聞く前に最低限ネット検索等を使って、自分で”調べる”努力はされたほうがよいかとおもいますが・・・）
（もこな２） 2018/03/18(日) 13:07
とりあえず。
・複数のセルが変更されても大丈夫なようにする
・日付を修正したときも対応できるようにするならこんな感じですかね
Dim 区分 As Variant
区分 = Array("出庫", "完成", "出荷")
Dim 検索列 As Variant
Dim MyRNG As Range, tmp As Range
'変更されたセルのうち、Ｄ～Ｆ列に該当するものを「MyRNG」にセット
Set MyRNG = Intersect(Target, Range("D:F"))
'MyRNGがNothing（＝変更されたセルにＤ～Ｆ列が含まれていない）なら処理終了
If MyRNG Is Nothing Then Exit Sub
For Each tmp In MyRNG
Select Case True
'ブランクに変更されたとき
Case tmp.Value = ""
Call 既入力クリア(tmp.Row, CStr(区分(tmp.Column - 4)))
'日付が入力されたとき
Case IsDate(tmp.Value)
検索列 = Application.Match(tmp, Range("G1:NG1"), 0)
If Not IsError(検索列) Then
Call 既入力クリア(tmp.Row, CStr(区分(tmp.Column - 4)))
★←自力で記述してみてください。
End If
'上記条件に当てはまらないとき
Case Else
End Select
Next tmp
End Sub
Range(Cells(行, "G"), Cells(行, "NG")).Replace _
What:=str, Replacement:=""
End Sub
SoulMan様色々と調べてみたいと思います。 もなこ２様ありがとうございます。 1つずつやっていきたいと思います。
Kazuo様も提供していただきありがうございます。 列や行を増やした際に変更する箇所は下記の部分だけでよろしいのでしょうか？
Set r対象s = Intersect(Target, Range("E6:G1000")) '行1000までを対象
Set r開始日 = Range("J5")
（いちか） 2018/03/19(月) 14:14
パソコンが修理から返って来るまで ちょっと待ってて下さい。 とか言って全然、駄目だったりして、、(笑) その時は、ごめんなさい。 では、では、 （SoulMan） 2018/03/19(月) 15:06
↓
＞ Set r対象s = Intersect(Target, Range("E6:G1000")) '行1000までを対象
＞ Set r開始日 = Range("J5")
ということは項目行も変更なので、項目から作業("出庫", "完成", "出荷")を取り出している関係上、
＞ s予定 = Cells(1, .Column).Value '記入日の１行目の項目文字
の変更要
２．
変更された全ターゲットを処理しているので、
行をすんごく増やされると、2997セルまでの一括日付変更なら今と全く同じですが、
10000セル一括変更とかになると処理時間が？です。
また、範囲外の日付入力も増えてしまう場合は、確認していません。
３．
＞ Set r前回 = r日付表.Offset(.Row - 1).Find(s予定, , , xlWhole) '記入済みの文字を探す
＞ r開始日.Offset(.Row - 1, 日差).Value = s予定 '日付の記入行に文字を記入
r日付表.row は 1 → 5 ・・・・大ヒントです。
r.row はr日付表からの相対値変わらず
なので、(.row - 1) の 1 を変更要
（kazuo） 2018/03/19(月) 19:15
Soul Man様パソコンが入院中なんですね（汗）
Kazuo様ありがとうございます。 下記のコードに変更したところ日付を変更すると、出庫・完成・出荷の文字が移動しなくなりました（汗） どこがよろしくないのでしょうか？
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r対象s As Range
Dim rr As Range
Dim r日付ミス As Range
Set r対象s = Intersect(Target, Range("E6:G1000")) '行1000までを対象
If r対象s Is Nothing Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each rr In r対象s
カレンダーにset rr, r日付ミス
Next
If Not r日付ミス Is Nothing Then
r日付ミス.Interior.Color = vbRed
Application.ScreenUpdating = True
MsgBox "該当日がありません"
r日付ミス.Interior.Pattern = xlNone
End If
Application.EnableEvents = True
End Sub
Sub カレンダーにset(r As Range, rerr As Range)
Dim s予定 As String
Dim r開始日 As Range
Dim r日付表 As Range
Dim r前回 As Range
Dim 日差 As Long
Dim flg As Boolean
With r
If (Not IsDate(.Value)) Or .Value = "" Then flg = True '日付以外は前回データを消すだけのフラグ
Set r開始日 = Range("J5")
Set r日付表 = Range(r開始日, r開始日.End(xlToRight)) '閏年等対応
s予定 = Cells(5, .Column).Value '記入日の5行目の項目文字
s予定 = VBA.Replace(s予定, "日", "") '文字から"日"を除く
On Error Resume Next
Set r前回 = r日付表.Offset(.Row - 1).Find(s予定, , , xlWhole) '記入済みの文字を探す
On Error GoTo 0
If Not r前回 Is Nothing Then r前回.ClearContents 'その文字が書かれたセルの値を消す
If Not flg Then '日付が入った場合の処理
'カレンダーは埋まっているようなので日差を求める
日差 = .Value2 - CDate(r開始日.Value)
If 日差 >= r日付表.Columns.Count Or 日差 < 0 Then
If rerr Is Nothing Then
Set rerr = r
Else
Set rerr = Union(rerr, r)
If Not r前回 Is Nothing Then r前回.Value = s予定 '消した文字を戻す
End If
Else
r開始日.Offset(.Row - 5, 日差).Value = s予定 '日付の記入行に文字を記入
End If
End If
End With
End Sub
（いちか） 2018/03/19(月) 23:56
また、単純に～～となりました。だけではなく、自分でブレークポイントを設定したうえでステップ実行してコードがどのように動いてるのか分析する癖をつけたほうがよいと思います。
（もこな２） 2018/03/20(火) 00:11
＞ Set r前回 = r日付表.Offset(.Row - 1).Find(s予定, , , xlWhole) '記入済みの文字を探す
日付表の、変更したセルと同じ行から、
予定文字が入ったセル探すし、
ｒ前回として代入するという意味です。
今後も位置関係が変わるようなら、コード変更が最小になるよう書き換えますが、必要ですか？
（kazuo） 2018/03/20(火) 10:34
位置関係が変更になるかもしれません。 甘えてしまって申し訳ありませんが、コード変更が最小になるようにお願いします。 勉強が必要なのは分かっております。ここの人たちみたいに回答できるように努力していきます。
（いちか） 2018/03/20(火) 11:46
解決しないで、 わちきの出番もおいといてちょうだいねぇ～～ (笑) （SoulMan） 2018/03/20(火) 12:04
P.S. 姪の名前は苺果（いちか）です。今のところかわいいです。
SoulManさんもその時はよろしくお願いします。だいじょうぶかなあ。
（kazuo） 2018/03/20(火) 18:39
大体、頭の中では出来てるんですけどね 流石にパソコンがないと駄目です😂 週末には、返ってくるでしょうから、その時は、 こちらこそよろしくお願いします😊 （SoulMan） 2018/03/20(火) 19:06
同じ名前でびっくりです(笑) SoulMan様もありがとうございます。 早くパソコンが戻って来るといいですね！ 皆さま親切にしていただきありがとうございます、
（いちか） 2018/03/20(火) 21:31
回答の時でいいかなっと思いましたが 私の孫の名前は、にちか です😅 （SoulMan） 2018/03/20(火) 21:37
こんばんは！と言うか、、深夜ですね。
取り敢えず、パソコンが返って来ましたので、コードを書いてみました。 また、来週の月曜日からなくなります。仮退院です。 あまり検証していないのでちょっと微妙です。(^^;
SelectionChange と Change の組み合わせですが、私の親友(あの人も中々やる、、でも、実力は、私の方がちょっと上だと思っている） のあの人が学校で紹介している点と学校のマイスターにも載っていることですし、 1対1なら問題ないと思いますので賛否両論あると思いますが私は採用しました。
この SelectionChange と Change を組み合わせる方法は、 私の職場でも実際に使われていて、「いつのファイルなのかなぁ」と先日見てみましたら 何と、、1998年 でした。もう、20年近く文句も言わないで頑張っています。(笑)
ですから、この方法も決して悪い方法ではないと思います。 と言うか、私的には Change で直前の値を記憶するのに持ってこいイベントで SelectionChange は この為にあるんじゃないかと私は思っています。まぁ、この件は色々とあるでしょうから、今回はこのぐらいで割愛します。
ただ、但しですよ、前回の私のコードの様に Public変数に 配列を入れてはいけないと思います。 というか、度合ですよね ちょっとぐらいならいいんでしょうけど、トピ主さんの様に ハードタイプだとちょっと厳しいかもですね
エクセル君的に言うと、「誰や、こんなコード書いたの、SoulMan お前か、そんなに ぱっとっ動いて、ぱっとっ記憶して出来るわけないやろ」 みたいな感じだと思います。
ということで、1対1の場合は、SelectionChange と Change の組み合わせ でコードを書いてみました。
で、よくよくこの予定表のことを考えると、出庫 完成 出荷 と まぁ、一行に一つだと思うんですよね
なので、出庫日を打ちかえると出庫日が移動して、完成日を打ちかえると完成日が移動します。
で、問題は消す時ですよね？方法は、色々あると思いますが、一応、二種類考えてみました。
Unionで､､か､､､め､､､は､､､め､､､､はぁぁ と 全部まとめて､､か､､､め､､､は､､､め､､､､はぁぁ です。
消したい範囲を選択して右クリック→メッセージが出て ハイなら 消去 いいえ なら メニュー、、、
どうかなぁ、、 の はずなんですけど、、、駄目な時があるかもしれません。
その時はすみません。
一応、マウスで飛び飛びに選択してもいい様にしておいた、、、つもり、、、です。(^^;
取り敢えず、例によって胸のカラータイマーが ピコピコ なんでもう寝ます。
おやすみなさいzzzzzzzzzzzzzzzzzzzzzzzzzzzzz
これ↓をシートモジュールに
Option Explicit
Dim MyDate As Date
'複数選択を不可にして SelectionChange と1対1で対応します。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyA As Variant
Dim MyTbl As Range
Dim x As Variant
Dim r As Long
Dim j As Long
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("D:F")) Is Nothing Then Exit Sub
r = Target.Row
Set MyTbl = Range("G" & r & ":NG" & r)
MyA = MyTbl.Value
If IsDate(Target.Value) Then
x = Application.Match(CLng(Target.Value), Rows(1), 0)
If Not IsError(x) Then
Select Case Target.Column
Case 4
日付に対応した項目を入力 MyA, MyTbl, "出庫", x
Case 5
日付に対応した項目を入力 MyA, MyTbl, "完成", x
Case 6
日付に対応した項目を入力 MyA, MyTbl, "出荷", x
End Select
Else
MsgBox Target.Value & " を検索出来ませんでした"
End If
ElseIf IsEmpty(Target.Value) Then
x = Application.Match(CLng(MyDate), Rows(1), 0)
If Not IsError(x) Then
Select Case Target.Column
Case 4
日付に対応した項目を削除 MyA, MyTbl, "出庫", x
Case 5
日付に対応した項目を削除 MyA, MyTbl, "完成", x
Case 6
日付に対応した項目を削除 MyA, MyTbl, "出荷", x
End Select
Else
MsgBox Target.Value & " を検索出来ませんでした"
End If
End If
Application.EnableEvents = True
End Sub
'直前の日付をMyDateに格納します。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("D:F")) Is Nothing Then Exit Sub
If Not IsDate(Target.Value) Then Exit Sub
MyDate = Target.Value
End Sub
'削除する時は範囲を選択して 右クリック で対応します。
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim k As Long
Dim MyMsg As String
Dim MyTimer As Single
If Target.Count > 1 Then
If vbYes = MsgBox("選択範囲を削除しますか？", vbYesNo + vbDefaultButton2) Then
Cancel = True
MyTimer = Timer
Application.EnableEvents = False
'ここは
'Unionで､､か､､､め､､､は､､､め､､､､はぁぁ と
'全部まとめて､､か､､､め､､､は､､､め､､､､はぁぁ
'のコメントを交互に入れ替えて試してください
'---------------------------------------------------------------------------
Unionで､､か､､､め､､､は､､､め､､､､はぁぁ Me, MyMsg, k
' 全部まとめて､､か､､､め､､､は､､､め､､､､はぁぁ Me, MyMsg, k
'---------------------------------------------------------------------------
Application.EnableEvents = True
Else
Exit Sub
End If
Else
Exit Sub
End If
MsgBox "処理時間は" & vbCrLf & _
Format(Timer - MyTimer, "#0.######### 秒") & vbCrLf & _
"です。"
If k > 0 Then
MsgBox "以下の日付を検索出来ませんでした。" & vbCrLf & MyMsg
Else
MsgBox "処理が完了しました"
End If
End Sub
これ↓を標準モジュールに
Option Explicit
Sub 日付に対応した項目を入力( _
ByRef MyA As Variant, _
ByVal MyTbl As Range, _
ByVal MyKey As String, _
ByVal x As Long)
Dim j As Long
For j = LBound(MyA, 2) To UBound(MyA, 2)
If Not IsEmpty(MyA(1, j)) Then
MyA(1, j) = Replace(MyA(1, j), MyKey, "")
End If
Next
MyA(1, x - 6) = MyKey
Application.EnableEvents = False
MyTbl.Value = MyA
Application.EnableEvents = True
End Sub
Sub 日付に対応した項目を削除( _
ByRef MyA As Variant, _
ByVal MyTbl As Range, _
ByVal MyKey As String, _
ByVal x As Long)
Dim j As Long
For j = LBound(MyA, 2) To UBound(MyA, 2)
If Not IsEmpty(MyA(1, j)) Then
MyA(1, j) = Replace(MyA(1, j), MyKey, "")
End If
Next
Application.EnableEvents = False
MyTbl.Value = MyA
Application.EnableEvents = True
End Sub
'ここネーミングは適当に変えて下さい。
'この溜める感じがいいでしょ？
Sub Unionで､､か､､､め､､､は､､､め､､､､はぁぁ( _
ByVal MySh As Worksheet, _
ByRef MyMsgA As String, _
ByRef n As Long)
Dim y() As Variant
Dim x As Variant
Dim MyTblA As Range
Dim MyTblB As Range
Dim MyUnionA As Range
Dim MyUnionB As Range
Dim rr As Range
Dim r As Range
With MySh
Set MyTblA = .Range("D:F")
Set MyTblB = .Range("G:NG")
MyTblA.Interior.ColorIndex = xlNone
MyTblB.Interior.ColorIndex = xlNone
If Not Intersect(Selection, MyTblA) Is Nothing Then
For Each rr In Intersect(Selection, MyTblA).Areas
For Each r In rr
If r.Value <> "" Then
If IsDate(r.Value) Then
x = Application.Match(CLng(r.Value), .Rows(1), 0)
If Not IsError(x) Then
If MyUnionA Is Nothing Then
Set MyUnionA = r
Else
Set MyUnionA = Union(MyUnionA, r)
End If
If MyUnionB Is Nothing Then
Set MyUnionB = .Cells(r.Row, x)
Else
Set MyUnionB = Union(MyUnionB, .Cells(r.Row, x))
End If
Else
n = n + 1
ReDim Preserve y(n)
y(n) = r.Value
MyMsgA = Join(y, vbCrLf)
End If
End If
End If
Next
Next
End If
'消しちゃうと分からないので色を付けてます。
'適当に応用してください
Application.ScreenUpdating = False
MyUnionA.Interior.ColorIndex = 3
MyUnionB.Interior.ColorIndex = 7
' MyUnionA.ClearContents
' MyUnionB.ClearContents
Application.ScreenUpdating = True
Set MyTblA = Nothing
Set MyTblB = Nothing
End With
End Sub
'ここネーミングは適当に変えて下さい。
'この溜める感じがいいでしょ？
Sub 全部まとめて､､か､､､め､､､は､､､め､､､､はぁぁ( _
ByVal MySh As Worksheet, _
ByRef MyMsgA As String, _
ByRef n As Long)
Dim MyA As Variant
Dim MyB As Variant
Dim y() As Variant
Dim x As Variant
Dim MyTblA As Range
Dim MyTblB As Range
Dim MyUnionA As Range
Dim rr As Range
Dim r As Range
With MySh
Set MyTblA = .Range("D:F")
Set MyTblB = .Range("G:NG")
MyA = Intersect(.UsedRange, MyTblA).Value
MyB = Intersect(.UsedRange, MyTblB).Value
If Not Intersect(Selection, MyTblA) Is Nothing Then
For Each rr In Intersect(Selection, MyTblA).Areas
For Each r In rr
If r.Value <> "" Then
If IsDate(r.Value) Then
x = Application.Match(CLng(r.Value), .Rows(1), 0)
If Not IsError(x) Then
'消しちゃうと分からないので アドレスにしています。
MyA(r.Row, r.Column - 3) = r.Address(0, 0)
MyB(r.Row, x - 6) = r.Address(0, 0)
' MyA(r.Row, r.Column - 3) = ""
' MyB(r.Row, x - 6) = ""
Else
n = n + 1
ReDim Preserve y(n)
y(n) = r.Value
MyMsgA = Join(y, vbCrLf)
End If
End If
End If
Next
Next
End If
Application.ScreenUpdating = False
.Range("D1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value = MyA
.Range("G1").Resize(UBound(MyB, 1), UBound(MyB, 2)).Value = MyB
Application.ScreenUpdating = True
Set MyTblA = Nothing
Set MyTblB = Nothing
Erase MyA, MyB
End With
End Sub
なんか長いなぁ、、、、、 あっ、全部まとめて､､か､､､め､､､は､､､め､､､､はぁぁ を一番下の行(1048576)でやったら、「メモリーがたりません」って怒られました。(笑) いります？
これぐらい大きな配列？(配列というのか微妙ですけど、ブンブン振り回してフリーザのどってぱらに 風穴を開けてやりたいね(笑) あかん、ほんま、もう寝ますわzzzzzzzzzzz v(=∩_∩=)v （SoulMan） 2018/03/24(土) 02:33
Dim Rng As Range
Dim s As String
If Target.CountLarge > 1 Then Exit Sub
If Intersect(Me.Range("D:F"), Target) Is Nothing Then Exit Sub
Set Rng = Me.Range("G:NG")
s = Left(Me.Cells(1, Target.Column).Value, 2)
With Intersect(Target.EntireRow, Rng)
.Replace s, ""
.Cells(Target.Value - Rng(1).Value + 1) = s
End With
End Sub
こういう事でしょうか？？？
（まっつわん） 2018/03/24(土) 11:57
SoulManさまありがとうございます。 凄いですね！！！処理時間や右クリックでの削除など感動です。 列や行を増やしたときはどこを変更したらよろしいのですか？ カレンダーのG～NGの列には元々色をつけていた場合にはすべて色が消えてしまいますよね！？ （いちか） 2018/03/24(土) 12:50
おはようございます。 >凄いですね！！！ 全然、凄くないんですよ、、本当は、、、(￣▽￣;)
>列や行を増やしたときはどこを変更したらよろしいのですか？
基本的に、↓この辺です。
Set MyTblA = .Range("D:F")
Set MyTblB = .Range("G:NG")
でも、ここを変えると、数合わせしているところが変わりますから、
そこは、お勉強ですね
>カレンダーのG～NGの列には元々色をつけていた場合にはすべて色が消えてしまいますよね！？ 昨夜、半分寝ながら書いたので色は、おまけですよ(^^; MyTblA.Interior.ColorIndex = xlNone MyTblB.Interior.ColorIndex = xlNone これをコメントすれば消えません。
まっつわん さんから素敵な回答が出ていますから、ぐぅぐぅ、、、と研究されて トピ主さんのオリジナルを作られたらいいですよ
では、では、頑張って下さいね。 パソコンが入院しててお待たせして申し訳なかったです。 ごめんなさい。 v(=∩_∩=)v （SoulMan） 2018/03/24(土) 13:05
まっつわんさまありがとうございます。
列や行の挿入をした場合の変更は下記の部分のみでいのでしょうか？
If Intersect(Me.Range("F:H"), Target) Is Nothing Then Exit Sub
Set Rng = Me.Range("K:NK")
SoulManさまありがとうございました。 （いちか） 2018/03/24(土) 23:50
2018/03/19(月) 14:14のコメント
＞列や行を増やした際に変更する箇所は下記の部分だけでよろしいのでしょうか？
2018/03/24(土) 12:50のコメント
＞列や行を増やしたときはどこを変更したらよろしいのですか？
＞カレンダーのG～NGの列には元々色をつけていた場合にはすべて色が消えてしまいますよね！？
2018/03/24(土) 23:50のコメント
＞列や行の挿入をした場合の変更は下記の部分のみでいのでしょうか？
すごくお節介なことだとおもいますが、一度、ステップ実行するなり、頭の中でシミュレーションするなりして、どのような動きをするコードなのかを確認してから質問されたらいかがでしょうか？
傍から見ていると、試しもせずにただ聞いてるだけで、結局欲しいのは結果だけであって、学ぶ気持ちは無いようにも見えてしまいます。（質問じゃなくて丸投げに見えてしまう）
まぁ、このサイトは丸投げ禁止とはなっていないので、それはそれでいいのかもしれませんが・・・
さて、小姑みたいなことばっかり言っててもしょうがないので、まっつわんさんの投稿をヒントに、以前投稿したコードをMATCH関数以外の方法で処理するように改造してみたので投稿します。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim 区分 As String
Dim buf As Integer
Dim MyRNG As Range, tmp As Range
'変更されたセルのうち、Ｄ～Ｆ列に該当するものを「MyRNG」にセット
Set MyRNG = Intersect(Target, Range("D:F"))
'MyRNGがNothing（＝変更されたセルにＤ～Ｆ列が含まれていない）なら処理終了
If MyRNG Is Nothing Then Exit Sub
For Each tmp In MyRNG
With Cells(1, tmp.Column)
区分 = Left(.Value, Len(.Value) - 1)
End With
With Intersect(tmp.EntireRow, Range("G:NG"))
Select Case True
'ブランクに変更されたとき
Case tmp.Value = ""
.Replace What:=区分, Replacement:=""
'日付が入力されたとき
Case IsDate(tmp.Value)
.Replace What:=区分, Replacement:=""
buf = DateDiff("d", Range("G1").Value, tmp.Value) + 1
If buf <= .Count And Range("G1").Value <= tmp.Value Then _
.Cells(1, buf).Value = 区分
End Select
End With
Next tmp
End Sub
（もこな２） 2018/03/25(日) 02:21
おはようございます。 沢山回答が出てきましたね。 私も不具合箇所を改善しつつちょっとヴァジョンUpしてみました。 基本的にあまり変わっていませんが、明日からまたパソコンがなくなるので、 今日のお馬さんモードの合間にチョットBreakTimeです。
改善点
1.全選択でオーバーフローする
これは、
If MyTblA.Count >= 3145728 Then
Set MyTblA = Nothing
Exit Sub
End If
D:F列で 3145728 個だったのでこれで対応しました。
後、削除の時、右クリックしてくれといいですけど、 そのままDeleteだと 対応しないで消えちゃうので、、そこは、 .Undo でやり直ししました。
それから、 Replace は、配列で処理しました。 これで、一回シートに触るのが減るのと 皆さんのコードを参考にKeyをシートの項目から取得しました。
これで、標準モジュールの 日付に対応した項目を入力 と 日付に対応した項目を削除 が不要です。
一番最初のレイアウトをよく見ていませんでしたね(;^_^A
まぁ、他にも不具合箇所があると思いますが、取り敢えずUpしておきます。
では、では、
標準モジュールの方は変更していません。
ここから更新しました 2018/3/25 15:00 なんか触れば触るほど、不具合が出て(￣▽￣;) 幸い誰も更新していないようなので更新しておきます。 トピ主さんが、やたら範囲の変更を気にされていたので 変数を一つ追加してなるべく書き換えが少ない様にしておきました。
これ↓シートモジュールへ
標準モジュールも触ったので載せておきます。
Option Explicit
Dim MyDate As Variant
'複数選択を不可にして SelectionChange と1対1で対応します。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyA As Variant
Dim MyS As Variant
Dim MyKey As String
Dim MyTblA As Range
Dim MyTblB As Range
Dim MyCoulmnB As Long
Dim x As Variant
Dim r As Long
Dim j As Long
Set MyTblA = Intersect(Target, Range("D:F"))
If MyTblA Is Nothing Then Exit Sub
'Range("D:F") を超えると終了 全選択オーバーフローに対応
If MyTblA.Count >= 3145728 Then
Set MyTblA = Nothing
Exit Sub
End If
If MyTblA.Count > 1 Then
If Application.CountA(MyDate) > 0 Then
If Application.CountA(Target) = 0 Then
If vbNo = MsgBox("選択範囲の日付に対応した項目は、" & vbCrLf & _
"削除されませんが、" & vbCrLf & _
"削除しますか？" & vbCrLf & vbCrLf & _
"削除する場合は、右クリックしてください。", vbYesNo + vbDefaultButton2) Then
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
Exit Sub
End If
End If
End If
Else
Application.ScreenUpdating = False
Application.EnableEvents = False
r = Target.Row
Set MyTblB = Range("G" & r & ":NG" & r)
MyCoulmnB = MyTblB.Column
x = Application.Match(Target.Value, Rows(1), 0)
MyKey = Left(Cells(1, Target.Column).Value, 2)
If IsDate(Target.Value) Then
x = Application.Match(CLng(Target.Value), Rows(1), 0)
If Not IsError(x) Then
MyA = MyTblB.Value
For j = LBound(MyA, 2) To UBound(MyA, 2)
MyA(1, j) = Replace(MyA(1, j), MyKey, "")
Next
MyA(1, x - (MyCoulmnB - 1)) = MyKey
MyTblB.Value = MyA
Else
MsgBox Format(Target.Value, "yyyy/mm/dd") & " を検索出来ませんでした"
End If
ElseIf IsEmpty(Target.Value) Then
x = Application.Match(CLng(MyDate), Rows(1), 0)
If Not IsError(x) Then
MyA = MyTblB.Value
For j = LBound(MyA, 2) To UBound(MyA, 2)
MyA(1, j) = Replace(MyA(1, j), MyKey, "")
Next
MyTblB.Value = MyA
Else
If MyDate > 0 Then
MsgBox Format(MyDate, "yyyy/mm/dd") & " を検索出来ませんでした"
End If
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
If IsArray(MyA) Then Erase MyA
End If
Set MyTblA = Nothing
Set MyTblB = Nothing
End Sub
'直前の日付をMyDateに格納します。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim MyTbl As Range
Set MyTbl = Intersect(Target, Range("D:F"))
'Range("D:F") を超えると終了 全選択オーバーフローに対応
If MyTbl Is Nothing Then Exit Sub
If MyTbl.Count >= 3145728 Then Exit Sub
If MyTbl Is Nothing Then Exit Sub
If MyTbl.Count = 1 Then
If IsDate(Target.Value) * Not IsEmpty(Target.Value) Then
MyDate = Target.Value
Else
MyDate = Empty
End If
Else
MyDate = Selection.Value
End If
End Sub
'削除する時は範囲を選択して 右クリック で対応します。
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim MyTbl As Range
Dim k As Long
Dim MyMsg As String
Dim MyTimer As Single
Set MyTbl = Intersect(Target, Range("D:F"))
If MyTbl.Count >= 3145728 Then
MsgBox "処理能力を超えています。" & vbCrLf & "もう少し範囲を絞って下さい"
Set MyTbl = Nothing
Exit Sub
End If
If MyTbl.Count > 1 Then
If vbYes = MsgBox("選択範囲を削除しますか？", vbYesNo + vbDefaultButton2) Then
Cancel = True
With Application
.ScreenUpdating = False
.EnableEvents = False
MyTimer = Timer
'ここは
'Unionで､､か､､､め､､､は､､､め､､､､はぁぁ と
'全部まとめて､､か､､､め､､､は､､､め､､､､はぁぁ
'のコメントを交互に入れ替えて試してください
'---------------------------------------------------------------------------
' Unionで､､か､､､め､､､は､､､め､､､､はぁぁ Me, MyMsg, k
全部まとめて､､か､､､め､､､は､､､め､､､､はぁぁ Me, MyMsg, k
'---------------------------------------------------------------------------
.EnableEvents = True
.ScreenUpdating = False
End With
Else
Exit Sub
End If
Else
Exit Sub
End If
MsgBox "処理時間は" & vbCrLf & _
Format(Timer - MyTimer, "#0.######### 秒") & vbCrLf & _
"です。"
If k > 0 Then
MsgBox "以下の日付を検索出来ませんでした。" & vbCrLf & MyMsg
Else
MsgBox "処理が完了しました"
End If
Set MyTbl = Nothing
End Sub
これ↓を標準モジュールへ
Option Explicit
'ここネーミングは適当に変えて下さい。
'この溜める感じがいいでしょ？
Sub Unionで､､か､､､め､､､は､､､め､､､､はぁぁ( _
ByVal MySh As Worksheet, _
ByRef MyMsgA As String, _
ByRef n As Long)
Dim y() As Variant
Dim x As Variant
Dim MyTblA As Range
Dim MyTblB As Range
Dim MyUnionA As Range
Dim MyUnionB As Range
Dim rr As Range
Dim r As Range
With MySh
Set MyTblA = .Range("D:F")
Set MyTblB = .Range("G:NG")
MyTblA.Interior.ColorIndex = xlNone
MyTblB.Interior.ColorIndex = xlNone
If Not Intersect(Selection, MyTblA) Is Nothing Then
For Each rr In Intersect(Selection, MyTblA).Areas
For Each r In rr
If r.Value <> "" Then
If IsDate(r.Value) Then
x = Application.Match(CLng(r.Value), .Rows(1), 0)
If Not IsError(x) Then
If MyUnionA Is Nothing Then
Set MyUnionA = r
Else
Set MyUnionA = Union(MyUnionA, r)
End If
If MyUnionB Is Nothing Then
Set MyUnionB = .Cells(r.Row, x)
Else
Set MyUnionB = Union(MyUnionB, .Cells(r.Row, x))
End If
Else
n = n + 1
ReDim Preserve y(n)
y(n) = r.Value
MyMsgA = Join(y, vbCrLf)
End If
End If
End If
Next
Next
End If
'消しちゃうと分からないので色を付けてます。
'適当に応用してください
Application.ScreenUpdating = False
MyUnionA.Interior.ColorIndex = 3
MyUnionB.Interior.ColorIndex = 7
' MyUnionA.ClearContents
' MyUnionB.ClearContents
Application.ScreenUpdating = True
Set MyTblA = Nothing
Set MyTblB = Nothing
End With
End Sub
'ここネーミングは適当に変えて下さい。
'この溜める感じがいいでしょ？
Sub 全部まとめて､､か､､､め､､､は､､､め､､､､はぁぁ( _
ByVal MySh As Worksheet, _
ByRef MyMsgA As String, _
ByRef n As Long)
Dim MyA As Variant
Dim MyB As Variant
Dim y() As Variant
Dim x As Variant
Dim MyTblA As Range
Dim MyTblB As Range
Dim MyUnionA As Range
Dim rr As Range
Dim r As Range
Dim MyColumnA As Long
Dim MyColumnB As Long
With MySh
Set MyTblA = .Range("D:F")
Set MyTblB = .Range("G:NG")
MyColumnA = MyTblA.Column
MyColumnB = MyTblB.Column
MyA = Intersect(.UsedRange, MyTblA).Value
MyB = Intersect(.UsedRange, MyTblB).Value
If Not Intersect(Selection, MyTblA) Is Nothing Then
For Each rr In Intersect(Selection, MyTblA).Areas
For Each r In rr
If r.Value <> "" Then
If IsDate(r.Value) Then
x = Application.Match(CLng(r.Value), .Rows(1), 0)
If Not IsError(x) Then
'消しちゃうと分からないので アドレスにしています。
MyA(r.Row, r.Column - (MyColumnA - 1)) = r.Address(0, 0)
MyB(r.Row, x - (MyColumnB - 1)) = r.Address(0, 0)
' MyA(r.Row, r.Column - 3) = ""
' MyB(r.Row, x - 6) = ""
Else
n = n + 1
ReDim Preserve y(n)
y(n) = r.Value
MyMsgA = Join(y, vbCrLf)
End If
End If
End If
Next
Next
End If
Application.ScreenUpdating = False
.Range("D1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value = MyA
.Range("G1").Resize(UBound(MyB, 1), UBound(MyB, 2)).Value = MyB
Application.ScreenUpdating = True
Set MyTblA = Nothing
Set MyTblB = Nothing
Erase MyA, MyB
End With
End Sub
すみません。 配列のところどうせループするんだから違いますね???? 後で、ゆっくりとみてみます。
すみません。二回目時 Nothing になりますね (^^; 修正しておきました。
まだ、ちょっと長いね(￣▽￣;) 今日もあてるぞぉ～～～～～～ ひぃひぃ～～～～～ん！！！！ v(=∩_∩=)v
Changeイベントは複数選択を許可するとややこしいね
もうすぐ走りまぁ～～～～～す。
差せ！差せ！差せ！差せ！させぇ～～～～～！！！！
v(=∩_∩=)v （SoulMan） 2018/03/25(日) 10:29
皆様色々とご回答いただきありがとうございます。 皆様に頂いたものを理解できるように勉強に励みます。
（いちか） 2018/03/28(水) 23:33
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.