教えて!gooにおける不適切な投稿への対応について

初心者です。ネットで見ながら記述したものです。データシートにあるC2の項目から部分一致で検索して抽出シートに転記したいのですがエラーが発生します
A作業日 B記入者 C現場名 D作業者名 E作業時間開始 F終了時間 G就労時間 H作業内容 I使用機器 J品目 Kサイズ L数量 M単位 N単価 O金額
AからOまで記述されています。C2現場名が文字数が多いので部分一致で検索したいのです。
よい方法をご指導ください、下記記述の訂正をお願いします。

Dim Ws1, Ws2 As Worksheet
Sub 抽出()

Set Ws1 = Worksheets("転記")
Set Ws2 = Worksheets("データ")

Call 削除

'項目名のコピー
Ws2.Rows(1).Copy
Ws1.Range("A4").Paste Special
Application.CutCopy Mode = False
Ws1.Range("B2").Select
Dim keyword As String
keyword = Ws1.Range("B2").Value
Dim x, y, z As Long
Dim word As String

'項目数のカウント
z = 1
Do While Ws2.Cells(1, z).Value <> ""
z = z + 1
Loop
z = z - 1
'検索ワードが含まれる内容を抽出
x = 5
y = 2
Do While Ws2.Cells(y, 1).Value <> ""
'検索対象をまとめる
word = ""
For i = 1 To z
word = word & Ws2.Cells(y, i)  この部分がエラーになります
Next i
'検索を行う
If word Like "*" & keyword & "*" Then
For i = 1 To z
Ws1.Cells(x, i).Value = Ws2.Cells(y, i).Value
Next i
x = x + 1
End If
y = y + 1
Loop
End Sub

Sub 削除()
Dim x, y As Long
'項目数のカウント
x = 1
Do While Ws1.Cells(4, x).Value <> ""
x = x + 1
Loop
x = x - 1
'行数のカウント
y = 5
Do While Ws1.Cells(y, 1).Value <> ""
y = y + 1
Loop
y = y - 1
End Sub
以上です。

質問者からの補足コメント

  • A列作業日のところを1か月であれば作動しますが、数か月分となるとエラーが発生します。

    word = word & Ws2.Cells(y, i)  この部分がエラーになります

      補足日時:2021/05/03 18:44
gooドクター

A 回答 (5件)

#4です


エラーについてですが、word = word & Ws2.Cells(y, i)
ここでエラーが出るのは、よくある例だとyやiが0又は負の数値などの時か(1004)
Ws2.Cells(y, i)の値にエラーが入っている時(13)だと思います。
なので、
どのようにして数か月にしているのかな?となりました。

セルの表示がエラーになっていないか確認してみてください。
また、転記方法を確認してみてください。
セルにエラーがあった場合は、転記方法を変えるなどしてエラーを無くすか、セルのエラー判定で分岐又は書き替え処理を追加すれば良いと思います。(エラー内容が解らないので言い切れませんが)

>下記記述の訂正をお願いします。
C列と検索列が決まっているのであれば、
'検索対象をまとめる
word = ""
For i = 1 To z
word = word & Ws2.Cells(y, i)  この部分がエラーになります
Next i
は不要です。
If word Like "*" & keyword & "*" Then に C列セルを直接で
If Ws2.Cells(y, 3) Like "*" & keyword & "*" Then でよいかと

zについては#4方法やO列と決まっているのなら、z=15 としてしまっても動きます。

また、範囲が分かっていれば
For i = 1 To z
Ws1.Cells(x, i).Value = Ws2.Cells(y, i).Value
Next i
は、
Ws1.Range(Ws1.Cells(x, 1), Ws1.Cells(x, z)).Value = _
Ws2.Range(Ws2.Cells(y, 1), Ws2.Cells(y, z)).Value
でループしなくても一度に代入出来ます。

Sub 削除()については、一例として
Ws1.Range("A4:O" & Ws1.Range("A4").End(xlDown).Row).ClearContents
で削除できます(値)

一例
Do While Ws1.Cells(y, 1).Value <> ""
y = y + 1
Loop
ではありませんが

