[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『別のシートにとばせたい』(yusuke)
Sheet1のA69:A75 C69:75 E69:75 G I K M…(一週間の日付) 第2週はA113:A119と続きます。 これらのセルに入力した数字を上から順に Sheet2のA8:A50へ飛ばせたいのです。 詳しくお教え願います。
< 使用 Excel:Excel2003、使用 OS:Windows7 >
もっと具体的に教えてください。 Sheet1 [A] [B] [C] [D] [E] [F] [G] [??] 月 火 水 木 金 土 日 [69] 16 74 39 49 14 85 [70] 58 48 62 31 86 [71] 85 85 33 82 [72] 32 36 87 [73] 51 56 [74] 16 58 [75] 57 25 〜 [113] 64 11 61 15 82 19 [114] 58 81 36 13 86 79 [115] 30 56 61 37 28 [116] 64 27 [117] 75 13 [118] [119]
このような表であった場合、Sheet2はどのような結果を求めたいのですか? (稲葉) 2014/09/26(金) 09:12
稲葉さん ありがとうございます Sheet2 A 8 16 9 58 10 85 11 32 12 74 13 48 14 36 15 51 16 39 ・ ・ ・ のようにしたいのです。 重複するのは飛ばせないように出来ますか?
よろしくお願いします
(yusuke) 2014/09/26(金) 09:26
中途半端な・・・ 重複は無くせます。 1)50行目までいったら、どうするんですか? 2)土曜日など数値と数値の間に空白がある場合はどうしますか? (稲葉) 2014/09/26(金) 09:49
一日分としては、多くて3個です。 それに、毎日ではありませんので、40行ぐらいまでです。 空白のところは、飛ばないようにしたいのです。 説明が旨く出来なくて申し訳ないです。 (yusuke) 2014/09/26(金) 10:10
こちらでいかがですか? Sub 出力() Dim ブロック As Collection Dim 重複確認 As Object Dim 出力範囲 As Range Dim i As Long, r As Long, c As Long Dim 値 As String Set ブロック = New Collection Set 重複確認 = CreateObject("Scripting.Dictionary") With Sheets("Sheet1") ブロック.Add .Range("A69:G75").Value, "1" ブロック.Add .Range("A113:G119").Value, "2" For i = 1 To ブロック.Count For c = 1 To UBound(ブロック(i), 2) For r = 1 To UBound(ブロック(i), 1) 値 = ブロック(i)(r, c) If (Not 重複確認.exists(値)) And (値 <> "") Then 重複確認.Add 値, "" End If Next r Next c Next i End With Sheets("Sheet2").Range("A8").Resize(Application.Min(43, 重複確認.Count)).Value = Application.Transpose(重複確認.keys) End Sub
出力結果 [A] [8] 16 [9] 58 [10] 85 [11] 32 [12] 74 [13] 48 [14] 36 [15] 51 [16] 39 [17] 62 [18] 49 [19] 31 [20] 33 [21] 87 [22] 14 [23] 86 [24] 82 [25] 57 [26] 56 [27] 25 [28] 64 [29] 30 [30] 11 [31] 81 [32] 75 [33] 61 [34] 27 [35] 13 [36] 15 [37] 37 [38] 28 [39] 19 [40] 79 [41] [42] [43] [44] [45] [46] [47] [48] [49] [50]
(稲葉) 2014/09/26(金) 10:17
稲葉さん ありがとうございます 以下のところを、Sheet1のシートの表示に貼り付ければいいのでしょうか? それとも、ThisWorkbookですか?
Sub 出力() Dim ブロック As Collection Dim 重複確認 As Object Dim 出力範囲 As Range Dim i As Long, r As Long, c As Long Dim 値 As String Set ブロック = New Collection Set 重複確認 = CreateObject("Scripting.Dictionary") With Sheets("Sheet1") ブロック.Add .Range("A69:G75").Value, "1" ブロック.Add .Range("A113:G119").Value, "2" For i = 1 To ブロック.Count For c = 1 To UBound(ブロック(i), 2) For r = 1 To UBound(ブロック(i), 1) 値 = ブロック(i)(r, c) If (Not 重複確認.exists(値)) And (値 <> "") Then 重複確認.Add 値, "" End If Next r Next c Next i End With Sheets("Sheet2").Range("A8").Resize(Application.Min(43, 重複確認.Count)).Value = Application.Transpose(重複確認.keys) End Sub
(yusuke) 2014/09/26(金) 11:28
標準モジュールでいいと思いますけど・・・ 何かイベントを拾いたい理由でもあるんですか? (稲葉) 2014/09/26(金) 11:32
どこに貼り付けても作動しません。 何か書き換えるところでもありますか? ど素人で申し訳ありません。 (yusuke) 2014/09/26(金) 11:38
作動しないというのは、何をしたら作動しないんですか? ステップ実行など確かめましたか? (稲葉) 2014/09/26(金) 11:39
Sheet1のA69に55と打ち込みましたが、Sheet2のA8には何も表示されないのです。 (yusuke) 2014/09/26(金) 11:42
Alt+F8を押して、出力を実行してください。 入力したら都度反映されることをご希望ですか? (稲葉) 2014/09/26(金) 11:46
Alt+F8を押して実行すれば、表示されました。 できれば、入力したら都度反映されればいいのですが。 ヨロシクお願いします。 (yusuke) 2014/09/26(金) 11:50
Sheet1のシートモジュールに入れてください。 Private Sub Worksheet_Change(ByVal Target As Range) Dim 入力範囲, chk Dim ブロック As Collection Set ブロック = New Collection 入力範囲 = Array(Range("A69:G75"), Range("A69:G75")) For Each chk In 入力範囲 If Not Intersect(Target, chk) Is Nothing Then ブロック.Add chk.Value, CStr(ブロック.Count + 1) End If Next chk If ブロック.Count = 0 Then Exit Sub
Dim 重複確認 As Object
Dim i As Long, r As Long, c As Long Dim 値 As String Set 重複確認 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1") For i = 1 To ブロック.Count For c = 1 To UBound(ブロック(i), 2) For r = 1 To UBound(ブロック(i), 1) 値 = ブロック(i)(r, c) If (Not 重複確認.exists(値)) And (値 <> "") Then 重複確認.Add 値, "" End If Next r Next c Next i End With With Application .EnableEvents = False Sheets("Sheet2").Range("A8").Resize(.Min(43, 重複確認.Count)).Value = .Transpose(重複確認.keys) .EnableEvents = True End With End Sub (稲葉) 2014/09/26(金) 13:28
稲葉さん ありがとうございます。 思うようになりつつありますが、第2週以降が旨くできません。
第2週 A113:119 C113:119 E113:119 G113:119 I113:119 K113:119 M113:119 第3週 A157:163 C157:163 E157:163 G157:163 I157:163 K157:163 M157:163 第4週 A201:207 C201:207 E201:207 G201:207 I201:207 K201:207 M201:207 第5周 A245:251 C245:251 E245:251 G245:251 I245:251 K245:251 M245:251
のようになっています。 B D F H J L Nの列はSheet2の方へ飛ばないようにしたいのです。 ややこしいことをいって申し訳ありませんが、お願いします。 (yusuke) 2014/09/26(金) 15:04
1列置きなのね・・・見落としてました。 3週目以降は「入力範囲」にカンマ区切りで追加していってください。
Private Sub Worksheet_Change(ByVal Target As Range) Dim 入力範囲, chk Dim ブロック As Collection Set ブロック = New Collection 入力範囲 = Array(Range("A69:M75"), Range("A113:M119")) ' ~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~ ' 1周目 2週目 For Each chk In 入力範囲 If Not Intersect(Target, chk) Is Nothing Then ブロック.Add chk.Value, CStr(ブロック.Count + 1) End If Next chk If ブロック.Count = 0 Then Exit Sub
Dim 重複確認 As Object
Dim i As Long, r As Long, c As Long Dim 値 As String Set 重複確認 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1") For i = 1 To ブロック.Count For c = 1 To UBound(ブロック(i), 2) Step 2 For r = 1 To UBound(ブロック(i), 1) 値 = ブロック(i)(r, c) If (Not 重複確認.exists(値)) And (値 <> "") Then 重複確認.Add 値, "" End If Next r Next c Next i End With With Application .EnableEvents = False Sheets("Sheet2").Range("A8").Resize(.Min(43, 重複確認.Count)).Value = .Transpose(重複確認.keys) .EnableEvents = True End With End Sub (稲葉) 2014/09/26(金) 15:12
ありがとうございます。 B D F H J L N列は表示されなくなりました。 しかし Sheet1に入力した数字をDeleteで消去していると、最後のひとつで、 実行時エラー'13' 型が一致しません。と表示され、以後、実行できなくなります。 解決できますでしょうか。
お願いします
(yusuke) 2014/09/26(金) 15:27
Private Sub Worksheet_Change(ByVal Target As Range) Dim 入力範囲, chk Dim ブロック As Collection Set ブロック = New Collection 入力範囲 = Array(Range("A69:M75"), Range("A113:M119")) For Each chk In 入力範囲 If Not Intersect(Target, chk) Is Nothing Then ブロック.Add chk.Value, CStr(ブロック.Count + 1) End If Next chk If ブロック.Count = 0 Then Exit Sub
Dim 重複確認 As Object
Dim i As Long, r As Long, c As Long Dim 値 As String Set 重複確認 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1") For i = 1 To ブロック.Count For c = 1 To UBound(ブロック(i), 2) Step 2 For r = 1 To UBound(ブロック(i), 1) 値 = ブロック(i)(r, c) If (Not 重複確認.exists(値)) And (値 <> "") Then 重複確認.Add 値, "" End If Next r Next c Next i End With If 重複確認.Count > 0 Then With Application .EnableEvents = False Sheets("Sheet2").Range("A8:A50").ClearContents Sheets("Sheet2").Range("A8").Resize(.Min(43, 重複確認.Count)).Value = .Transpose(重複確認.keys) .EnableEvents = True End With End If End Sub これでどうでしょうか (稲葉) 2014/09/26(金) 15:32
本当にありがとうございます。 完璧に完成です。 長い時間を費やしていただきありがとうございました。 また、よろしくお願いします。 (yusuke) 2014/09/26(金) 15:40
稲葉さんに、お尋ねしたいのです。 上記のコードで、第3週 第4週 第5週を下記のように追加しました。(正しいでしょうか) 第1週に入力をすれば、希望通りに表示されます。 しかし、第2週に入力すると、第1週の表示が Sheet2から消えて、第2週のみが表示されます。 第3週 第4週 第5週も同じ状況です。 解決できるのでしたら、お願いします
入力範囲 = Array(Range("A69:M75"), Range("A113:M119"), Range("A157:M163"), Range("A201:M207"), Range("A245:M251"))
(yusuke) 2014/10/10(金) 08:27
ロジックの誤りがありました! Private Sub Worksheet_Change(ByVal Target As Range) Dim 入力範囲, chk, chkRng As Range Dim ブロック As Collection Set ブロック = New Collection 入力範囲 = Array(Range("A69:M75"), Range("A113:M119"), Range("A157:M163")) For Each chk In 入力範囲 If chkRng Is Nothing Then Set chkRng = chk Else Set chkRng = Union(chkRng, chk) End If ブロック.Add chk.Value, CStr(ブロック.Count + 1) Next chk If Intersect(Target, chkRng) Is Nothing Then Exit Sub
Dim 重複確認 As Object
Dim i As Long, r As Long, c As Long Dim 値 As String Set 重複確認 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1") For i = 1 To ブロック.Count For c = 1 To UBound(ブロック(i), 2) Step 2 For r = 1 To UBound(ブロック(i), 1) 値 = ブロック(i)(r, c) If (Not 重複確認.exists(値)) And (値 <> "") Then 重複確認.Add 値, "" End If Next r Next c Next i End With With Application .EnableEvents = False Sheets("Sheet2").Range("A8:A50").ClearContents If 重複確認.Count > 0 Then Sheets("Sheet2").Range("A8").Resize(.Min(43, 重複確認.Count)).Value = .Transpose(重複確認.keys) End If .EnableEvents = True End With End Sub こちらに差し替えでお願いします。 (稲葉) 2014/10/10(金) 09:05
稲葉さん ありがとうございます。 コードを差し替えて、第1週に入力しEnterキーを押すと 実行時エラー'424' オブジェクトが必要です。 と表示されます。 よろしくお願いします。 yusuke
(yusuke) 2014/10/10(金) 09:21
急いで返信したので、変数やらなんやら間違ってました。 9:05投稿のコードを修正しましたので、ご確認ください。 (稲葉) 2014/10/10(金) 10:15
お忙しいところ ありがとうございました。 旨く出来るようになり、感謝します。 本当にありがとうございました yusuke
(yusuke) 2014/10/10(金) 10:29
又々ごめんなさい。 Sheet1に入力した数字を消す際についてです。 10箇所まとめて消そうとすると、Sheet1の分はDeleteキーで消えますが、Sheet2は消えません。 また、Sheet1を1個づつ消すと、Sheet2も消えていくのですが、Sheet2のA8だけが消えません。 解決策がありましたらお願いします。 (yusuke) 2014/10/10(金) 12:07
9:05の投稿を差し替えました。 (稲葉) 2014/10/10(金) 14:05
稲葉さん ありがとうございました。 しっかり消せるようになりました。
何も分からないお爺に対して、丁寧にお教えくださいまして ありがとう また、質問することがあると思いますが、その節にはどうぞよろしく。
(yusuke) 2014/10/10(金) 14:26
またまた、お世話になります。 現状は旨く作動しており感謝しています。
Sheet2に飛んでくる数字を品名として、各々に単価を付けたいのです。 [A]------------------- [AI] [8] 16 200 [9] 58 250 [10] 85 180 [11] 32 [12] 74 [13] 48 [14] 36 [15] 51 [16] 39 [17] 62 [18] 49 [19] 31 [20] 33 と、したいのです。
Sheet1の S69:T170に単価表を作りました。 [S] [T] 69 16 200 70 58 250 71 85 180
Sheet1のA69に16を打ち込めば、Sheet2のA8に16 AI8に200としたいのです。
Sheet2 [A]------------------- [AI] [8] 16 200 [9] 58 250 [10] 85 180
よろしくお願いします。
(yusuke) 2014/11/09(日) 11:18
一番簡単なのは >Sheets("Sheet2").Range("A8:A50").ClearContents なので、AI8:AI50 に、VLOOKUP関数を使った数式を入力しておく事だと思います。 これだと、マクロの知識は必要ないので。 (HANA) 2014/11/12(水) 10:54
ごめんなさい、見落としていました! HANAさんの案に賛成です! (稲葉) 2014/11/12(水) 11:44
HANAさん 稲葉さん ありがとうございます。 回答を、書いていただきましたけど、 11月10日に、解決させていただきました。 また、よろしくお願いします。 (yusuke) 2014/11/13(木) 07:49
また、難題? Sheet2の C6からAG6(日付) C8からG50に数量が入ります。 C8:AG50のセルに、保護で“ロック” “表示しない”に チェックを入れて、シートの保護をすると、Sheet1で数字を打ち込もうとすると、 実行時エラー“1004”になります。 保護の仕方が間違ってるのでしょうか? よろしくお願いします。 (yusuke) 2014/11/17(月) 10:04
デバッグした時にどこで止まっていますか? たぶん >Sheets("Sheet2").Range("A8:A50").ClearContents この部分なんだろうけど
Sheet2のA8:A50は保護しない にチェック入れていますか? (稲葉) 2014/11/17(月) 10:40
シートの保護をするのなら コードでは 保護解除 データ書込み 保護 とするか 保護しててもVBAからは書き込めるように保護 が必要では?
ロックのチェックにかかわらず。 (HANA) 2014/11/17(月) 11:31
HANAさんのおっしゃる通りですね。横着してすみません。 Application.EnableEvents = False With Sheets("Sheet2") .Unprotect .Range("A8:A50").ClearContents If 重複確認.Count > 0 Then Sheets("Sheet2").Range("A8").Resize(.Min(43, 重複確認.Count)).Value = .Transpose(重複確認.keys) End If .Protect End With Application.EnableEvents = False
最後の出力部分、シートの保護を解除してから書き込むように設定しなおしました。 シートの保護パスワードや、オプションを付ける場合は、マクロの記録で記録されたコードを元に ご自身で書き換えてください。 (稲葉) 2014/11/17(月) 11:35
稲葉さん ありがとうございます。 おっしゃるとおり、Sheets("Sheet2").Range("A8:A50").ClearContents です。
最後の出力部分を、書いていただいていますが、どこにどうすればいいのですか? よろしくお願いします。 (yusuke) 2014/11/17(月) 14:29
2014/10/10(金) 09:05に投稿したコードの With Application から End With を丸ごと差し替えてください。
(稲葉) 2014/11/17(月) 14:55
このように書き換えました。 Private Sub Worksheet_Change(ByVal Target As Range) Dim 入力範囲, chk, chkRng As Range Dim ブロック As Collection Set ブロック = New Collection 入力範囲 = Array(Range("A69:M106"), Range("A111:M148"), Range("A153:M190"), Range("A195:M232"), Range("A237:M275")) For Each chk In 入力範囲 If chkRng Is Nothing Then Set chkRng = chk Else Set chkRng = Union(chkRng, chk) End If ブロック.Add chk.Value, CStr(ブロック.Count + 1) Next chk If Intersect(Target, chkRng) Is Nothing Then Exit Sub
Dim 重複確認 As Object
Dim i As Long, r As Long, c As Long Dim 値 As String Set 重複確認 = CreateObject("Scripting.Dictionary")
With Sheets("日計表") For i = 1 To ブロック.Count For c = 1 To UBound(ブロック(i), 2) Step 2 For r = 1 To UBound(ブロック(i), 1) 値 = ブロック(i)(r, c) If (Not 重複確認.exists(値)) And (値 <> "") Then 重複確認.Add 値, "" End If Next r Next c Next i End With Application.EnableEvents = False With Sheets("月集計") .Unprotect .Range("A8:A50").ClearContents If 重複確認.Count > 0 Then Sheets("月集計").Range("A8").Resize(.Min(43, 重複確認.Count)).Value = .Transpose(重複確認.keys) End If .Protect End With Application.EnableEvents = False
End Sub
Sheet2は“月集計”と名前を変えています。 Sheet1(日計表)に打ち込もうとすると、 実行時エラー“438” オブジェクトは、このプロパティまたはメソッドをサポートしていません。 と出て、デバッグは Sheets("月集計").Range("A8").Resize(.Min(43, 重複確認.Count)).Value = .Transpose(重複確認.keys) が、黄色くなっています。
(yusuke) 2014/11/17(月) 15:22
あ、ごめんなさい修正忘れです。 Sheets("月集計").Range("A8").Resize(Application.Min(43, 重複確認.Count)).Value = Application.Transpose(重複確認.keys) こちらに直してください。
(稲葉) 2014/11/17(月) 15:24
稲葉さん ありがとうございます。 書き直しをしましたが、日計表から月集計に飛びません。 何度も申し訳ないです。 (yusuke) 2014/11/17(月) 15:54
イミディエイトウィンドウに Application.EnableEvents = True と入れて実行してください。
イベントが無効になっている可能性があります。 (稲葉) 2014/11/17(月) 17:26
書き換えて、出来ました。 何度も、ありがとうございました。
(yusuke) 2014/11/17(月) 17:44
度々申し訳ないです。 日計表に品名を打ち込み、セルを右に移動して数量を打ち込もうとすると 一瞬二重線になって消え、アクティブセルがどこなのか分からなくなります。 コード表を消して試したら、正常に作動するのですが、何か設定が必要でしょうか? よろしくお願いします。 (yusuke) 2014/11/18(火) 08:30
あーこれは面白い症状ですね! 新しい事を発見出来ました。ありがとうございます。 修正箇所は、前回と同じ箇所です。
Application.ScreenUpdating = False '←これでちらつきとアクティブセル表示 Application.EnableEvents = False With Sheets("月集計") .Unprotect .Range("A8:A50").ClearContents If 重複確認.Count > 0 Then .Range("A8").Resize(Application.Min(43, 重複確認.Count)).Value = Application.Transpose(重複確認.keys) End If .Protect End With Application.EnableEvents = True '↓これを入れないと、Tabで確定した時に別シートの保護にも関わらず、なぜかTabキーで移動が出来なくなる Target.Parent.Protect Target.Parent.Unprotect (稲葉) 2014/11/18(火) 08:44
早朝にもかかわらずありがとうございます。 解決できました。 (yusuke) 2014/11/18(火) 08:56
何度もすみませんが。 これまで日計表には、品名を打ち込んでいたのですが、横着を考えて 品名の表をつくり、そこからコピー・貼り付けをしようと思ったのですが 一個のコピー・貼り付けをすると、次に何も出来なくなります。 ファイルを閉じるしかないのですが、解決できないでしょうか。 よろしくお願いします。 (yusuke) 2014/12/07(日) 08:40
ごめんなさい、見落としていました。
具体的に何をどうしているのですか? 最初の質問の時にも書きましたが、具体的にこちらが再現できるように記述していただかないと 検証のしようがないです。 (稲葉) 2014/12/10(水) 09:56
お手数おかけします。 Sheets1(日計表)の横に品名の表を作りました。 これまでは、打ち込んでいましたが、品名の表からコピーして 今日の欄に貼り付けをしたいのです。(品名は、LENS-UNIT-Y 段カットHS6E-61 SAIE-PUR-2C など) コピーをして貼り付けると、動かなくなってしまうのです。 横着せずに、文字を打ち込めば済むことなのですが… 上手く説明でいませんが、よろしくお願いします。
(yusuke) 2014/12/10(水) 11:29
横ってどこ・・・ 今日の欄ってどこ・・・
(稲葉) 2014/12/10(水) 12:54
Sheets1(日計表)のP68:P118に品名表を作り E 今日の打ち込むところはE113です。 LENS-UNIT-Y E113に貼り付けて、F113に数量を打ち込みます。 段カットHS6E-61 SAIE-PUR-2C
(yusuke) 2014/12/10(水) 13:14
こちらでは問題を再現できません。 動かなくなるとは、具体的にどうなることですか? コードにブレークポイントを付けて、同じ動作をしたときに、求めた動作しているかを確認してください。
(稲葉) 2014/12/10(水) 14:10
コピーをして貼り付ける。 そこまではできますが、コピーされるセルは波状の線が消えません。 貼り付け作業をするまでは、波状の破線は動いています。(この時点では、コード表に変化はありません) 貼り付けた方は二重線で囲まれた状態で、固まったままになって、コード表も開けません。 勿論、他のシートも開けません。(ファイルを閉じるしかありません)
(yusuke) 2014/12/10(水) 14:35
どうにも再現できません。 新しいファイルに値だけコピーして、コードを実行してください。 それで問題がなければ、コードとは別のところで止まっている可能性があります。 (稲葉) 2014/12/10(水) 16:18
何度も申し訳ないです。 稲葉さんのおっしゃる通りにやってみましたが駄目でした。 以前に書いてもらったコードで、シートの保護をしなかったら旨くできました。 シートの保護なしで遂行したいと思います。(ファイルにパスワードを設定します) 訳の分からんお爺に長々とお付き合いいただきありがとうございました。 これに懲りず、またの時はよろしくお願いします。 (yusuke) 2014/12/10(水) 18:11
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.