• 締切済み

シート内の複数の特定の文字を検出

お客さんからもらったEXCELのフォーマットに沿って集計ツールを EXCEL VBAで作成していますが、下記で詰まってしまいました。 表示されているシートを順に選択して、それ毎に「結果」と「実施日」と 入力されているセルがあるか探して、無ければとばして、あれば 処理していくという流れで作成しています。 ★の行が無い状態では動くのですが、それだとシート内で「結果」「実施日」を 見つけて処理した後に、次のシートへ行ってしまいます。 シートによっては複数の「結果」「実施日」があり（この２つはセット）、 それを全て拾って処理したいと考えて、繰り返す為に★の行を追加して実行すると、 一つ目の★の行で「オブジェクトが必要です」というエラーではじかれてしまいます。 自分としては、２つ目の★の行でオブジェクトを用意しているつもりですが。。。 For Each、、、に拘りは特に無いので、他の方法も含めて どなたかご教示いただきたいです。 For Each Sh In Worksheets Sh.Activate If Sh.Visible = True Then Set Kekka = Sh.Cells.Find(What:="結果") If Not Kekka Is Nothing Then Set jissibi = Sh.Cells.Find(What:="実施日") If Not jissibi Is Nothing Then For Each rg In UsedRange　★ Set rg = Range("kekka")　★ Day_Col = jissibi.Column Day_Col_Last_Row = Cells(Rows.Count, Day_Col).End(xlUp).Row Result_Col = rg.Column Call Count(A_count, B_count, C_count) Next rg　★ Else End If Else End If Else End If Next Sh

みんなの回答

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.3

＃２です。質問がよくわからないので勝手例題で、やってみた。 参考にして。 シートはＳｈｅｅｔ３対象（For each で複数シートに拡張はやさしい） 例データ シート内３セルで挟まれた中の日付を抽出。「開始日」と「終了」セルで挟まれたものを情報データ抜出。 データの状況と離散状況。 Ｂ４セルから３セル　開始日 2017/2/10 終了 Ｄ１３セルから３セル　開始日 2017/2/18 終期日 Ａ２２セルから３セル　開始日 2017/2/24 終了 ーー ２番目のブロックは開始日ー終期日であり、開始日ー終了でないので拾わない。 標準モジュールに Sub test3() 'For Each sh In Worksheets Set sh = Worksheets("Sheet3") sh.Select With sh.Cells Set c = sh.Cells.Find(what:="開始日", lookat:=xlWhole) MsgBox "場所 " & sh.Name & "=" & c.Row & "," & c.Column tx = Cells(c.Row, c.Column) & Cells(c.Row, c.Column + 1) & Cells(c.Row, c.Column + 2) MsgBox "３セル結合" & tx If tx Like "開始日*終了" Then MsgBox "日付 " & Mid(tx, 4, Len(tx) - 5) End If '条件に当てはまるセルがあるかどうかを判定 If Not c Is Nothing Then '最初のセルのアドレスを覚える firstAddress = c.Address '繰返し検索し、条件を満たすすべてのセルを検索する Do Set c = .FindNext(c) If c Is Nothing Then Exit Do MsgBox "場所 " & sh.Name & "=" & c.Row & "," & c.Column tx = Cells(c.Row, c.Column) & Cells(c.Row, c.Column + 1) & Cells(c.Row, c.Column + 2) MsgBox "３セル結合" & tx If tx Like "開始日*終了" Then MsgBox "日付 " & Mid(tx, 4, Len(tx) - 5) End If If c.Address = firstAddress Then Exit Do Loop End If End With 'Next End Sub で実行。 Ｍｓｇｂｏｘの出ようで、納得して。 検索該当終了で、最初の該当に戻るがその表示が出るままにしているが、夜遅いので手抜きした。

garigarisama
質問者

お礼

夜遅くにも関わらずご回答いただきまして、ありがとうございます。 意図と具体的なもの（データ）を整理してそちらから質問ようにした方が近道ですね。 コードも参考にさせていただきます。

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.2