Sub 抽出()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim keyword As String
Dim x As Long, y As Long, z As Long
 Set Ws1 = Worksheets("転記")
 Set Ws2 = Worksheets("データ")
 '項目名のコピー
 Ws1.Range("A4:O" & Ws1.Range("A4").End(xlDown).Row).ClearContents
 Ws2.Rows(1).Copy Ws1.Range("A4")
 
 keyword = Ws1.Range("B2").Value
 With Ws2
 '項目数のカウント
  z = .Cells(1, Columns.Count).End(xlToLeft).Column
  x = 5    '書き出し始めの行番号
 'データシートを行方向にループ
  For y = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
 '検索範囲C列セルに含まれているか
   If InStr(.Cells(y, "C"), keyword) > 0 Then
 '検索ワードが含まれていれば
    Ws1.Range(Ws1.Cells(x, 1), Ws1.Cells(x, z)).Value = _
    .Range(.Cells(y, 1), .Cells(y, z)).Value
    x = x + 1
   End If
  Next
 End With
End Sub

ただ、結構な行数になるようなので、掲示のロジックだと少々難がありそうです
なさりたい事を読むとC列からあいまい検索で抽出したデータ(行)をWs1に出力するのなら、AutoFilter を使用するのが簡単です。
ループも必要無いです。

一例でサンプルを書きます。
Sub testSample()
Dim keyword As String
 With Worksheets("転記")
  keyword = .Range("B2").Value
 '転記シートのA4セルから下のセルをクリアー
  .Range("A4:O" & .Range("A4").End(xlDown).Row).Clear
 End With
 With Worksheets("データ")
 '実行時のフィルタの状態を確認し解除
  If .AutoFilterMode Then .AutoFilterMode = False
 'C列の値をキーワードでフィルタ
  .Range("A1").AutoFilter Field:=3, _
        Criteria1:="*" & keyword & "*"
 'フィルタ結果(見えているセル範囲)をコピー貼り付け(書式を含む)
  .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
    Worksheets("転記").Range("A4")
 'フィルタモードを解除
  .AutoFilterMode = False
 End With
End Sub
    • good
    • 0
この回答へのお礼

ありがとうございます。
やりたいとおりに、なりました。すごいです、最初は何列もの中から検索しようとして、方向を見失ていました。
素人はだめですね、1か月くらいやってました。
エクセルも満足に動かせないのに無理でした。
本当に、ありがとうございました。

お礼日時:2021/05/04 07:12

こんばんは、


>A列作業日のところを1か月であれば作動しますが、
数か月分となるとエラーが発生します。
どのようにして数か月にしているのかな?

不思議なところ、エラーがちらほら、、、あるけれど
取り敢えず
A1セルが空白の時に発生する可能性を回避して

'項目数のカウント
z = 1
Do While Ws2.Cells(1, z).Value <> ""
z = z + 1
Loop
z = z - 1 ’A1が空白だと0になる。
をやめて

Z = Ws2.Cells(1, Columns.Count).End(xlToLeft).Column

とするといかがでしょう。
    • good
    • 0
この回答へのお礼

ありがとうございます。
A列には空白セルはありません。どのようにして数か月にしているのかな?
入力シートがあり。基本的に毎日の作業内容を15行程度打ち込みます、それをデータシートへ転記しています。
空白セルが発生する列もあります、絶対空白セルが発生しない列はA列、C列です。ご提案早速トライしてみます。

お礼日時:2021/05/03 23:49

>VBは経験ありませんので無理かと思います。



エラーになって黄色くなっている際にコードの y , i にマウスのカーソルを近づけるだけの事ですよ?
憶測ですが行・列どちらかが範囲を超えてそうな気がします。
    • good
    • 0
この回答へのお礼

ありがとうございます。
Ws1.Cells(x, i).Value = Ws2.Cells(y, i).Value y の値がy=157で範囲を超えていました、Dim x, y, z As Long 変数の書き方がわかりません、最終的には5000行を超えると思います。ほかに方法があればご指導ください。

お礼日時:2021/05/03 21:12

>word = word & Ws2.Cells(y, i)  この部分がエラーになります



エラーで黄色く色が出ているのなら、
・エラーの内容
について情報として提示は必要ですが、カーソルを変数:y,i に合わせた時『 y = ?, i = ??』と出る場合があります。
その値が実際存在している値であるのかを確認しましょう。
仮に存在しない値であればどうしてそうなるのか考えてみましょう。
    • good
    • 0
この回答へのお礼

ありがとうございます。エラーは黄色く出るだけでメッセジは出ません。
VBは経験ありませんので無理かと思います。

お礼日時:2021/05/03 18:40

直接な回答ではありません。



Dim Ws1, Ws2 As Worksheet
Dim x, y, z As Long

のような書き方は

Dim Ws1 As Valiant, Ws2 As Worksheet
Dim x As Valiant, y As Valiant, z As Long

と同じですが意図と合っていますか?
先の書き方はVisualBasicでは出来ますがVBAでは出来ない方法です。
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

gooドクター

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング