[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロが実行できない』（ささの）
はじめましてこんにちは、
こちらの掲示板を拝見し自分なりにマクロをいじったのですが
エラーがでてしまいます。
原因を探したのですが上手く行かない為、ご指導いただけますと幸いです
シート1のa2で検索をかけシート2が全データになるのですがそこから抽出するというマクロです
検索をｈ列までかけたいのです
データがは1万件以上です
Option Explicit
Private Sub Worksheet_Change(ByVal target As Range) Const wshInfoName As String = "結果" Const CriteriaScope As String = "A1:h9" Dim originalWord Dim BufWord As String
If target.Address(0, 0) <> "A2" Then Exit Sub
If target.Value = "" Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
originalWord = Range("A1:H2").Value
BufWord=Target.Value
On Error Resume Next
Application.Undo
If Err.Number=0 Then
myReDO=Target.Value
Target.Value=Bufword
End If
On Error GoTo 0
Range("A1:D2,A3:T15000").ClearContents
Range("A1:B1").Value = Sheets(wshInfoName).Range("A1:B1").Value
Range("C1").Value = Sheets(wshInfoName).Range("h1").Value
Range("A2,B3,C4,D5,E6,F7,G8").Value = "*" & originalWord(2, 1) & "*"
Range("A2,B3,C4,D5,E6,F7,G8,H9").Value = "*" & originalWord(2, 1) & "*"
Sheets(wshInfoName).Columns("A:T").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("検索").Range(CriteriaScope), CopyToRange:=Range("A6"), Unique:=False
Range("A1:H2").Value = originalWord
Range("A3:D5").ClearContents
Columns("A:T").EntireColumn.AutoFit
ActiveWindow.FreezePanes = False
Rows("7:7").Select
ActiveWindow.FreezePanes = True
Application.Goto Reference:="R6C1"
Rows(7:15000).RowHeight=18
Range("A2").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
めちゃくちゃなマクロかと思います・・・
すみません・・宜しくお願い致します
＜ 使用 Excel：Excel2003、使用 OS：WindowsXP ＞
（γ） 2017/02/16(木) 22:43
エラーは1004エラーです
すみません、初心者で何がエラーか分からない状態です。
やりたいことはシート内検索
文字を入力すれば文字の含まれた単語を抽出したいのです。
シート1のA2を検索文字入力として
それ以下に結果を表示がさせたい、全ての情報はシート2のaからnまで現在はあり(増えるかもしれません)
ただし検索文字はaからh間で行いたいというマクロになります
回答になれていますでしょうか？
お手数ですがよろしくお願いします。
（ささの） 2017/02/16(木) 23:33
（γ） 2017/02/16(木) 23:36
>エラーは何故かかからなくなったのですが
コードは何も変えておらず、シートの状況も何も変えていないのにエラーがでなくなったということですか？
もし、【試行錯誤】の過程でコードを変えているならそれをアップしてください。
もし、コードを変えていないとすれば、エラーが出ていた時のシートと、現在のエラーが出ないシートで 何か変更ををしたかどうか、具体的に教えてください。
また現在はエラーが出ないとしても、エラーがでていた時に黄色く光ったコードはどこでしたかとの γさんの質問に答えてください。
その時のエラーメッセージも覚えていれば、アップしてください。 1004エラーには、多くの原因があり、エラーメッセージを見なければ、的を絞ったアドバイスが できませんので。
（ β） 2017/02/22(水) 23:23
追加で。
まずアップされたコードは【本物】ですか？
Rows(7:15000).RowHeight=18 これが構文エラーになり実行されないはずですが？
それと、
>検索が実際Ｈまでできていない状況です
この日本語もわかりません。 具体的に、かつ正確に状況を伝えてください。
さらに追加。
このコードが書かれたシート（Sheet1?)、結果シート、検索シートの、それぞれの 具体的なレイアウトを正確に説明してください。
（ β） 2017/02/22(水) 23:34
わからないことだらけですので、質問していることに対する回答を待ちますが、 フィルターオプション処理ですよね。
CopyToRange:=Range("A6") ですから このコードが書かれているシート（Sheet1?)の A6から始まる領域に
抽出結果を転記しようとしてますね。
フィルターオプションなら、抽出先にタイトル行があるか、あるいは、条件によってはすべてが空白ということが 必要ですが、このシートの A6から始まるタイトル行には、
Range("A2,B3,C4,D5,E6,F7,G8,H9").Value = "*" & originalWord(2, 1) & "*"
これが何のために何をしているコードなのか全くわかりませんが、これによって E6 に *なんとか* という文字列があります。
そうすると、フィルターオプションでは、フィールド名がないのでできません というエラーになります。
そもそも、フィルターオプションを理解していますか？（手作業ならできますか？）
（ β） 2017/02/22(水) 23:51
検索をｈ列まで掛けると言う事は、8列検索する事になりますよね？ 8つの検索条件(OR条件）を入れるとなると、9行要しますよ。(←タイトル行+8行)
なのに、何故、打ち出し開始がA6からなんですか？ A10以下じゃないとおかしくないですか？
↓
＞ CopyToRange:=Range("A6")
コードを見ても、よく分からない事が所々にあるんですが（ 元々チャンと動いていないのでしょうから、読み取れるハズもないです。
私としては、こんなのでいいと思えちゃう・・・
Private Sub Worksheet_Change(ByVal target As Range) Const wshInfoName As String = "検索" Const CriteriaScope As String = "A1:N9"
Dim BufWord As String
If target.Address(0, 0) <> "A2" Then Exit Sub
If target.Value = "" Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
BufWord = target.Value
Range("A2:T15000").ClearContents
target.Value = BufWord
Range("A2,B3,C4,D5,E6,F7,G8,H9").Value = "*" & BufWord & "*"
Sheets(wshInfoName).Columns("A:N").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("結果").Range(CriteriaScope), CopyToRange:=Range("A10:N10"), Unique:=False
Columns("A:T").EntireColumn.AutoFit
ActiveWindow.FreezePanes = False
Rows(10).Select
ActiveWindow.FreezePanes = True
Rows("10:15000").RowHeight = 18
Range("A2").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
（半平太） 2017/02/22(水) 23:56
検索、結果は以下になっております
結果が抽出したいデータが入っています
行 __A___B___C____D____E__ _F__ _G__ _H__ _I__
1 コード 分類 説明1 説明2 説明3 変換6 科目 属性 金額 2 XKY1 FFDG 5-8 5525 鉛 98-6 88 1 \9800 3 559-55 Z556 5-58 5578 銀 98-8 88 1 \88 4 888i FFZ 2 5588 鉛 6158 88 2 \850 5 XXX-21 665Z 8857-8 1568 金属 29 88 1 \77
検索
行 __A___B___C____D____E__ _F__ _G__ _H__ _I__
1 2 ココで検索 3 4 5 コード 分類 説明1 説明2 説明3 変換6 科目 属性 金額 ↓以下検索結果表示 6 559-55 Z556 5-58 5578 銀 98-8 88 1 \88 7 888i FFZ 2 5588 鉛 6158 88 2 \850 8 XXX-21 665Z 8857-8 1568 金属 29 88 1 \77
半平太さんのマクロを試してみたのですが
＞ Sheets(wshInfoName).Columns("A:N").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("結果").Range(CriteriaScope), CopyToRange:=Range("A10:N10"), Unique:=False
にエラーがでてしまい名前等変更したのですができませんでした。
すみません・・・
またできれば半角、全角とも検索できたら良いなとも考えています・・・
データーがエタノールと入力されているものもあればｴﾀﾉｰﾙと明記されてあるものもあり、治すのが大変なぐらいの量あるので・・・
大変お手数おかけしますがご教授頂けますと幸いです
宜しくお願いします
（ささの） 2017/02/23(木) 20:26
>にエラーがでてしまい名前等変更したのですができませんでした。
すでに、たんにエラーではなく【エラー番号とその時に表示されたメッセージ文言】を示してくださいという コメントがあがっているのに、あいかわらず『エラーでした』ですか？
（ β） 2017/02/23(木) 20:59
まだよくわからないところがあるんですが
１．関連するシートは 検索 と 結果 だけですね。 ２．検索 シートの A2 に文字列を打ち込む --> 結果シートの該当のものを 検索シートの6行目以降に抽出 ですね？ ３．検索 シートの A2 に打ち込む文字列は、 コード、分類、説明1、説明2、説明3、 変換6、科目、 属性 、金額 のどの列に対する抽出語句ですか？
（ β） 2017/02/23(木) 21:17
もしかして・・と想像しまくりですので、これが的を得ているのかどうか、はなはだ疑問ですが。 検索シートの５行目には、あらかじめ、結果シートのタイトル行と同じものが記入されているという前提です。
作業シートを準備してください。からっぽでＯＫ。シート名もなんでもいいのですが 以下のコードでは "work" という名前にしています。 このシートは非表示にしておきましょう。
検索シートのシートモジュールに以下。
A2 に入力された語句が結果シートの【どこかの列】に存在すれば抽出します。 結果シート側の値が 半角であろうと全角であろうと抽出（しているつもり）
A2 がDeleteキーでクリアされたら全データを抽出します。 クリア時は、逆にデータを消したいということなら、それも可能です。
なお、枠固定や行の高さの設定はマクロで毎回やる必要がないのでコードには含めていません。 あらかじめ手作業で設定しておけばいいことですから。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim shW As Worksheet
Dim c As Range
Dim pos As Range
Dim shL As Worksheet
Dim wd As String
If Intersect(Range("A2"), Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
wd = Range("A2").Value
Set shL = Sheets("結果") '元データシート
Set shW = Sheets("work") '★作業シート
shW.Cells.ClearContents
shW.Range("A1:H1").Value = shL.Range("A1:H1").Value '検索用タイトル行
Set pos = shW.Range("A2")
For Each c In shW.Range("A1").CurrentRegion
pos.Value = "*" & wd & "*"
pos.Offset(1).Value = "*" & StrConv(wd, vbNarrow) & "*"
pos.Offset(2).Value = "*" & StrConv(wd, vbWide) & "*"
Set pos = pos.Offset(3, 1)
Next
shL.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=shW.Range("A1").CurrentRegion, CopyToRange:=Range("A5", Range("A5").End(xlToRight))
Application.EnableEvents = True
End Sub
（ β） 2017/02/24(金) 03:58
β様のマクロ、実行ができ、まさに求めていたものでした・・・
言葉足らずの中、誠に有難うございました。
大変不快な思い、ご迷惑をおかけしましたが教えて頂き幸いに思います
有難うございます
自分の作っていたシートに名前を変更し貼り付けたのですが上手く動かなかったので
知らぬところで変な事をやってしまっていたのかと思います
なので起こり得ないことも起こっていたのかなと。。。判らぬままですが
新しく作り直し実行でき感激しております
この度は沢山のお方に教えて頂き、有難うございました
（ささの） 2017/02/24(金) 22:14
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.