[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『答えによって、オートシェイプで〇をつけたいです。』（ちえこ）
AJ26に数字が出るんですが、1の場合はF26に〇
2の場合には、F27に〇
3の場合には、F31に〇を付けたいです。
AJ26は数字がない場合もあります。
その場合には、〇は表示しないようにしたいです。
宜しくお願いします。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
数式で◯の表示を切り替える、ではだめですか？
シェイプに拘るのなら、画像の切り替え、という方法があります。 シェイプで使えるかは未検証です。
http://www.officetanaka.net/excel/function/tips/tips14.htm
（OK） 2020/06/05(金) 17:40
わざわざ何枚も付けてるのは、面倒なので答えを選んだら自動的に丸がつくように、したいのです。
（ちえこ） 2020/06/05(金) 21:54
オートシェイプに拘る理由になってません。 説明聞いて、なお数式の方がいいのでは？と 思うのですが。 （OK） 2020/06/05(金) 21:55
たぶん、AJ26に1を入力したときに、 例えばF26に、1.はい みたいものを入力しておき、その「1.」のところにオートシェイプで ○を重ねて表示したい・・・みたいなことかと、勝手に想像しています。
（自信なし） 2020/06/05(金) 22:14
おはようございます。。 一応、動作確認はした。。。つもり、、です。 シートモジュールに貼り付けます。。。 どうかなぁ？？？
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$AJ$26" Then Exit Sub
Select Case Target.Value
Case 1
kk Me, Me.Range("F26")
Case 2
kk Me, Me.Range("F27")
Case 3
kk Me, Me.Range("F31")
Case Else
kk Me
End Select
End Sub
Sub kk(ByVal MySh As Worksheet, Optional ByVal r As Range)
Dim myshap As Shape
With MySh
For Each myshap In .Shapes
If Not Intersect(.Range("F26,F27,F31"), .Range(myshap.TopLeftCell.Address, .Range(myshap.BottomRightCell.Address))) Is Nothing Then
myshap.Delete
End If
Next
If Not r Is Nothing Then
With .Shapes.AddShape(msoShapeOval, r.Left, r.Top, r.Width, r.Height)
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 1
End With
End If
End With
End Sub
（SoulMan） 2020/06/06(土) 06:24
SoulManさま おはようございます ＾＾ バッチぐ〜ですよ (*^^*)ｖ m(_ _)m （隠居じーさん） 2020/06/06(土) 07:41
オートシェープは、あらかじめ適正な位置に、適正な大きさで貼り付けてある気がするなぁ。 すると、単に表示/非表示を切り替えればよさそう。
図形が楕円1〜3だとして、以下のマクロをシートモジュールに貼り付け
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "AJ26" Then
Me.Shapes.Range(Array("Oval 1", "Oval 2", "Oval 3")).Visible = msoFalse
Select Case Target.Value
Case 1: Me.Shapes("Oval 1").Visible = msoCTrue
Case 2: Me.Shapes("Oval 2").Visible = msoCTrue
Case 3: Me.Shapes("Oval 3").Visible = msoCTrue
End Select
End If
End Sub
（半平太） 2020/06/06(土) 08:12
| AJ26に数字が出るんですが、 出るという言葉からすると、 AJ26は式が入っていて、直接の入力項目ではないということはありますか？ AJ26に範囲を限定したChangeイベントプロシージャでは捕捉できないかも。
| わざわざ何枚も付けてるのは、面倒なので ここの意味がよくわからないです。何枚もつける、とは？
ちなみに、AJ26に相当する箇所はどのくらいの数があるんですか？ その辺も、質問者さんが実際にコードを書かれるときにポイントになりそうな気がします。 （γ） 2020/06/06(土) 10:33
ありがとうございます。
AJ26はVLOOKUPが入っています。
その答えをもとにオートシェイプで〇を付けます。
会社の決まられている書類なので、沢山作成するので、
いちいち〇を付けているのが面倒なので、お願いしてみました。
いろいろ試してみたいと思います。
（ちえこ） 2020/06/08(月) 08:58
>いちいち〇を付けているのが面倒なので、 オートシェイプを何枚も作成する方がもっと面倒と思うけど。 >お願いしてみました。 それに関する回答がほとんどないのはなぜか。回答者に対する態度が悪い。 （touda） 2020/06/08(月) 09:32
オートシェイプが面倒だから自動化するのに相談してみただけなのに、
そんな言われ方するなんて酷いです。
解らないから相談するのがいけないんですか？
（ちえこ） 2020/06/08(月) 10:49
他人が口を挟むようですけど >そんなつもりありません。 だったら回答者に返信するのが常識だと私は思います。 （wakara） 2020/06/08(月) 11:53
一例ですけど、
If Not Intersect(Target, Range("B1").Precedents) Is Nothing Then
など。
（ただし、Precedentsはそのシート内に限定されるので、他シート参照していたらさらに
そこも見る必要がありますかね）
あとは頑張ってください。
（γ） 2020/06/08(月) 13:21
（γ） 2020/06/08(月) 16:31
明日会社でやってみます。
（ちえこ） 2020/06/08(月) 23:32
こんばんは！ 見逃してましたぁ(^^; AJ26の値が計算式によって変更された時という事なら楕円を書くコードは同じで Changeを以下に差し替えて下さい。。。
Option Explicit
Private Sub Worksheet_Calculate()
Static x As Variant
If x = Me.Range("AJ26").Value Then Exit Sub
Select Case Me.Range("AJ26").Value
Case 1
kk Me, Me.Range("F26")
Case 2
kk Me, Me.Range("F27")
Case 3
kk Me, Me.Range("F31")
Case Else
kk Me
End Select
x = Me.Range("AJ26").Value
End Sub
隠居じーさん さん いつもありがとうございます。 返事すると怒られますからね(^^; 楽しくいきましょうね v(=∩_∩=)v （SoulMan） 2020/06/09(火) 19:21
こんばんは ＾＾ 。。。 何時も、お気遣いありがとうございます。 良い加減な、ことばかり、言いまして大変、相済みません。 ＞＞楽しくいきましょうね v(=∩_∩=)v 同感です。 ちえこさん、横入りすみませんでした。 m(_ _)m （隠居じーさん） 2020/06/09(火) 19:51
（SoulMan） 2020/06/09(火) 19:21 （隠居じーさん） 2020/06/09(火) 19:51 ここは質問欄です。個人的な挨拶はやめようぜ。 閲覧していて不愉快になった人より （不愉快になった人） 2020/06/10(水) 09:10
お早うございます。
お返事ありがとうございます。
教えてくださった、マクロにするとSubまたはFunctoinが定義されてませんと出てしまいます。
どうしてでしょうか？
（ちえこ） 2020/06/15(月) 09:52
こんにちは ＾＾ SoulManさん多分いまお仕事で、夜しか、こちらには登校されないかもしれません。 あのぉ〜下にあった Sub kk
↓
End Sub 消していませんでしょうか。←恐る恐る。。。こわごわ ＾＾；。。。。m(_ _)m （隠居じーさん） 2020/06/15(月) 10:12
こんにちは。
ありがとうございます。
ちゃんと入っているんですが…？
出来ないというか動かないですね…
（ちえこ） 2020/06/15(月) 13:11
こんにちは ＾＾ そぉなんですね。こちらでは動いていますので、何か、動作環境が違うのでしょうね。 エラーメッセージを拝見させて戴いた限りでは、何らかの要因でｋｋと云うプロシジャー が認識されていないようです。どちらのモジュールに有るのか教えていただきますと、 お手伝い出来るかもしれません。m(_ _)m （隠居じーさん） 2020/06/15(月) 13:29
Private Sub Worksheet_Calculate()
Static x As Variant
If x = Me.Range("AJ26").Value Then Exit Sub
Select Case Me.Range("AJ26").Value
Case 1
kk Me, Me.Range("F26")
Case 2
kk Me, Me.Range("F27")
Case 3
kk Me, Me.Range("F31")
Case Else
kk Me
End Select
x = Me.Range("AJ26").Value
End Sub
chengeという所です。
間違っていますでしょうか？
発注書というシートにデータがあるんですけど、そこから開発を開いてコードをコピペしました。
kkという所が黄色くなりエラーが出ます。
宜しくお願いします。<(_ _)>
（ちえこ） 2020/06/15(月) 13:50
Sub kk(ByVal MySh As Worksheet, Optional ByVal r As Range)
Dim myshap As Shape
With MySh
For Each myshap In .Shapes
If Not Intersect(.Range("F26,F27,F31"), .Range(myshap.TopLeftCell.Address, .Range(myshap.BottomRightCell.Address))) Is Nothing Then
myshap.Delete
End If
Next
If Not r Is Nothing Then
With .Shapes.AddShape(msoShapeOval, r.Left, r.Top, r.Width, r.Height)
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 1
End With
End If
End With
End Sub
もし ↑ が 存在していませんでしたら、今ある、コードの下に ↑ を コピペ して、貼り付けてみて下さい。 ＾＾；。。。うまくいくと。。いいですね。m(_ _)m （隠居じーさん） 2020/06/15(月) 13:57
有難うございます。
やってみましたが、エラーは出なくなったものの、何も変化はありません。
他にもマクロがあるから、動かないのでしょうかね？
初心者なのでなんと説明していいのか分りませんが、ユーザーフォームで登録してその結果をVLOOKUPで検索して表示・印刷なのですが…
マクロは勉強しないとですね。
奥深い…(´;ω;｀)
（ちえこ） 2020/06/15(月) 14:54
こんにちは ＾＾ エラーは消えたのでしたら、今回はイベント処理が変更になっていますので。 ＞＞VLOOKUPで検索 ← これを変化させてあげると〇が表示されるはずな のですが。ご確認を、 ＞＞他にもマクロがあるから、動かないのでしょうかね？ 新規ブックのシートSheet1 にSoulmanさんのコードのみ、コピペして、ＡＪ２６ の数式を=Ａ２６にでもして、Ａ２６に1,2,3を順次入力してみて下さい。動くと思います。 （隠居じーさん） 2020/06/15(月) 16:45
こんばんは ＾＾ ↑の実験の件です。 お待たせいたしました、Sheet1のA26に =Sheet2!A1 といれて Sheet2のA1に入力してみて下さい。[ま、おなじかもですが ＾＾；] あと、一息！みたいなところまで来ていると思いますので、頑張ってくださいね ＞＞マクロは勉強しないとですね。 ＞＞ 奥深い…(´;ω;｀) わたしも同じですよ。でも完成すれば便利ですよね(#^^#) では。。。m(_ _)m （隠居じーさん） 2020/06/15(月) 17:34
こんにちは！ 取り敢えずシートモジュールに貼ってあるコードをそのまま ここへコピペしてください 先ずは新規Bookで検証しましょう それから実際のBookで試してみましょう （SoulMan） 2020/06/15(月) 18:38
こんばんは ＾＾ ＞＞お待たせいたしました、Sheet1のA26に =Sheet2!A1 といれて Sheet1のAJ26に =Sheet2!A1 といれて の間違いですね。済みませんでした。(￣▽￣)。。。(*^^*)///。m(_ _)m （隠居じーさん） 2020/06/15(月) 18:47
隠居じーさん さん いつもありがとうございます😊 再計算が行われたら動くでしょ？ （SoulMan） 2020/06/15(月) 19:15
今、↓このコードを新規Bookで検証しましたがVlookup関数でも動きましたよ？
ただ、Vlookupの様に検索値が見つからなかった時にエラーになる様なので
If IsError(Me.Range("AJ26").Value) Then Exit Sub
を追加しました。。。。
再計算が行われて、、、x が変化して １か２か３だったら引っ掛かると思いますが、、、どうでしょう？？？
Option Explicit
Private Sub Worksheet_Calculate()
Static x As Variant
If IsError(Me.Range("AJ26").Value) Then Exit Sub
If x = Me.Range("AJ26").Value Then Exit Sub
Select Case Me.Range("AJ26").Value
Case 1
kk Me, Me.Range("F26")
Case 2
kk Me, Me.Range("F27")
Case 3
kk Me, Me.Range("F31")
Case Else
kk Me
End Select
x = Me.Range("AJ26").Value
End Sub
Sub kk(ByVal MySh As Worksheet, Optional ByVal r As Range)
Dim myshap As Shape
With MySh
For Each myshap In .Shapes
If Not Intersect(.Range("F26,F27,F31"), .Range(myshap.TopLeftCell.Address, .Range(myshap.BottomRightCell.Address))) Is Nothing Then
myshap.Delete
End If
Next
If Not r Is Nothing Then
With .Shapes.AddShape(msoShapeOval, r.Left, r.Top, r.Width, r.Height)
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 1
End With
End If
End With
End Sub
（SoulMan） 2020/06/15(月) 20:29
SoulMan さん こんばんは ＾＾ こちらこそ、何時も済みません。 あえて、ｘ様はおられなくても動くような気が しないでは有りませんが。。。＾＾；。m(_ _)m はい。 いまこちらもテストしてみました。 修正已前も動いていましたので、なにが原因 となっているのでしょうね、他にもマクロが あるとの事でしたので、そちらでしょうかね ちえこ さん にお聞きするしか無いかもしれ ませんね。m(_ _)m （隠居じーさん） 2020/06/15(月) 21:40
>あえて、ｘ様はおられなくても動くような気が あっははは、、ですよねぇ(^^; 同じときは再計算しませんものねぇ？？？ 何か勘違いしてたかな？？？ ありがとうございます。。。 流石ですね。。。せんせいm(__)m （SoulMan） 2020/06/15(月) 21:50
出来ました。
本チャン頑張ってみます。
（ちえこ） 2020/06/16(火) 09:33
実際のファイルでやってみた所、実行時エラー1004
アプリケーション定義またはオブジェクト定義エラーですと出てしまいました。
他のマクロが関係してますかね？
新規Bookの時は動いたのですが、ダメでした。
他のマクロも載せておいたほうがよろしいですかね？
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'-----------------------------------------------------------------------------------------------
Dim lngRow As Long ' 行INDEX
If Target.Column <> 1 Or Target.Count > 1 Then Exit Sub
lngRow = Target.Row
' 登録処理を呼び出す(引数は選択行)
Call TOUROKU(lngRow)
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
Sub main()
Dim c As Range, sht As Worksheet
For Each c In Sheets("data").Range("W2:W" & Rows.Count).SpecialCells(2)
Do
For Each sht In Worksheets
If sht.Name = c.Value & "月" Then
Intersect(Sheets("data").Range("AJ:AU"), c.EntireRow).Copy
sht.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Exit Do
End If
Next sht
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = c.Value & "月"
'Sheets("data").Rows(1).Copy Worksheets(Worksheets.Count).Range("A4")
Sheets("data").Range("AJ1:AU1").Copy Worksheets(Worksheets.Count).Range("A4")
Loop
Next c
End Sub
（ちえこ） 2020/06/16(火) 09:45
こんにちは ＾＾ すみません、外出いたしておりました。 停止したプロシジャー名と コード、停止箇所等が、お解りでしたら こちらに貼り付けてやってください。
今現在［ちょい見では］？状態なので 今から、ちょっと見てみますね。。。 下のSub mainは同じシートモジュールにあるのでしょうか。 どこかで拝見したことがある様なないような。。。＾＾； 引き続き他の方の回答もお待ちくださいね。m(_ _)m （隠居じーさん） 2020/06/16(火) 11:19
ユーザーフォームで登録しています。
↑のコードはmodule1に書いてあります。
↑のコードも未完成でこちらも困っています。
中々一度では伝わらないですね。
宜しくお願いします。
（ちえこ） 2020/06/16(火) 12:00
こんにちは ＾＾ あ、はい了解です で、エラーの件ですが、 １．どのマクロで発生していますか ２．黄色くなっているコードを教えて下さい 上記のマクロが有る事が直接の原因では無いかもしれません「内容によっては解りませんが」 一応疑似マクロ作りましたが問題なく動いています。。。m(_ _)m （隠居じーさん） 2020/06/16(火) 12:06
↑この部分でエラーが出ます。
VLOOKUPで表示と同時に出ます。
（ちえこ） 2020/06/16(火) 12:16
こんにちは ＾＾
実際のシートの .Range("F26,F27,F31") 当たりのセル
と
新規ＢＯＯＫの同じアドレス、セルに何か相違点は有りません
でしょうか。何かお気づきの点があれば教えて下さい。
その様なものは有りませんと云うエラーの様な気がいたしますので
こちらでは、先ほどからテストするのですが、再現しません。？
今少し調べてみますね。m(_ _)m
（隠居じーさん） 2020/06/16(火) 13:03
ユーザーフォームで登録しています。
それも関係あるのでしょうかね？
シートは発注書・list・dataの3つのシートで作っております。
dataのシートはユーザーフォームで入力し発注書の番号でVLOOKUPを使用しています。
宜しくお願いします。
（ちえこ） 2020/06/16(火) 13:15
（隠居じーさん） 2020/06/16(火) 14:53
Option Explicit
'===================================================================================================
Public g_swOK As Byte ' フォームで登録が押されたかを判定するスイッチ
Public Sub TOUROKU(lngRow As Long)
'-----------------------------------------------------------------------------------------------
With FRM_USER
' 新規登録か判断
If ((lngRow = 1) Or (Cells(lngRow, 1).Value = "")) Then
' 見出しか未登録行の場合は新規登録と判断
lngRow = 0
.ComboBox5.Text = "" '会社名
.TXT_CODE.Text = "" ' 注文番号
.ComboBox2 = "" '注文 年
.ComboBox3 = "" '注文 月
.ComboBox4 = "" '注文 日
.ComboBox1 = "" '担当者
.TXT_hin1 = "" '品名1
.TXT_su1 = "" '数量1
.TextBox1 = "" '単価1
.TXT_hin2 = "" '品名2
.TXT_su2 = "" '数量2
.TextBox2 = "" '単価2
.TXT_hin3 = "" '品名3
.TXT_su3 = "" '数量3
.TextBox3 = "" '単価3
.TXT_hin4 = "" '品名4
.TXT_su4 = "" '数量4
.TextBox4 = "" '単価4
.TextBox6 = "" '品名5
.TXT_su5 = "" '数量5
.TextBox5 = "" '単価5
.ComboBox6 = "" '納期 年
.ComboBox7 = "" '納期 月
.ComboBox8 = "" '納期 日
.Text_ba = "" '納期場所
.ComboBox13 = "" '支払方法
' .OptionButton1 = "" '口座振込
' .OptionButton2 = "" '現金
' .OptionButton3 = "" 'その他
.Text_si = "" '支払その他
.TextB1 = "" '備考１
.TextB2 = "" '備考2
.TextB3 = "" '備考3
.TextB4 = "" '備考4
.TextB5 = "" '備考5
.ComboBox10 = "" '
.ComboBox11 = "" '
.ComboBox12 = "" '
Else
' 既存行の場合は修正と判断
.ComboBox5.Text = Cells(lngRow, 2).Value ' 会社名
.TXT_CODE.Text = Cells(lngRow, 1).Value '注文番号
.ComboBox2.Text = Cells(lngRow, 3).Value ' 注文 年
.ComboBox3.Text = Cells(lngRow, 4).Value '注文 月
.ComboBox4.Text = Cells(lngRow, 5).Value '注文 日
.ComboBox1.Text = Cells(lngRow, 6).Value '担当者
.TXT_hin1.Text = Cells(lngRow, 7).Value '品名1
.TXT_su1.Text = Cells(lngRow, 8).Value '数量1
.TextBox1.Text = Cells(lngRow, 9).Value '単価1
.TXT_hin2.Text = Cells(lngRow, 10).Value '品名2
.TXT_su2.Text = Cells(lngRow, 11).Value '数量2
.TextBox2.Text = Cells(lngRow, 12).Value '単価2
.TXT_hin3.Text = Cells(lngRow, 13).Value '品名3
.TXT_su3.Text = Cells(lngRow, 14).Value '数量3
.TextBox3.Text = Cells(lngRow, 15).Value '単価3
.TXT_hin4.Text = Cells(lngRow, 16).Value '品名4
.TXT_su4.Text = Cells(lngRow, 17).Value '数量4
.TextBox4.Text = Cells(lngRow, 18).Value '単価4
.TextBox6 = Cells(lngRow, 19).Value '品名5
.TXT_su5.Text = Cells(lngRow, 20).Value '数量5
.TextBox5.Text = Cells(lngRow, 21).Value '単価5
.ComboBox6.Text = Cells(lngRow, 22).Value '納期 年
.ComboBox7.Text = Cells(lngRow, 23).Value '納期 月
.ComboBox8.Text = Cells(lngRow, 24).Value '納期 日
.Text_ba = Cells(lngRow, 25).Value '納期場所
.ComboBox13 = Cells(lngRow, 26).Value '支払方法
.Text_si = Cells(lngRow, 27).Value '支払3
.TextB1 = Cells(lngRow, 28).Value '備考1
.TextB2 = Cells(lngRow, 29).Value '備考2
.TextB3 = Cells(lngRow, 30).Value '備考3
.TextB4 = Cells(lngRow, 31).Value '備考4
.TextB5 = Cells(lngRow, 32).Value '備考5
.ComboBox10 = Cells(lngRow, 33).Value '
.ComboBox11 = Cells(lngRow, 34).Value '
.ComboBox12 = Cells(lngRow, 35).Value '
End If
' フォームを表示
g_swOK = 0
.Show
' 登録ボタンが押されていない場合は以降の処理はしない
If g_swOK <> 1 Then Exit Sub
' 新規登録の場合は未登録行を探す
If lngRow = 0 Then
lngRow = 2
' 会社列未登録を判定
Do While Cells(lngRow, 1).Value <> ""
lngRow = lngRow + 1
Loop
End If
' シート上に登録
ActiveSheet.Unprotect
Cells(lngRow, 2).Value = Trim(.ComboBox5.Text) ' 会社名
Cells(lngRow, 1).Value = Trim(.TXT_CODE.Text) ' 注文番号
Cells(lngRow, 3).Value = Trim(.ComboBox2.Text) ' 注文 年
Cells(lngRow, 4).Value = Trim(.ComboBox3.Text) '注文 月
Cells(lngRow, 5).Value = Trim(.ComboBox4.Text) '注文 日
Cells(lngRow, 6).Value = Trim(.ComboBox1.Text) '担当者
Cells(lngRow, 7).Value = Trim(.TXT_hin1.Text) '品名1
Cells(lngRow, 8).Value = Trim(.TXT_su1.Text) '数量1
Cells(lngRow, 9).Value = Trim(.TextBox1.Text) '単価1
Cells(lngRow, 10).Value = Trim(.TXT_hin2.Text) '品名2
Cells(lngRow, 11).Value = Trim(.TXT_su2.Text) '数量2
Cells(lngRow, 12).Value = Trim(.TextBox2.Text) '単価2
Cells(lngRow, 13).Value = Trim(.TXT_hin3.Text) '品名3
Cells(lngRow, 14).Value = Trim(.TXT_su3.Text) '数量3
Cells(lngRow, 15).Value = Trim(.TextBox3.Text) '単価3
Cells(lngRow, 16).Value = Trim(.TXT_hin4.Text) '品名4
Cells(lngRow, 17).Value = Trim(.TXT_su4.Text) '数量4
Cells(lngRow, 18).Value = Trim(.TextBox4.Text) '単価4
Cells(lngRow, 19).Value = Trim(.TextBox6.Text) '品名5
Cells(lngRow, 20).Value = Trim(.TXT_su5.Text) '数量5
Cells(lngRow, 21).Value = Trim(.TextBox5.Text) '単価5
Cells(lngRow, 22).Value = Trim(.ComboBox6.Text) '納期 年
Cells(lngRow, 23).Value = Trim(.ComboBox7.Text) '納期 月
Cells(lngRow, 24).Value = Trim(.ComboBox8.Text) '納期 日
Cells(lngRow, 25).Value = Trim(.Text_ba.Text) '納期場所
Cells(lngRow, 26).Value = Trim(.ComboBox13.Text) '支払方法
' Cells(lngRow, 26).Value = Trim(.OptionButton1.Caption) '口座振込
' Cells(lngRow, 26).Value = Trim(.OptionButton2.Caption) '現金
' Cells(lngRow, 26).Value = Trim(.OptionButton3.Caption) 'その他
Cells(lngRow, 27).Value = Trim(.Text_si.Text) '支払方法3
Cells(lngRow, 28).Value = Trim(.TextB1.Text) '備考1
Cells(lngRow, 29).Value = Trim(.TextB2.Text) '備考2
Cells(lngRow, 30).Value = Trim(.TextB3.Text) '備考3
Cells(lngRow, 31).Value = Trim(.TextB4.Text) '備考4
Cells(lngRow, 32).Value = Trim(.TextB5.Text) '備考5
Cells(lngRow, 33).Value = Trim(.ComboBox10.Text) '
Cells(lngRow, 34).Value = Trim(.ComboBox11.Text) '
Cells(lngRow, 35).Value = Trim(.ComboBox12.Text) '
ActiveSheet.Protect
End With
End Sub
（ちえこ） 2020/06/16(火) 15:05
こんにちは ＾＾ 怪しげなコード、発見しました。。。 ひょっとして。。。当該シートに保護がかかっているのではないでしょうか、 だとすると、オートシェープ、〇を書込めません。今から試して見ます。
（隠居じーさん） 2020/06/16(火) 15:17
dataシート
A B C D E F C G H I J K L M 〜 AJ AK AL AM AN AO AP AQ AR AS AT AU 1 会社名 注文番号 注文年 注文月 注文日 品名 数量 単価 納品年 納品月 納品日 納品場所 支払方法 備考 〜 No. 内容 業者 番号 注文書 注文日 発行 要・不要 受領日 税込価格 支払日 備考 2 ああ 20001 2020 4 1 あ 1 100 2020 4 2 あああ 振込 1 3 いい 20002 2020 4 25 あ 1 200 2020 4 26 いいい 振込 2 4 ああ 20003 2020 4 27 い 1 100 2020 4 28 ううう 振込 3 5 うう 20004 2020 5 1 う 1 250 2020 5 2 いいい 振込 1 6 いい 20005 2020 5 24 あ 1 320 2020 5 25 あああ 振込 2
発注書シート
V4＝リストで注文番号を選んで、VLOOKUPで表示しています。
AJ26＝IFERROR(IF(VLOOKUP($V$4,data!$A:$AI,24,FALSE)=0,"",VLOOKUP($V$4,data!$A:$AI,26,FALSE)),"")
（ちえこ） 2020/06/16(火) 15:19
（隠居じーさん） 2020/06/16(火) 15:47
宜しくお願いします。
（ちえこ） 2020/06/16(火) 15:49
発注書シートモジュールの Private Sub Worksheet_Calculate()
↓
End Sub を下記の物と差し換えて下さい。で。。。お試しを。。m(_ _)m
Private Sub Worksheet_Calculate()
Me.Unprotect
Static x As Variant
If IsError(Me.Range("AJ26").Value) Then Exit Sub
If x = Me.Range("AJ26").Value Then Exit Sub
Select Case Me.Range("AJ26").Value
Case 1
kk Me, Me.Range("F26")
Case 2
kk Me, Me.Range("F27")
Case 3
kk Me, Me.Range("F31")
Case Else
kk Me
End Select
x = Me.Range("AJ26").Value
Me.Protect
End Sub
（隠居じーさん） 2020/06/16(火) 15:53
やっぱりIf Not Intersect(.Range("F26,F27,F31"), .Range(myshap.TopLeftCell.Address, .Range(myshap.BottomRightCell.Address))) Is Nothing Then
の部分がエラーで黄色くなります。
困りました。
（ちえこ） 2020/06/16(火) 16:01
はい ＾＾
もう一度
下記の物と差し換えて試して見て下さい。
セルを移動するだけでイベントが起きている可能性がありますので、
推測の域を出ないのですが。一度止めてみました。(◎_◎;)。。。m(_ _)m
Private Sub Worksheet_Calculate()
Me.Unprotect
Application.EnableEvents = False
Static x As Variant
If IsError(Me.Range("AJ26").Value) Then Exit Sub
If x = Me.Range("AJ26").Value Then Exit Sub
Select Case Me.Range("AJ26").Value
Case 1
kk Me, Me.Range("F26")
Case 2
kk Me, Me.Range("F27")
Case 3
kk Me, Me.Range("F31")
Case Else
kk Me
End Select
x = Me.Range("AJ26").Value
Me.Protect
Application.EnableEvents = True
End Sub
（隠居じーさん） 2020/06/16(火) 16:09
やってみましたが…
実行時エラーが出てしまいます。
（ちえこ） 2020/06/16(火) 16:19
失礼致しました、Ａ列以外はすぐ抜けていました、関係なかったようですね。 複数ブック、複数シート、等を使用時に、どのシートのどのセルか、エクセル様 が理解不能になった時によく出るエラーなので、なにかお心当たり、とか、これ かも。。。みたいなものは御座いませんでしょうか。 新規ブックで動くのですから、何か必ず、原因は［相違点］あるはずです。 最近頭の中身が弱っていますので、考えてみます。←嘘つけ前からやろ。！はい、 済みませんm(_ _)m。 無理にとは申し上げませんが［必ず判明するとは言えませんので、ダメ元で＾＾；］ 各シートのマクロ、こちらにそのままアップもご考察ください。お役に立てず申し訳 有りません、懲りずに、他の方の回答もお待ちくださいね。でわでわ。。。m(_ _)m （隠居じーさん） 2020/06/16(火) 16:42
Public g_swOK As Byte ' フォームで登録が押されたかを判定するスイッチ
Public Sub TOUROKU(lngRow As Long)
'-----------------------------------------------------------------------------------------------
With FRM_USER
' 新規登録か判断
If ((lngRow = 1) Or (Cells(lngRow, 1).Value = "")) Then
' 見出しか未登録行の場合は新規登録と判断
lngRow = 0
.ComboBox5.Text = "" '会社名
.TXT_CODE.Text = "" ' 注文番号
.ComboBox2 = "" '注文 年
.ComboBox3 = "" '注文 月
.ComboBox4 = "" '注文 日
.ComboBox1 = "" '担当者
.TXT_hin1 = "" '品名1
.TXT_su1 = "" '数量1
.TextBox1 = "" '単価1
.TXT_hin2 = "" '品名2
.TXT_su2 = "" '数量2
.TextBox2 = "" '単価2
.TXT_hin3 = "" '品名3
.TXT_su3 = "" '数量3
.TextBox3 = "" '単価3
.TXT_hin4 = "" '品名4
.TXT_su4 = "" '数量4
.TextBox4 = "" '単価4
.TextBox6 = "" '品名5
.TXT_su5 = "" '数量5
.TextBox5 = "" '単価5
.ComboBox6 = "" '納期 年
.ComboBox7 = "" '納期 月
.ComboBox8 = "" '納期 日
.Text_ba = "" '納期場所
.ComboBox13 = "" '支払方法
' .OptionButton1 = "" '口座振込
' .OptionButton2 = "" '現金
' .OptionButton3 = "" 'その他
.Text_si = "" '支払その他
.TextB1 = "" '備考１
.TextB2 = "" '備考2
.TextB3 = "" '備考3
.TextB4 = "" '備考4
.TextB5 = "" '備考5
.ComboBox10 = "" '
.ComboBox11 = "" '
.ComboBox12 = "" '
Else
' 既存行の場合は修正と判断
.ComboBox5.Text = Cells(lngRow, 2).Value ' 会社名
.TXT_CODE.Text = Cells(lngRow, 1).Value '注文番号
.ComboBox2.Text = Cells(lngRow, 3).Value ' 注文 年
.ComboBox3.Text = Cells(lngRow, 4).Value '注文 月
.ComboBox4.Text = Cells(lngRow, 5).Value '注文 日
.ComboBox1.Text = Cells(lngRow, 6).Value '担当者
.TXT_hin1.Text = Cells(lngRow, 7).Value '品名1
.TXT_su1.Text = Cells(lngRow, 8).Value '数量1
.TextBox1.Text = Cells(lngRow, 9).Value '単価1
.TXT_hin2.Text = Cells(lngRow, 10).Value '品名2
.TXT_su2.Text = Cells(lngRow, 11).Value '数量2
.TextBox2.Text = Cells(lngRow, 12).Value '単価2
.TXT_hin3.Text = Cells(lngRow, 13).Value '品名3
.TXT_su3.Text = Cells(lngRow, 14).Value '数量3
.TextBox3.Text = Cells(lngRow, 15).Value '単価3
.TXT_hin4.Text = Cells(lngRow, 16).Value '品名4
.TXT_su4.Text = Cells(lngRow, 17).Value '数量4
.TextBox4.Text = Cells(lngRow, 18).Value '単価4
.TextBox6 = Cells(lngRow, 19).Value '品名5
.TXT_su5.Text = Cells(lngRow, 20).Value '数量5
.TextBox5.Text = Cells(lngRow, 21).Value '単価5
.ComboBox6.Text = Cells(lngRow, 22).Value '納期 年
.ComboBox7.Text = Cells(lngRow, 23).Value '納期 月
.ComboBox8.Text = Cells(lngRow, 24).Value '納期 日
.Text_ba = Cells(lngRow, 25).Value '納期場所
.ComboBox13 = Cells(lngRow, 26).Value '支払方法
' .OptionButton1 = Cells(lngRow, 26).Value '口座振込
' .OptionButton2 = Cells(lngRow, 26).Value '現金
' .OptionButton3 = Cells(lngRow, 26).Value 'その他
.Text_si = Cells(lngRow, 27).Value '支払3
.TextB1 = Cells(lngRow, 28).Value '備考1
.TextB2 = Cells(lngRow, 29).Value '備考2
.TextB3 = Cells(lngRow, 30).Value '備考3
.TextB4 = Cells(lngRow, 31).Value '備考4
.TextB5 = Cells(lngRow, 32).Value '備考5
.ComboBox10 = Cells(lngRow, 33).Value '
.ComboBox11 = Cells(lngRow, 34).Value '
.ComboBox12 = Cells(lngRow, 35).Value '
End If
' フォームを表示
g_swOK = 0
.Show
' 登録ボタンが押されていない場合は以降の処理はしない
If g_swOK <> 1 Then Exit Sub
' 新規登録の場合は未登録行を探す
If lngRow = 0 Then
lngRow = 2
' 下請業者列未登録を判定
Do While Cells(lngRow, 1).Value <> ""
lngRow = lngRow + 1
Loop
End If
' シート上に登録
ActiveSheet.Unprotect
Cells(lngRow, 2).Value = Trim(.ComboBox5.Text) ' 会社名
Cells(lngRow, 1).Value = Trim(.TXT_CODE.Text) ' 注文番号
Cells(lngRow, 3).Value = Trim(.ComboBox2.Text) ' 注文 年
Cells(lngRow, 4).Value = Trim(.ComboBox3.Text) '注文 月
Cells(lngRow, 5).Value = Trim(.ComboBox4.Text) '注文 日
Cells(lngRow, 6).Value = Trim(.ComboBox1.Text) '担当者
Cells(lngRow, 7).Value = Trim(.TXT_hin1.Text) '品名1
Cells(lngRow, 8).Value = Trim(.TXT_su1.Text) '数量1
Cells(lngRow, 9).Value = Trim(.TextBox1.Text) '単価1
Cells(lngRow, 10).Value = Trim(.TXT_hin2.Text) '品名2
Cells(lngRow, 11).Value = Trim(.TXT_su2.Text) '数量2
Cells(lngRow, 12).Value = Trim(.TextBox2.Text) '単価2
Cells(lngRow, 13).Value = Trim(.TXT_hin3.Text) '品名3
Cells(lngRow, 14).Value = Trim(.TXT_su3.Text) '数量3
Cells(lngRow, 15).Value = Trim(.TextBox3.Text) '単価3
Cells(lngRow, 16).Value = Trim(.TXT_hin4.Text) '品名4
Cells(lngRow, 17).Value = Trim(.TXT_su4.Text) '数量4
Cells(lngRow, 18).Value = Trim(.TextBox4.Text) '単価4
Cells(lngRow, 19).Value = Trim(.TextBox6.Text) '品名5
Cells(lngRow, 20).Value = Trim(.TXT_su5.Text) '数量5
Cells(lngRow, 21).Value = Trim(.TextBox5.Text) '単価5
Cells(lngRow, 22).Value = Trim(.ComboBox6.Text) '納期 年
Cells(lngRow, 23).Value = Trim(.ComboBox7.Text) '納期 月
Cells(lngRow, 24).Value = Trim(.ComboBox8.Text) '納期 日
Cells(lngRow, 25).Value = Trim(.Text_ba.Text) '納期場所
Cells(lngRow, 26).Value = Trim(.ComboBox13.Text) '支払方法
Cells(lngRow, 27).Value = Trim(.Text_si.Text) '支払方法3
Cells(lngRow, 28).Value = Trim(.TextB1.Text) '備考1
Cells(lngRow, 29).Value = Trim(.TextB2.Text) '備考2
Cells(lngRow, 30).Value = Trim(.TextB3.Text) '備考3
Cells(lngRow, 31).Value = Trim(.TextB4.Text) '備考4
Cells(lngRow, 32).Value = Trim(.TextB5.Text) '備考5
Cells(lngRow, 33).Value = Trim(.ComboBox10.Text) '
Cells(lngRow, 34).Value = Trim(.ComboBox11.Text) '
Cells(lngRow, 35).Value = Trim(.ComboBox12.Text) '
ActiveSheet.Protect
End With
End Sub
dataのシート
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'-----------------------------------------------------------------------------------------------
Dim lngRow As Long ' 行INDEX
If Target.Column <> 1 Or Target.Count > 1 Then Exit Sub
lngRow = Target.Row
' 登録処理を呼び出す(引数は選択行)
Call TOUROKU(lngRow)
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
Sub main()
Dim c As Range, sht As Worksheet
For Each c In Sheets("data").Range("W2:W" & Rows.Count).SpecialCells(2)
Do
For Each sht In Worksheets
If sht.Name = c.Value & "月" Then
Intersect(Sheets("data").Range("AJ:AU"), c.EntireRow).Copy
sht.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Exit Do
End If
Next sht
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = c.Value & "月"
'Sheets("data").Rows(1).Copy Worksheets(Worksheets.Count).Range("A4")
Sheets("data").Range("AJ1:AU1").Copy Worksheets(Worksheets.Count).Range("A4")
Loop
Next c
End Sub
発注書のシート
Option Explicit
Private Sub Worksheet_Calculate()
Me.Unprotect
Application.EnableEvents = False
Static x As Variant
If IsError(Me.Range("AJ26").Value) Then Exit Sub
If x = Me.Range("AJ26").Value Then Exit Sub
Select Case Me.Range("AJ26").Value
Case 1
kk Me, Me.Range("F26")
Case 2
kk Me, Me.Range("F27")
Case 3
kk Me, Me.Range("F31")
Case Else
kk Me
End Select
x = Me.Range("AJ26").Value
Me.Protect
Application.EnableEvents = True
End Sub
Sub kk(ByVal MySh As Worksheet, Optional ByVal r As Range)
Dim myshap As Shape
With MySh
For Each myshap In .Shapes
If Not Intersect(.Range("F26,F27,F31"), .Range(myshap.TopLeftCell.Address, .Range(myshap.BottomRightCell.Address))) Is Nothing Then
myshap.Delete
End If
Next
If Not r Is Nothing Then
With .Shapes.AddShape(msoShapeOval, r.Left, r.Top, r.Width, r.Height)
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 1
End With
End If
End With
End Sub
これで全部になります。
宜しくお願いします。
（ちえこ） 2020/06/16(火) 16:54
＞＞実際のファイルでやってみた所、実行時エラー1004 ＞＞アプリケーション定義またはオブジェクト定義エラーですと出てしまいました。 黄色反転箇所
↓
If Not Intersect(.Range("F26,F27,F31"), .Range(myshap.TopLeftCell.Address, .Range(myshap.BottomRightCell.Address))) Is Nothing Then
だそぉです。 ＾＾；。。。なんとなく。わかってきたよぉな。。。m(_ _)m いや、そんな気がするだけです。。。m(_ _)m 今しばらく御猶予を
（隠居じーさん） 2020/06/16(火) 16:59
最後に提示されたコードの保護解除などの
位置が適切では無いように思われます。
問題に直接関係しませんが。
（γ） 2020/06/16(火) 17:05
（γ） 2020/06/16(火) 17:13
前のも含めて全部載せてみました。
解除方法は暗証番号などはないので、そのまま解除できます。
オートシェイプは白抜きの黒丸です。
dataのユーザーフォームもエラーになってしまって登録できなくなりました…
（ちえこ） 2020/06/16(火) 17:15
＞＞dataのユーザーフォームもエラーになってしまって登録できなくなりました… ｗ (◎_◎;) 。。。すみません。 こちらは どのような。。 エラー番号、メッセージ、停止箇所のコード、等お願いいたします。 （隠居じーさん） 2020/06/16(火) 17:25
隠居じーさん様
If Not Intersect(.Range("F26,F27,F31"), .Range(myshap.TopLeftCell.Address, .Range(myshap.BottomRightCell.Address))) Is Nothing Then
またこちらです。↑
フォームは開くのですが登録を押すとエラーです。
実行時エラー1004と出ます。
すみません。
ほんとにすみません
（ちえこ） 2020/06/16(火) 17:30
（γ） 2020/06/16(火) 17:37
（γ） 2020/06/16(火) 17:39
いえいえ ＾＾ こちらこそ、勉強させていただいております。 γさんからの強力なフォローもあり、有難う御座います。
（隠居じーさん） 2020/06/16(火) 17:45
# ちょっと出掛けます。
（γ） 2020/06/16(火) 17:50
こんばんは！ わちきの駄作コードのせいで皆様には大変ご迷惑をおかけしております。。です。。。どうもすみません。。m(__)m
どうもShapeを制限していないのが原因の様なので、、 書きたいのは、、楕円ですので、、消すのも、、楕円としました。。。 一応、、全コードを載せておきます。。。 どうでしょうか？？？上手く行きます様に！！！ぱんぱん
Option Explicit
Private Sub Worksheet_Calculate()
Static x As Variant
If IsError(Me.Range("AJ26").Value) Then Exit Sub
If x = Me.Range("AJ26").Value Then Exit Sub
Select Case Me.Range("AJ26").Value
Case 1
kk Me, Me.Range("F26")
Case 2
kk Me, Me.Range("F27")
Case 3
kk Me, Me.Range("F31")
Case Else
kk Me
End Select
x = Me.Range("AJ26").Value
End Sub
Sub kk(ByVal MySh As Worksheet, Optional ByVal r As Range)
Dim myshap As Shape
With MySh
For Each myshap In .Shapes
If myshap.Type = msoAutoShape Then
If myshap.AutoShapeType = msoShapeOval Then
If Not Intersect(.Range("F26,F27,F31"), .Range(myshap.TopLeftCell.Address, .Range(myshap.BottomRightCell.Address))) Is Nothing Then
myshap.Delete
End If
End If
End If
Next
If Not r Is Nothing Then
With .Shapes.AddShape(msoShapeOval, r.Left, r.Top, r.Width, r.Height)
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 1
End With
End If
End With
End Sub
（SoulMan） 2020/06/16(火) 19:54
Static x As Variant
If IsError(Me.Range("AJ26").Value) Then Exit Sub
If x = Me.Range("AJ26").Value Then Exit Sub
Me.Unprotect
Select Case Me.Range("AJ26").Value
Case 1
kk Me, Me.Range("F26")
Case 2
kk Me, Me.Range("F27")
Case 3
kk Me, Me.Range("F31")
Case Else
kk Me
End Select
x = Me.Range("AJ26").Value
Me.Protect
End Sub
（γ） 2020/06/16(火) 21:47
色々とご迷惑をおかけしております。m(__)m
明日会社でやってみますね。
保護はこのデーターが簡単な見本でネットのユーザーフォームから入力する場合、というコードを引用して作成しました。
保護は必要ないんですが、勝手に保護が入ってしまう、dataが出来てしまったんです。
それに色づけと肉付けして今の状態です。
どのタイミングで保護がかかるかが分かっておりません。
色々、試行錯誤して下さって本当に申し訳ないです。
保護がかかる以外は、使い勝手はいいと思うのですが…
書式も決まっており、発注書加工する事は出来ず、今の現状になっております。
月別に振り分けされた後に保護が掛かっていたと思います。
こんな私のために皆さんで一緒に考えてくれてとても嬉しい気持ちと申し訳ない気持ちで一杯です。
本当にありがとうございます。
（ちえこ） 2020/06/16(火) 21:59
こんばんは！ コントロール出来ていないのは問題ですね(^^; 取り敢えず↓これは消してください。。。 ActiveSheet.Protect
プロテクト・・・・保護・・・です。 これを消せば保護は掛かりません。。。 （SoulMan） 2020/06/16(火) 22:13
どこで保護かかっているかわからないそうですが、
Public Sub TOUROKU(lngRow As Long)
の最後で
ActiveSheet.Protect
としているじゃないですか。
不要ならとればいいし、その前にやっているUnprotectもとってください。
頂いたコードであっても、きちんと中身をよく読んで、
自分のものとしておかないといけないと思います。
それが回答を下さったかたへの礼儀です。
（γ） 2020/06/16(火) 22:15
明日会社で試されるとのことですので簡潔なアドバイスを、、、いくつか。。。 コントロール出来ていなコードで仕事をされていることに驚きですが、 それはそれとして、、今回を機に是非、Helpの使い方を身に付けることをお勧めします。
コードのわからないところにカーソルをおいてF1を押すとHelpが出ます。 Helpが出てたら参考コードを試してもいいですし、、オブジェクト プロパティなどなど ネットで質問するよりもはるかに有意義な情報があります。 (青く反転しているところクリック) 勿論、ネットにはネットのいいところがありますからそれを否定するものではありません。 Helpもちょいちょい間違っていることもある(笑)
要は、ある程度の基礎知識、、それ以前に使い方をマスターすることです。 Helpは、基礎の基礎、、何はなくても、、が多いですけど(^^;
これはなんだ？と思ったら、、選択してF1、、、メンバーを調べる、、定数を調べる。。。 みたいなことをしていると思わぬ発見があったりで楽しいものです。 特に図形は記録されないのでHelpの出番ですよね。 もう、、コードなんて書きたくない。。。と思うこともありますけど。。。。 少なくともわからないままコードを走らしちゃだめです。。。 コードを覚えるのではなくて、、書き方というかぁ、、調べ方を身に付けることです。 それが出来るようになれば、、わからないままコードを走らせる、、、なんてことはまずありえません。。。
簡潔と言いながら長くなってしまいしました。。。くれぐれも気分を悪くなされません様に。。。頑張ってください。 では、、では、、おやすみなさいzzzzzzzzzzzzzzzz （SoulMan） 2020/06/16(火) 23:05
出来ました!！
保護も消して、満足です。
月毎にシートに振り分ける、作業を改めて質問したいと思います。
本当にご協力ありがとうございました。
（ちえこ） 2020/06/17(水) 09:01
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.