[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『何処が、何が悪いのか教えてください。』（nori)
下のプログラムは本で読んだプログラムを下敷きに、皆さんに教えていただいたことを 組み合わせて作って、ヤッタ！と思っていたらエラーが出て動かなくなりました。 いろいろやってはいるのですが､何処が、何が悪いのか判りません。教えてください。
シートの構成（入力用シート）
A B C D E F G H I
7 番号 業者名 検索値 品名 色・サイズ等 注文数 単位 単価 合計額
8 １ A商会 鋸 32山 鋸 32山 １ 本 900 900
9 2 B商事 金鎚 大 金鎚 大 １ 本 700 700
色、サイズ、単位 そして単価を検索値で表引きしたデータが入るK,L,Mのセルがあります。
此処で､購入したい物品名を書き込んで行き､コマンドボタン１をクリックすれば業者名毎に
シートがあれば､そのシートに、シートが無ければ業者名のシートを挿入して､そこに、品名
やカタログ名、注文数等を書き込んだ発注伝票をつくる事を考えております。
皆様に教えていただき､出来上がり､喜んでいたのですが､何をどうやったのか判らないのです
が今朝から動かなくなりました。動かなくなるところは､コードの下に^^^をつけたところで
す。なお、そこを変更を加え､戻ろうとするとフリーズして動かなくなり､Alt+Ctr+Delを押し
て復旧せざるを得ない状態です。また、このシートに関係するプログラムを全部書き込みまし
た。何処がどの様に悪いのか、どのような対策を行えば良いのか、を教えてください。
見づらく､読みづらいと思いますが,よろしくお願い致します。
Private Sub CommandButton1_Click()
Dim LastRow1 As Long '元データの最終行
Dim LastRow2 As Long '作業用シート「Temp」のデータの最終行
Dim LastRow3 As Long
Dim SheetCheck As Integer
Dim i As Integer
Dim Rng As Range
Dim Sh As Worksheet
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = Sheets("木工作入力シート")
Application.ScreenUpdating = False '画面の更新を停止
'作業用シートの挿入
Worksheets.Add(after:=WS1).Name = "Temp"
Set WS2 = Sheets("Temp")
'データの最終行を取得
LastRow1 = WS1.Range("B65536").End(xlUp).Row
'重複する業者名を除いて作業用シート「Temp」に抽出
WS1.Range("B8:B" & LastRow1).AdvancedFilter _
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Action:=xlFilterCopy, CopyToRange:=WS2.Range("A1"), _
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Unique:=True
^^^^^^^^^^^^
'作業用シート「Temp」のデータの最終行を取得
LastRow2 = WS2.Range("A65536").End(xlUp).Row
'抽出した各業者毎に処理を繰り返す
For Each Rng In WS2.Range("A1:A" & LastRow2)
'業者名のシートの有無をチェック
SheetCheck = 0
For Each Sh In Worksheets
If Sh.Name = Rng.Value Then
SheetCheck = 1
Exit For
End If
Next Sh
If SheetCheck = 1 Then '業者名のシートがあった場合
'業者名シートの入力されているデータの最後を求める
LastRow3 = Sheets(Rng.Value).Range("B65536").End(xlUp).Row
'業者名毎にデータを抽出
WS1.Range("B8").AutoFilter Field:=2, Criteria1:=Rng.Value
'抽出したデータに対応する業者名のシートにデータをコピー
WS1.Range("D8:J" & LastRow1).Copy
Sheets(Rng.Value).Range("B" & LastRow3 + 1).PasteSpecial Paste:=xlPasteValues
Else '業者名のシートがなかった場合
'業者名のシートを挿入
Worksheets.Add(after:=Sheets(Sheets.Count)).Name = Rng.Value
'業者名毎のデータの抽出
WS1.Range("B8").AutoFilter Field:=2, Criteria1:=Rng.Value
'抽出したデータに対応する業者名のシートにデータをコピー
WS1.Range("D8:J" & LastRow1).Copy
Sheets(Rng.Value).Range("B8").PasteSpecial Paste:=xlPasteValues
End If
WS1.Range("B8").AutoFilter 'オートフィルタの解除
Next Rng Application.DisplayAlerts = False '警告メッセージの表示を無効 WS2.Delete '作業用シートの削除 Application.DisplayAlerts = True '警告メッセージの表示を有効 Application.ScreenUpdating = False '画面の更新を有効 WS1.Activate
End Sub
Private Sub CommandButton2_Click()
Dim WS1 As Worksheet
Set WS1 = Sheets("木工作入力シート")
If MsgBox("現在の入力内容を消して宜しいですか？", _
vbYesNoCancel, "木工作入力シートの内容クリア") = vbYes Then
With WS1
.Range("E2:E5,B8:J67").SpecialCells(xlConstants, 23).ClearContents
.Range("E2").Select
End With
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ActRow As Integer
Dim myData As Range
Set myData = Application.Intersect(Target, Range("C8:C67"))
ActRow = Target.Row
If myData Is Nothing Then Exit Sub
Application.EnableEvents = False
Application.ScreenUpdating = False
Cells(ActRow, "L").Copy
Cells(ActRow, "F").PasteSpecial xlPasteValues
Cells(ActRow, "M").Copy
Cells(ActRow, "H").PasteSpecial xlPasteValues
Cells(ActRow, "N").Copy
Cells(ActRow, "I").PasteSpecial xlPasteValues
Application.EnableEvents = True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
- - - -
提示されたデータで、AdvancedFilterまでのコードを走らせても、問
題は発生しませんでした。
これはExcel2000での話ですが、論理値Trueが組み込み定数として認識
されなくなったと言う経験はあります。そのときはアプリケーションの
自動修復を行いましたが再発し、アプリケーションの再インストールで
何とか回復した記憶があります。
（必ずしも同様の現象とは言い切れません）
そこで、まずは、別のPCのエクセルで実行してみて・・・
同じ現象が起きるようなら、ブックの破損か、コード上の問題。
おきないようなら、それを実行しているPC（エクセル）の問題。
と言う風に、原因を切り分けてみてはいかがでしょう。
とりあえず未回答のままにして置きます。
本題に関係ない細かい点では、WS1.Range("B8:B" & LastRow1).AdvancedFilter
で、B8セルの値がリストの「見出し」として認識されるかもしれません。
（B8と同じ値がそれ以降にあった場合、B8の値がWS2のA列に2回表示され
る）
(みやほりん)(-_∂)b
先ずはみやほりんさんのおっしゃるように新規Bookにデータ、プログラムを コピペしてそちらで試してみるとかが定石かと。 neptune
みやほりんさん、neptuneさん、アドバイス有難う御座います。 excel2007の互換モードで試したところ、何の問題も無く動きました。 >本題に関係の無い・・・ も従って、無いようです。 neptuneさんにアドバイスしていただいた方法を試すしか無いようです。トホホです。
>>本題に関係の無い・・・
>も従って、無いようです。
いえ、これはコードが期待通りに動いても発生する問題です。
Ｅｘｃｅｌバージョンによって動作が異なる可能性はありますが、
当方の試行ではB8セルの値が見出しとして認識されています。
（Excel2003）
ご提示の入力用シートのレイアウト、行位置が正しいとすれば、
「A商会」が10行目以降に複数存在した場合は見出しとして「A
商会」が先頭にひとつ、そして、抽出データとして「A商会」が
もうひとつ抽出された格好になります。従って抽出コードは
WS1.Range("B7:B" & LastRow1).AdvancedFilter
が適当であろう、と言うのが私の提案です。
この場合、見出しが不要であるのなら見出し行を削除するか、
あるいはその後のループで見出し行の部分だけ作業をパスするか
などの処理が必要でしょう。
もちろん、重複がないかどうか確認するコードにも出来ますが、
上記のほうがシンプルだと感じます。
(みやほりん)(-_∂)b
新たに質問をしなおすのであれば以前の質問にはその旨を書いて一段落させておいた方がいいですよ。
(独覚)
みやほりんさん、お世話になります。 私もいろいろやっている最中に指摘された事には気が付いたのですが､改めてテストしてみます。 しかし、一晩かかり､作り直したのですが､また同じような状況になったらと考えると、やる気が 失せてゆきます。 ご指摘のことと、AdvancedFilterのところでエラーが出るのは関係しているのでしょうか？
独覚さん、有難う御座います。現在作成しているプログラムの一部ではあるのですが､話題が違う ので良いかと思い､質問ししまいました。 失礼致しました。ご注意いただいたこと書き込みました。
みやほりんさん、試してみました。その結果を報告させていただきます。
>従って抽出コードは、WS1.Range("B7:B" & LastRow1).AdvancedFilter
にしてテストしました。
作業用のシート「Temp」を残すように設定して、テストし､その内容をみると
WS1.Range("B7:B" & LastRow1),AdvancedFilterにすると「表題」の下に入力した各業者名
が表示されます。そして､表題と同じ「業者名」と言うシートが挿入され､その中に記入した各
業者への注文内容が書き込まれています。
次にB7の部分を元のB8に戻すとAdvancedFilterのところでエラーが出て､フリーズ。B7に戻す
と動作する。
worksheet_change()を使っているのと何か関係があるのでしょうか？？？
挿入された「業者名」のシートを削除すれば良いか、とも考えておりますが､B8に設定して､問
題が見つかっていないのです。私の使っているバージョンは２０００です。
みやほりんさん、書き込んだことが間違っていました。 訂正させていただきます。B8のままでは､エラーになる。B7だとエラーにならない。 請求シートのほうに入力内容の転記が終わった時点で表題を業者名として判断され､ 作られてしまうシートを削除する方向で試してみます。
なぜB8だと実行できないのかはちょっと判りません。
こちらでは動いてはいるので。たぶん、本データが「見出しが認識できない」
などの理由にかもしれませんが、それだとエラーが表示されるのではないかと。
>エラーが出るのは関係しているのでしょうか？
「本題に関係ない細かい点では、」とも書きましたし、
「コードが期待通りに動いても発生する問題です。」と書いたのですが・・・
仮に、以下のようなB列に「A商会」が2行だけのデータで
WS1.Range("B8:B" & LastRow1).AdvancedFilter ・・・を実行した場合に、
A B C D E F G H I
7 番号 業者名 検索値 品名 色・サイズ等 注文数 単位 単価 合計額
8 １ A商会 鋸 32山 鋸 32山 １ 本 900 900
9 2 A商会 金鎚 大 金鎚 大 １ 本 700 700
期待する結果は
[temp]
[A]
[1] A商会
とひとつだけ抽出されるものですが、実際には
[temp]
[A]
[1] A商会
[2] A商会
と、二つ抽出されてしまいますよ、この場合、一行目のものは見出しとして
抽出されているのですよ、と言うことをお伝えしたかったのです。
この状態のまま転記部分が実行されると、現状のコードでは「A商会」のシー
トに同じ内容が二度書き込まれます
これはAdvancedFilterの動作が、抽出元フィールドに「見出し」が必ず必要
であり、抽出先でも見出しが出力されるという仕様に起因しています。
それを意識したコードを作りましょう。
エラーとの関係は、ご提示のコードがこちらではちゃんと走っているので不
明。
>worksheet_change()を使っているのと何か関係があるのでしょうか？？？
ブレークポイントを設定して、ステップインデバッグすれば関係しているか
どうかはご自身で確認できます。
(みやほりん)(-_∂)b
＞訂正させていただきます。B8のままでは､エラーになる。B7だとエラーにならない。
転記すべきデータが一行しか存在しないのでは？ (それだと、8行目が項目名で、検索すべき対象行がゼロと見做されるのからではないでしょうか？） ＞請求シートのほうに入力内容の転記が終わった時点で表題を業者名として判断され､ ＞作られてしまうシートを削除する方向で試してみます。
筋としては、B7にして、必ず7行目は転記させ、転記先の2行目から処理すべきだと思います。 以下、一案です。
'この上の部分は同じなので省略
Set WS1 = Sheets("木工作入力シート")
'データの最終行を取得
LastRow1 = WS1.Range("B65536").End(xlUp).Row '←ここで最初にデータ行を取得する
if LastRow1 < 8 then exit Sub '←ここでデータの存在を確認する
Application.ScreenUpdating = False '画面の更新を停止
'作業用シートの挿入
Worksheets.Add(after:=WS1).Name = "Temp"
Set WS2 = Sheets("Temp")
'重複する業者名を除いて作業用シート「Temp」に抽出 '←フィルターはB7を含める
WS1.Range("B7:B" & LastRow1).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=WS2.Range("A1"), _
Unique:=True
'作業用シート「Temp」のデータの最終行を取得
LastRow2 = WS2.Range("A65536").End(xlUp).Row
'抽出した各業者毎に処理を繰り返す
For Each Rng In WS2.Range("A2:A" & LastRow2) '←TmpのA2から開始する
'この下の部分は同じなので省略 ※ 個人的には、毎回Tmpシートを作ったり、削除したりするのも、エクセルに負担を掛けるのでやろうとは思いません。 (私なら、Tmpシートを常駐させ、必要な都度、データをクリアーして再利用すると思います)
（半平太）
半平太さん､有難う御座います。 B8をB7にし、挿入された不必要なシートを削除することばかリ考え､参考書をひっくり返し､ おっ繰り返ししておりました。 それが､アレマ〜です。本当に有難う御座いました。 tmpの常駐､必要な都度､データをクリアーする、試してみます。 昨日は､出来た！と思っていたブックが全く駄目か・・・と非常に落ち込んでいました。 本当に有難う御座いました。 みやほりんさん、neptuneさん、独覚さん、有難う御座いました。
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.