質問内容・文章表現で補足すべきだとおもう。 （不完全と自認している）我流のコードを上げるよりも、データの状況を詳しく書け。 ＞特定の文字を検出 文字でなく、文字列（=複数文字の綴り）のことだろう？ ーー ある１つのシートで ＞「結果」と「実施日」と 必ずペアか？ 「結果」ー＞「実施日の出現順序の前後はこの順序か？ ーー ペアとして２ペア以上は出現しないのか？ 質問のコードではＦｉｎｄＮｅｘｔが使われていないが。 ーー 結果と実施日の間の列間か行間に、ほしいデータがあるのか。 例でも挙げて説明のこと ーー こういう文章・語句間からデータを抜くのは、むつかしい。ＨＴＭＬ文のタグの 間から内容を抜くのむづかしいが、ＴＡＧもないしね。 企業秘密もあるのだろうが、実例に近いものでも示して、質問しないと、わからない。 文章で処理ロジックを固めることがまず先だろう。 ＶＢＡでは検査語の組み合わせを指定して検索は、セルにデータが分れているだけに、かえって難しいのでは。 在り様が、結果＋データ＋実施日の３セルに限るなら、３セルのキストを結合し、「結果＊実施日」で検索するとか思ったりするが。

  • ushi2015
  • ベストアンサー率51% (241/468)
回答No.1

こんばんは シートによっては複数の「結果」「実施日」があり（この２つはセット） とは？ 2つのセットのセルの位置関係は？ セットは必ず同じ行にあるとかですか？

garigarisama
質問者

補足

これらの「結果」「実施日」は、片方でしかシートに記載されていないということが無いということです。 記載されているシートもセルも固定ではなく、どこにあるか分からない状態なのでCells.Findという大雑把な検索しかできないんです。 自分でこういった入力する文書を作成する際には、集計のことも踏まえて固定で作成するのですが、お客さんから指定されているのでこのように作らざるを得なくなっています。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • 特定の文字を含むシートを選択するには

    いつもお世話になっております。 特定の文字を含むシートのデータをコピーするにはどのようにしたらよろしいでしょうか。 具体的には (1)シート名の末尾に"D"を含むシートを選択 (2)選択したシートのデータをコピー (3)コピーしたデータを順次"Sheet1"に貼付 というマクロを組みたいのですが、(1)のところがうまくいきません。 以下のように作成してみました。 Dim sh As Worksheet Dim lr As Long, tlr As Long For Each sh In Worksheets If sh.Name = "*D" Then lr = sh.Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row sh.Rows("3:" & lr).Copy tlr = Sheets("Sheet1").Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row Sheets("Sheet1").Range("A" & tlr + 1).PasteSpecial End If Next 4行目の sh.Name = "*D" のところがうまくないようです。 よろしくお願いします。

  • EXCEL VBA 取得したセルの列の最終行

    お客さんからいただいたEXCELフォーマットに沿って、集計ツールを作成していますが 下記でつまってしまいました。 Wb.Worksheets("Sheet1").Cells.Find("実施日").Select Sel_Col = Selection.Column Last_Row = Wb.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row　※1 For i = Last_Row To 2 Step -1 If Wb.Worksheets("Sheet1").Cells(Sel_Col, i).Value = Day Then　※2 If Wb.Worksheets("Sheet1").Cells(Sel_Col, i).Offset(-5).Value = "A" Then A_count = A_count + 1 ElseIf Wb.Worksheets("Sheet1").Cells(Sel_Col, i).Offset(-5).Value = "B" Then B_count = B_count + 1 ElseIf Wb.Worksheets("Sheet1").Cells(Sel_Col, i).Offset(-5).Value = "C" Then C_count = C_count + 1 End If Else End If Next i まず※1の箇所ですが、Sheet1の実施日と入力されているセルの列番号を取得して その列の最終行を取得したいのですが、上記作成したものですと入力されている列全部の 中での最終行が取得されてしまいます。 この場合、Sel_Col をどのように使えばよろしいでしょうか？ 次に※2ですが、※1で取得した列の最終行から１つずつ上に上がりながら 日付が今日であれば、そのセルから５つ左のセルのA、B、Cいずれかを カウントするという造りにしたいと思っています。 実行すると1004エラーでアプリケーション定義、オブジェクト定義のエラーと 出てしまいます。 Wbはset Wbとして開いたブックを定義しています。 DayはDay = Dateで今日の日付を取得しています。 独学で無茶苦茶なコードですが、 どなたか詳しい方、ご教示お願いいたします。

  • 【エクセルVBA】特定のシートのみ検索したい

    VBA勉強中です。 フォルダにある複数のファイル（１ファイル内には複数シートあります）を順番に開けて検索をかけ、条件に合致した行をあるファイルへ転記・集約させるマクロを組みたいと思っています。 （条件は1番左の列が「○」であることです。） ネットや本を参考にしながら組んでみたのですが、「○」がない（シートの）行も転記されてしまい困っています。 （○があるシートは複数シートの内、１シートのみなのですが、○がないシートからも 「○があるシートの○がある行」と同じ行番号の行がが転記されているようです） 組んでみたマクロは以下のとおりです。 ------------------------------------------------ Sub 楕円1_Click() ActiveSheet.Range("A2:H30").ClearContents Dim ans, fn, wb, x, i, n, sh, myPath ans = "○"　'条件 myPath = ThisWorkbook.Path & "\" fn = Dir(myPath & "*.xls") '選択したフォルダ内のExcelファイル Do Until fn = "" If fn <> ThisWorkbook.Name Then 'ファイルが当ファイル以外なら Set wb = Workbooks.Open(myPath & fn) '選択したファイルを開きます For Each sh In wb.Worksheets '各シートごとに x = sh.Cells(Rows.Count, 1).End(xlUp).Row '最終行取得 For i = 1 To x '1行目から最終行まで以下を実行します If Cells(i, 1) = ans Then '条件に合致するか検索 n = n + 1 With ThisWorkbook.Sheets("Sheet1") '転記 .Cells(n + 1, 1) = sh.Cells(i, "B") .Cells(n + 1, 2) = sh.Cells(i, "C") .Cells(n + 1, 3) = sh.Cells(i, "D") .Cells(n + 1, 4) = sh.Cells(i, "E") .Cells(n + 1, 5) = sh.Cells(i, "F") End With End If Next i Next sh wb.Close (False) '選択したファイルを閉じる End If fn = Dir() '次のファイルを検索 Set wb = Nothing Loop '繰り返し --------------------------------------------------------- このマクロでは各ファイルの全てのシートを検索していると思うのですが、 全シートを検索していることが問題でしょうか？ 検索したいデータは特定のシートにのみ存在するので（全ファイル同じ名前のシートです） 特定のシートのみ検索してくれればそれで良いのですがどう変更すればよいかわかりません。 「For Each sh In wb.Worksheets '各シートごとに」　色々と調べてここを変更してみたのですが 何れもエラーとなり上手くいきませんでした。 どなたか上手く直す方法を教えて下さい。 宜しくお願いします。

  • 複数シートにわたる連番を自動作成するfunctio

    複数シートにわたる連番を自動作成するfunction関数をoffice 365のEXCELで作りました。 variant型で定義しており、連番途中に右側のセルが空白だった場合、対象セルを空白にし、上のセルが空白だった場合は、数字が出てくるセルまで上に行き＋１します。 左端のシート以外の最上のセルは左のシートの最大の数字+1に設定しています。 Function renban1() As Variant Dim temp As Integer, a_row As Long, a_col As Long Dim range1 As Range, ind As Integer Const a_spc = " " ind = ActiveSheet.Index a_row = ActiveCell.Row a_col = ActiveCell.Column renban1 = a_spc Set range1 = Range(Cells(a_row, a_col + 1), Cells(a_row, a_col + 7)) If a_col = 2 And a_row = 5 Then renban1 = 1 Exit Function End If If a_row = 12 And a_col = 2 Then If ind = 1 Then renban1 = 2 Exit Function Else If WorksheetFunction.CountA(range1) = 0 Then '右が空白 renban1 = a_spc Exit Function Else For temp = 80 To 12 Step -2 If ActiveSheet.Previous.Cells(temp, a_col).Value <> a_spc Then '上が空白以外≒数値 renban1 = ActiveSheet.Previous.Cells(temp, a_col).Value + 1 Exit Function End If Next temp End If End If End If If a_row > 10 And a_row < 82 Then '番号のセル範囲 If WorksheetFunction.CountA(range1) = 0 Then '右が空白 renban1 = a_spc Exit Function Else For temp = a_row - 2 To 12 Step -2 If Cells(temp, a_col).Value <> a_spc Then '上が空白以外≒数値 renban1 = Cells(temp, a_col).Value + 1 Exit Function End If Next temp End If End If End Function これで、動作自体は正しいのですが、いちいちセルをクリックしてENTERを押さないと正しく更新されません。（トリガーが無いので当然と言えなくもないのですが） １シートに３５行ほどあり、同様のシートが１１枚あるので、出来れば自動で更新させたいのですが、calculateやapplication.volatileを試してもうまくいきませんでした。 VBAにお詳しい方、どうやれば良いか教えて下さい。よろしくお願い致します。

  • VBA 複数のシートをまたいでの連想配列

    win7、Excelは2013を使用しています。 添付画像の様に、12シートの合計を連想配列に格納しsheet13に書き出したいのですが、プロシージャーの下から6行目のところで、エラーコード451が出ます。 どの様に変更すれば良いか教えて下さい。 Sub 年間集計() Dim Dic Dim i As Integer Dim j As Integer Dim sh As Worksheet Dim rng As Range Dim buf As String Dim num As Integer Set Dic = CreateObject("Scripting.Dictionary") For Each sh In Worksheets For Each rng In sh.Range("J2", sh.Cells(Rows.Count, 10).End(xlUp)) buf = rng.Value num = rng.Offset(, 1).Value If Not Dic.Exists(buf) Then Dic.Add buf, num Else Dic.Item(buf) = Dic.Item(buf) + num End If Next rng Next sh j = 2 With Worksheets("Sheet13") For i = 0 To Dic.Count - 1 .Cells(j, 1) = Dic.Keys(i)　　　’エラー箇所 .Cells(j, 2) = Dic.Items(i) j = j + 1 Next i End With End Sub

  • ExcelVBAで画像の様に動作を変更したいです

    先日、こちらにて 教えていただいたマクロでのデータ突合方法を基にマクロを作成中なのですが、 画像の様に動作させるにはどう修正すればよいでしょうか （目標） 画像のSheet1 と Sheet2の商品コードを上から順に突合し、 Sheet3に合致したA品番をコピー Sheet4に合致したB品番をコピー Sheet5に合致しなかったA品番をコピー Sheet6に合致しなかったB品番をコピー ※なお、A品番B品番ともに同じ値の品番がいくつか存在することがある。 この場合は、ループ中既に合致したデータは対象から外す。 判別方法は品番の一つ横のセルに”〇”を表記。（フラグを立てる） 「A品番＝B品番」のとき「Offset(0, 1)が”〇”」ならば合致しない　 --------------------------------------------------- （手順） (1)Sheet1 あり Sheet2 ありの場合 →一致したSheet1とSheet2のOffset(0, 1)に”〇” →一致したSheet1の行全体の値をSheet3にコピー →一致したSheet2の行全体の値をSheet4にコピー (2)Sheet1 あり Sheet2 なしの場合 →該当するSheet1の行全体の値をSheet5にコピー (3)Sheet1 なし Sheet2 ありの場合 →該当するSheet2の行全体の値をSheet6にコピー --------------------------------------------------- （現在のコード） Sub Test() Dim c As Range, FRange As Range Dim Sh1 As Worksheet, Sh2 As Worksheet Set Sh1 = Worksheets("Sheet1") Set Sh2 = Worksheets("Sheet2") For Each c In Sh1.Range(Sh1.Cells(3, "A"), Sh1.Cells(Rows.Count, "A").End(xlUp)) Set FRange = Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Rows.Count, "A").End(xlUp)). _ Find(c.Value, LookAt:=xlWhole, After:=Sh2.Cells(Rows.Count, "A").End(xlUp)) If Not FRange Is Nothing Then If c.Value = FRange.Value And FRange.Offset(1, 0).Value <> "◯" Then c.Offset(0, 1).Value = "◯" '↓(1).xlsmSheet2に Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value FRange.Offset(0, 1).Value = "◯" End If Else '↓(1).xlsmのSheet3に Sheets("Sheet5").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value End If Next For Each c In Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Rows.Count, "A").End(xlUp)) If c.Offset(0, 1).Value = "◯" Then '↓(2).xlsmのSheet2に Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value Else '↓(2).xlsmのSheet3に Sheets("Sheet6").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value End If Next End Sub ご指導頂ければ幸いです。

  • 全くの初心者ですVBA

    どこが悪いかわかりません。 教えてください。 Sub テスト() Dim kekka As String Dim i As Integer tokuten = Worksheets("Sheet1").Cells(i, 1).Value For i = 1 To Worksheets("Sheet1").Range("A1").End(xlDown).Row.Count If tokuten >= 80 Then kekka = "合格" Else kekka = "不合格" kekka = Cells(i, 2) End If Next i End Sub シート１の A列に数値で得点が入っています。

  • 対象のシートが３行目からになった修正について

    対象のシートが３行目からになってしまったのですが、修正したいのですが、どこを修正したらよいかが分からず、困っています。お教え頂けませんか。よろしくお願いします。初心者で申し訳ありません。 Sub 統合() Dim J As Long Dim r As Long Dim s As Long Dim Sh As Worksheet Dim MaxRow As Long Dim MaxCol As Long Dim MyArray As Variant Dim JoinSh As Worksheet Set JoinSh = Worksheets("統合") '統合シートを変数に格納 JoinSh.Cells.Delete 'すでに統合シートが存在する場合は一旦セルを削除 s = 1 '最大行を超えた場合次の統合シートを作成するための番号 For i = s + 1 To Worksheets.Count 'シートを統合シートの次～末尾までループ With Worksheets(i) '各月シート If J = 1 Then r = 1 '最初だけ項目も取得 Else r = 1 '最初以外は2行目から取得 End If MaxRow = .Cells(Rows.Count, 10).End(xlUp).Row '9列目で最終行を取得 MaxCol = .Cells(1, Columns.Count).End(xlToLeft).Column '1行目で最終列を取得 MyArray = Range(.Cells(r, 10), .Cells(MaxRow, MaxCol)) 'A1～データ末尾まで配列に格納 End With With JoinSh '統合シート MaxRow = .Cells(Rows.Count, 10).End(xlUp).Row '統合シートの9列目で最終行取得 If MaxRow + UBound(MyArray) > Rows.Count Then '最大行を超える場合の処理 s = s + 1 '統合シートの番号を加算 Worksheets.Add Before:=Worksheets(s) '新規に統合シートを追加 ActiveSheet.Name = "統合" & s '名前が同じにならないように番号を追加 Set JoinSh = ActiveSheet '統合シートを変数に格納 MaxRow = JoinSh.Cells(Rows.Count, 10).End(xlUp).Row '統合シートの9列目で最終行取得 End If If .Cells(1, 1) = "" Then '最初だけ1行目から貼り付け Range(.Cells(1, 1), .Cells(UBound(MyArray), MaxCol)) = MyArray Else '最初以外は最終行の次に貼り付け Range(.Cells(MaxRow + 1, 1), .Cells(MaxRow + UBound(MyArray), MaxCol)) = MyArray End If End With Next i End Sub

  • マクロで複数の行をまとめて切り取りする方法

    Ｉの列のセルに「テスト」があったら、その行を切り取ってシート2に貼り付ける といった流れのコードが下記です。 Sub 切り取り() Dim i, LastRow As Long LastRow = Cells(Rows.Count, 9).End(xlUp).Row For i = 1 To LastRow If Cells(i, 9) = “テスト” Then Rows(i).Cut Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End If Next i End Sub ●Ｉの列のセルに「テスト」と「課題」があったら、その行を切り取ってシート2に貼り付ける といったものをしたいのです。 1. If Cells(i, 9) = “テスト” Then ↓ If Cells(i, 9) = “テスト,課題” Then 結果エラー 2. If Cells(i, 9) = “テスト” Then ↓ If Cells(i, 9) = “テスト&課題” Then 結果エラー 正常なコードを教えてくださいますか？ 宜しくお願いします。

  • Excel VBA で特定のシートのみ除外

    ＶＢＡで以下のような、ブック内の全シートから特定の文字列が入った行のみを新しくシート作成して一覧化するマクロを組みました。 検索する時に保護解除するなど別の作業もあるため無駄に長くなっております。 Sub 検索() Dim Sh As Worksheet, Rng As Range Dim StrFind As String, Res As String Dim Rw As Long, R As Long Dim N As Integer Const OutShName = "検索結果" StrFind = InputBox("検索する文字列を入力してください。" & " 　　 検索する文字列は正確に。", "検索文字列") If StrFind = vbNullString Then Exit Sub Dim Ws As Worksheet Application.ScreenUpdating = False For Each Ws In Worksheets Ws.Unprotect Password:=908118 Next Application.ScreenUpdating = True Application.ScreenUpdating = False UserForm1.Show vbModeless UserForm1.Repaint For N = 1 To Worksheets.Count If Worksheets(N).Name = OutShName Then Set Sh = Worksheets(N) Sh.Move after:=Worksheets(Worksheets.Count) Sh.Cells.ClearContents Exit For End If Next N If N > Worksheets.Count Then Set Sh = Sheets.Add(after:=Worksheets(Worksheets.Count)) Sh.Name = OutShName End If Worksheets(1).Rows(1).Copy Sh.Rows(1) R = 2 For N = 1 To Worksheets.Count - 1 With Worksheets(N).UsedRange For Rw = 1 To .Rows.Count Set Rng = .Cells(Rw, 1).Resize(, .Columns.Count).Find(StrFind) If Not Rng Is Nothing Then Rng.EntireRow.Copy Sh.Rows(R) R = R + 1 End If Next Rw End With Next N Unload UserForm1 ResultMsg: If R < 3 Then Res = "「" & StrFind & "」 は、見つかりません。" For Each Ws In Worksheets Ws.Protect Password:=908118 Next Sheets("TOP").Select Else Columns("A:A").ColumnWidth = 20 Columns("C:C").ColumnWidth = 13 Rows("1:1").RowHeight = 30 Sheets("12月").Select Rows("1:1").Select Selection.Copy Sheets("検索").Select Range("A1").Select Application.ScreenUpdating = True Res = "「" & StrFind & "」 は、" & R - 2 & " 件 見つかりました。 " & _ String(2, vbLf) & Sh.Name & " に抽出しました。" Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.Font.Bold = False Selection.Font.Bold = True End If MsgBox Res, vbInformation, "検索完了" Set Rng = Nothing End Sub Excel2003を使用してます。 シートは30枚程あり、複雑な計算式等が入っています。 この時、特定のシート（例:"月別データ")のみを除外したいのですが、いまいちわかっておりません。 稚拙な質問かと思いますがご指導していただきたく思います。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する