[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『矢印の起点と終点の日付を習得したい』(もも初心者)
マクロ初心者です。
コードを入力する際にそのコードが何の作業をするコードなのか、
併せてコメントも記入して頂けると大変助かります。
●やりたいこと
・矢印の起点(開始日)と終点(終了日)を日付の列から習得し、矢印がある期間の列に入力したい(9/18〜9/19という形で)
ガントチャートでいうと、開始日と終了日を日付から探して矢印を引く作業と逆で、既に引いてある矢印から開始日と終了日を取得して期間を入力したい
●シートの状態
列 B C D E F G H I…
行3 期間 9/18 9/19 9/20 9/21 …一年間の日付が続く
4 日 月 火 水 5 6 7 9/18〜9/19 ↔
●詳細
上記の場合、E7〜F7に矢印あったら、D7に開始日〜終了日を入力する
< 使用 Excel:Excel2016、使用 OS:Windows7 >
矢印は複数あるのですか。 矢印の数だけ開始日〜終了日を表示させるのですか。
(?) 2022/09/30(金) 08:25
Sub sammple() Dim shp As Shape Dim sDay As Date, eday As Date For Each shp In ActiveSheet.Shapes sDay = Intersect(shp.TopLeftCell.EntireColumn, Rows(3)).Value eday = Intersect(shp.BottomRightCell.EntireColumn, Rows(3)).Value Intersect(shp.TopLeftCell.EntireRow, Columns("D")).Value = sDay & "-" & eday Next End Sub
(´・ω・`) 2022/09/30(金) 09:33
Sub Sample() Dim shp As Shape Dim ws As Worksheet Dim indexRow As Long Dim lastColumn As Long Dim c As Long 'ワークシートを設定(アクティブシート) Set ws = ActiveSheet '日付の記入してある行を設定(3行目) indexRow = 3 '出力する列を設定(D列) c = 4 '日付の記入してある最後の列を取得 lastColumn = ws.Cells(indexRow, Columns.Count).End(xlToLeft).Column 'シート上のオートシェイプを巡回 For Each shp In ws.Shapes With shp '条件 '「オートシェイプの左上セルと右下セルの行が同一」 '「日付の記入してある行より下にある」 '「出力する列の右側で日付の記入してある列の最後の列までの間にある」 '「オートシェイプの先が矢印無しになっていない」 If .TopLeftCell.Row = .BottomRightCell.Row And _ .TopLeftCell.Row > indexRow And _ .TopLeftCell.Column > c And .TopLeftCell.Column <= lastColumn And _ .BottomRightCell.Column > c And .BottomRightCell.Column <= lastColumn And _ .ShapeRange.Line.BeginArrowheadStyle <> msoArrowheadNone And _ .ShapeRange.Line.EndArrowheadStyle <> msoArrowheadNone Then 'すべての条件を満たしたとき Dim d1 As Double Dim d2 As Double Dim str As String '左上セルと右下セルのある列の日付行のデータを取得し '「小さい方の日付〜大きい方の日付」の文字列を生成 d1 = ws.Cells(indexRow, ws.TopLeftCell.Column).Value d2 = ws.Cells(indexRow, ws.BottomRightCell.Column).Value If d1 > d2 Then str = Format(d2, "m/d") & "〜" & Format(d1, "m/d") Else str = Format(d1, "m/d") & "〜" & Format(d2, "m/d") End If 'オートシェイプのある行の出力する列に記入する ws.Cells(ws.TopLeftCell.Row, c).Value = str End If End With Next End Sub
練習問題のつもりで作ってみました。
ももさんの考えているものと違っていたらすみません。
(下手の横好き) 2022/09/30(金) 09:43
?@矢印はオートシェイプです。マクロです。
矢印を引きたいセルを選択して実行ボタンを押すと
矢印が引けるようになってます。
↑これは私が作ってません。。
?A矢印の数ですが、例えばB7には作業内容が入るのですが
一つの作業内容につき矢印は1つだけです。
?Bコード記載して頂いた方へ
ありがとうございます!!検証してみます。
そして私の方でも一つ一つコードを解読していきますので、
わからないことが発生した場合またご質問させてください。。
(もも初心者) 2022/09/30(金) 10:43
Sub Sample() Dim shp As Shape Dim ws As Worksheet Dim indexRow As Long Dim lastColumn As Long Dim c As Long 'ワークシートを設定(アクティブシート) Set ws = ActiveSheet '日付の記入してある行を設定(3行目) indexRow = 3 '出力する列を設定(D列) c = 4 '日付の記入してある最後の列を取得 lastColumn = ws.Cells(indexRow, Columns.Count).End(xlToLeft).Column 'シート上のオートシェイプを巡回 For Each shp In ws.Shapes With shp '条件 '「オートシェイプの左上セルと右下セルの行が同一」 '「日付の記入してある行より下にある」 '「出力する列の右側で日付の記入してある列の最後の列までの間にある」 '「オートシェイプの先が矢印無しになっていない」 '※直線以外のオートシェイプがあるとエラーになる If .TopLeftCell.Row = .BottomRightCell.Row And _ .TopLeftCell.Row > indexRow And _ .TopLeftCell.Column > c And .TopLeftCell.Column <= lastColumn And _ .BottomRightCell.Column > c And .BottomRightCell.Column <= lastColumn And _ .ShapeRange.Line.BeginArrowheadStyle <> msoArrowheadNone And _ .ShapeRange.Line.EndArrowheadStyle <> msoArrowheadNone Then 'すべての条件を満たしたとき Dim d1 As Double Dim d2 As Double Dim str As String '左上セルと右下セルのある列の日付行のデータを取得し '「小さい方の日付〜大きい方の日付」の文字列を生成 d1 = ws.Cells(indexRow, .TopLeftCell.Column).Value d2 = ws.Cells(indexRow, .BottomRightCell.Column).Value If d1 > d2 Then str = Format(d2, "m/d") & "〜" & Format(d1, "m/d") Else str = Format(d1, "m/d") & "〜" & Format(d2, "m/d") End If 'オートシェイプのある行の出力する列に記入する ws.Cells(.TopLeftCell.Row, c).Value = str End If End With Next End Sub
問題があったので少し修正しました。
(下手の横好き) 2022/09/30(金) 10:51
どの行でエラーがでますか?
3行目に日付と解釈できない文字列が入力されているとしか、エラーの原因は想像できないです
Dim sDay As Date, eday As Date ' この行を削除してみてください (´・ω・`) 2022/10/04(火) 14:37
あ、D3セルに、"期間" て文字列が入ってますね 線の左端がD列にちょっとだけかかっている線があるんだとおもいます (´・ω・`) 2022/10/04(火) 14:44
Sub Sample() Dim shp As Shape Dim ws As Worksheet Dim indexRow As Long Dim lastColumn As Long Dim tlRow As Long Dim brColumn As Long Dim c As Long
Set ws = ActiveSheet 'ワークシートを設定(アクティブシート) indexRow = 3 '日付行を設定(3行目) c = 4 '出力列を設定(D列)
lastColumn = ws.Cells(indexRow, Columns.Count).End(xlToLeft).Column '日付の記入してある最後の列を取得 For Each shp In ws.Shapes 'シート上のオートシェイプを巡回 With shp tlRow = .TopLeftCell.Row tlColumn = .TopLeftCell.Column brColumn = .BottomRightCell.Column Select Case True '以下の条件のときは日付を出力しない Case .Type <> msoLine '「直線以外」 Case tlRow <> .BottomRightCell.Row '「オートシェイプの左上セルと右下セルの行が同一でない」 Case tlRow <= indexRow '「日付の記入してある行以上にある」 Case tlColumn <= c '「オートシェイプ左端が出力する列以下にある」 Case brColumn > lastColumn '「オートシェイプ右端が最終列より右にある」 Case Else 'すべての条件を満たしたとき '左上セルと右下セルのある列の日付行のデータを取得し文字列を生成し 'オートシェイプのある行の出力列に記入する Dim d1 As String Dim d2 As String Dim str As String d1 = Format(ws.Cells(indexRow, tlColumn).Value, "m/d") '日付1 d2 = Format(ws.Cells(indexRow, brColumn).Value, "m/d") '日付2 If d1 <> d2 Then d1 = d1 & "〜" & d2 '日付1と日付2が別の日なら「日付1〜日付2」にする str = ws.Cells(tlRow, c).Value '出力列の値を変数に入れる If str <> "" Then 'すでに出力列に値がある場合は str = str & "、" & d1 '「、」区切りで繋げる Else '値が無い場合は str = d1 '日付文字列を入れる End If ws.Cells(tlRow, c).Value = str '出力列の値を書き換える End Select End With Next End Sub
エラー改修版とおまけつきのものに書き換えてみました。
(下手の横好き) 2022/10/06(木) 17:13
Sub Sample() Dim shp As Shape Dim ws As Worksheet Dim indexRow As Long Dim lastColumn As Long Dim tlRow As Long Dim tlColumn As Long Dim brColumn As Long Dim barType As Long Dim c As Long
Set ws = ActiveSheet 'ワークシートを設定(アクティブシート) indexRow = 3 '日付行を設定(3行目) c = 4 '出力列を設定(D列) barType = msoLine '対象となるオートシェイプのタイプ(直線)※四角の場合は「msoShapeRectangle」に変更
lastColumn = ws.Cells(indexRow, Columns.Count).End(xlToLeft).Column '日付の記入してある最後の列を取得 For Each shp In ws.Shapes 'シート上のオートシェイプを巡回 With shp tlRow = .TopLeftCell.Row '左上セルの行の値を変数に入れる tlColumn = .TopLeftCell.Column '左上セルの列の値を変数に入れる brColumn = .BottomRightCell.Column '右下セルの列の値を変数に入れる Select Case True '以下の条件のときは日付を出力しない Case .Type <> barType '「対象となるオートシェイプの種類以外」 Case tlRow <> .BottomRightCell.Row '「オートシェイプの左上セルと右下セルの行が同一でない」 Case tlRow <= indexRow '「日付の記入してある行以上にある」 Case tlColumn <= c '「オートシェイプ左端が出力する列以下にある」 Case brColumn > lastColumn '「オートシェイプ右端が最終列より右にある」 Case Else 'すべての条件を満たしたとき '左上セルと右下セルのある列の日付行のデータを取得し文字列を生成し 'オートシェイプのある行の出力列に記入する Dim d1 As String Dim d2 As String Dim str As String d1 = Format(ws.Cells(indexRow, tlColumn).Value, "m/d") '日付1 d2 = Format(ws.Cells(indexRow, brColumn).Value, "m/d") '日付2 If d1 <> d2 Then d1 = d1 & "〜" & d2 '日付1と日付2が別の日なら「日付1〜日付2」にする str = ws.Cells(tlRow, c).Value '出力列の値を変数に入れる If str <> "" Then 'すでに出力列に値がある場合は str = str & "、" & d1 '「、」区切りで繋げる Else '値が無い場合は str = d1 '日付文字列を入れる End If ws.Cells(tlRow, c).Value = str '出力列の値を書き換える End Select End With Next End Sub
変数の宣言忘れがありました。xhoさんご指摘感謝です。
ついでにまた余計なものを付け足してみました。
(下手の横好き) 2022/10/07(金) 09:08:24
↑ >ついでにまた余計なものを付け足してみました。 実行するたびに同じ日付が「、」で区切られていく仕様なんですか。
|[C]|[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] [1] | | | | | | | | | [2] | | | | | | | | | [3] | |期間 |9/18|9/19|9/20|9/21|9/22|9/23|9/24 [4] | | |日 |月 |火 |水 |木 |金 |土 [5] | | | | | | | | | [6] | | | | | | | | | [7] | |9/18〜9/20、9/18〜9/20、9/18〜9/20|□□|□□| | | | | [8] | |9/19〜9/22、9/19〜9/22、9/19〜9/22| |□□|□□|□□| | | [9] | |9/20〜9/24、9/20〜9/24、9/20〜9/24| | |□□|□□|□□|□□| [10]| | | | | | | | |
(xho) 2022/10/07(金) 11:23:41
横合いから失礼します。
指摘がありました、 >線の左端がD列にちょっとだけかかっている線があるんだとおもいます についてのご返事がないようです。
つまり、矢印が想定している日付のセル位置より少しだけ飛び出したりしているかどうか、という点です。 ここが解決できないと、図形のある位置の判定が狂ってくるので、 その他の皆さんのアプローチもすべて、そこが障害になります。
実際のところどうなんでしょうか。 質問者さんからのコメントが待たれます。 (そんなことはありません、とか、一部にありましたが解決しましたとか) その回答が無いと前に進まないように思います。
なお、もし図形を描く現行の処理のなかで図形のズレが生じているなら、そこの手当が必要でしょうし、 同時に日付も書き込むように変更すれば良いと思います。 そうすれば、今検討している作業自体がゆくゆくは省略できるはずですから。 (γ) 2022/10/07(金) 18:49:24
セル範囲を択んでボタン押したら線引いて日付も入れるってんならそれはそれで簡単なんですけどね 質問者さんが再登場するまではペンディングてすね (´・ω・`) 2022/10/07(金) 19:05:13
Sub 矢印選択日付() Dim NA Dim TL Dim BR Dim RO If VarType(Selection) = vbObject Then NA = Selection.Name TL = ActiveSheet.Shapes(NA).TopLeftCell.Address(False, False) BR = ActiveSheet.Shapes(NA).BottomRightCell.Offset(0, -1).Address(False, False) Range(TL).Select RO = Selection.Row Range("D" & RO).Value = Format(Range(TL).End(xlUp).Offset(-1, 0).Value, "mm/dd") & _ " 〜 " & Format(Range(BR).End(xlUp).Offset(-1, 0).Value, "mm/dd") MsgBox "開始日 " & Format(Range(TL).End(xlUp).Offset(-1, 0).Value, "mm/dd") & vbCrLf & _ "終了日 " & Format(Range(BR).End(xlUp).Offset(-1, 0).Value, "mm/dd") Else MsgBox "矢印を選択してください。" End If End Sub (?) 2022/10/13(木) 17:15:15
線の左端がD列にかかっている 私が「13:型が一致しません」とエラーが出ると言いましたが、
Rows(3)を4に変更したところ作動しました!
ですがまた別問題が発生しました(´・_・`)
問題点1
矢印の終点の日付が合わない、1日先に進んでいる
例:終点が9月30日なのに10月1日で読み取ってしまう
問題点2
D1に「0:00:00〜0:00:00」が表示され、マクロ終了後も残ってしまう
(もも初心者) 2022/10/14(金) 14:55:54
開始日と終了日から日付を読み取り矢印を引くコードは
検索すると出てくるのですが、私のように、
既にある「選択したセル範囲に矢印を引くマクロ」がある場合、
作成された矢印から日付を読み取るマクロを作るのは
効率悪い作業なんですかね、、?
(もも初心者) 2022/10/14(金) 15:01:48
(もも初心者) 2022/10/14(金) 15:12:24
>Rows(3)を4に変更したところ作動 日付は3行目だったのでは? シートのレイアウトを変更したならそういってもらわないとわかりませんよ
>矢印の終点の日付が合わない、1日先に進んでいる ShapeのBottomRightCellがそうなっているので、矢印の終点がはみ出してるんでしょう たぶん 線を引くマクロの方で対応すべき案件と思います。
>D1に「0:00:00〜0:00:00」が表示され 1行目にShapeがあるんでしょう Shapeがあれば、その行に書き出しますので、コマンドボタンとか配置してればそうなります。
ご自分で対処可能と思いますし、いろいろな回答者の方からよいマクロが提示されてますので 私はここで退場します。 (´・ω・`) 2022/10/14(金) 16:23:07
>Rows(3)を4に変更したところ作動しました! 日付の行が変動してもいいように End(xlUp )で対応している。 >矢印の終点の日付が合わない、1日先に進んでいる ShapeのBottomRightCell はそういう仕様になっているので Offset(0, -1) で対応している。 >D1に「0:00:00〜0:00:00」が表示され D7 の間違いではないですか。 こちらでは D7 に表示されましたが。 (?) 2022/10/14(金) 17:27:09
D1に表示される件ですが、D1に矢印作成ボタンを設置していますので
図形があるからそこにも表示されるのですね、理解できました!
でもそれは最後に手動で消せば問題なさそうです。
D7にも日付入ってます!私が実現したかったことが叶っています。
あとは終了日が1日先に進んでしまっているので、そこを改善するには
終点の矢印を調べれば一歩近づくということですよね。
(もも初心者) 2022/10/15(土) 11:47:01
>あとは終了日が1日先に進んでしまっているので それについては(?) 2022/10/14(金) 17:27:09 で回答しているのですが。 (?) 2022/10/15(土) 12:16:12
一括処理にしてみました。
Sub 一括処理() Dim na Dim tl Dim br Dim ro Dim ws As Worksheet Set ws = ActiveSheet For Each na In ws.Shapes If na.Name Like "Straight Connector *" Then na.Select Replace:=True na = Selection.Name tl = ActiveSheet.Shapes(na).TopLeftCell.Address(False, False) br = ActiveSheet.Shapes(na).BottomRightCell.Offset(0, -1).Address(False, False) Range(tl).Select ro = Selection.Row Range("D" & ro).Value = Format(Range(tl).End(xlUp).Offset(-1, 0).Value, "mm/dd") & _ " 〜 " & Format(Range(br).End(xlUp).Offset(-1, 0).Value, "mm/dd") End If Next Range("A1").Select '図形選択を解除します。 End Sub
変数の型は手抜きです。 処理速度は考慮していません。
矢印を消したら日付も消える。またはその逆を考察中です。 お楽しみに いつになるか分からないけど
(?) 2022/10/15(土) 19:54:23
Sub 選択範囲の各行に両矢印を引いて日付をいれる() Dim aArea As Range, aRow As Range Dim xl As Double, xr As Double, y As Double Dim sDay As Date, eDay As Date If TypeName(Selection) <> "Range" Then Exit Sub For Each aArea In Selection.Areas For Each aRow In aArea.Rows xl = aRow.Left xr = xl + aRow.Width ' 位置調整 y = aRow.Top + aRow.Height / 2 With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, xl, y, xr, y) .Line.BeginArrowheadStyle = msoArrowheadTriangle .Line.EndArrowheadStyle = msoArrowheadTriangle sDay = Intersect(aRow.Cells(1, 1).EntireColumn, Rows(4)).Value eDay = Intersect(aRow.Cells(1, aRow.Cells.Count).EntireColumn, Rows(4)).Value aRow.EntireRow.Cells(1, "D").Value = sDay & "〜" & eDay End With Next Next End Sub (´・ω・`) 2022/10/15(土) 20:06:23
日付を読み取るために
列と行が交差するセルは何かを読み取るという考えに辿り着けず
図形の位置を読み取ってその後どうすればいいのか…と考えを繰り返していました。
ここに掲載してくださった方のひとつひとつコードを
検索して調べるという作業を繰り返していました。
時間を頂戴し、不快な思いをさせてしまった方本当にすみません。
コードの作業にコメント付けてくださった方、とても勉強になりました。。
今同時に本を読みながら勉強進めているので
次質問した際は今より理解度が進んだ状態でまた皆さんと関われるようにします。
(もも初心者) 2022/10/18(火) 08:12:02
>そして完成形にたどり着けました。 その完成形が提示されないということはいずれかの回答者のコードを そのまま流用しているとしか思えない。 (ただよりやすいものはない) 2022/10/18(火) 08:29:44
詰まらない書き込みにいちいち付き合う必要はないです。 軽くイナすのも、社会人としての必須テクニックです。
逆に、そんなやり取りに妙に長けている質問者もたまにいますが、 それもまたうんざりですけどね。
色々な思惑の質問者と回答者が混在しているので、自分にフィットする 回答者が現れるのを待つのも手です。あまり、気を使い過ぎると疲れますよ。
(半平太) 2022/10/18(火) 10:50:37
日付と矢印を設定した後の修正にどうぞ 矢印を選択して実行すると日付、矢印が削除できます。
Sub 矢印日付修正() Dim na Dim tl Dim br Dim ro If VarType(Selection) = vbObject Then na = Selection.Name tl = ActiveSheet.Shapes(na).TopLeftCell.Address(False, False) Range(tl).Select ro = Selection.Row Range("D" & ro).Clear ActiveSheet.Shapes(na).Delete Else MsgBox "矢印を選択してください。" End If End Sub
ちなみに矢印を引くコードはこれでした。
Sub 選択範囲に矢印作成() Dim targetRng Set targetRng = Selection With ActiveSheet.Shapes.AddLine(targetRng.Left, targetRng.Top + targetRng.Height / 2, _ targetRng.Left + targetRng.Width, targetRng.Top + targetRng.Height / 2).Line .ForeColor.RGB = RGB(255, 0, 0) .Weight = 3 .EndArrowheadStyle = 2 End With End Sub
今までのコード解説必要ですか。
(?) 2022/10/18(火) 21:40:50
新たな条件が発生してしまい、ここに掲載してくださった方々のコードをもとに
自分で考えたコードも追加して作成しているところです。
ですがエラーは起きていなくても作動しないためまた別日に相談しようと思っています。
ただ、?さんが教えてくださったコードも含め、
流用してしまっているので不快に思う方もいるかと思い、恐る恐るですが。。
(もも初心者) 2022/10/22(土) 19:02:31
>自分で考えたコードも追加して作成しているところです。 でしたら恐れることはありませんよ。 (?) 2022/10/22(土) 20:19:06
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.