VBA 別のシートから文字列参照して全て表示

質問

ExcelのVBAでSheet1のA3に5文字の文字列(大文字、小文字を区別しない)を入力してSheet２のC列にあるA3の文字列から始まるデータ(10文字以上)をすべてを参照してSheet2のD列を含めSheet1のA5,B5から下にすべて表示させる。
宜しくお願い致します。

Sub macro1()

Dim V2 As Variant

V1 = Sheets("sheet1").Cell("A3").Value '文字列を取得
V2 = Application.InStr(Sheets("sheet2").Range("C:C"), V1) '検索するテーブルでC列の文字列を探す
'みつけたら、その行、無かったら、エラーのコードが変数に入る
If IsError(V2) Then
'テーブルに無かったらなにもしない
Else
str0 = Worksheets("Sheet2").Cells(V2, 7).Value
str1 = Worksheets("Sheet2").Cells(V2, 8).Value
str2 = Worksheets("Sheet2").Cells(V2, 9).Value
Worksheets("sheet1").Cells(i, 2).Value = str0
Worksheets("sheet1").Cells(i, 3).Value = str1
Worksheets("sheet1").Cells(i, 4).Value = str2
End If

End Sub

回答No.6

kkkkkm · ベストアンサー

C列で見つかればC,D列をSheet1のA5,B5から下にすべて表示
と
Sheet2のB列にあるデータ(C列のデータに同期したデータ)をSheet1のB列に同じ様に表示する

B列が重複してますので、とりあえずSheet2のB列のデータ(C列のデータに同期したデータ)をSheet1のC列に表示します。

一部訂正：
A3が空白の時に変な結果が出るので空白の時は実行しないようにしました。
また、最初にA5:C5以下を消してから実行するようにしました。

> 例えば(abcde)と入力してみたのですがabcdeから始まる文字列ではなくすべてのデータが表示されました。

こちらでそのような結果がでないので原因がわかりませんから

Debug.Print "A3="; SData; ; " : 位置="; VRet; " : 対象="; CStr(c.Value)
でイミディエイトウィンドウにそれぞれの値が表示されるようにしてます。それでそれぞれがどうなっているか確認してみてください。

Sub Test2()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim SData As String, i As Long, VRet As Variant
Dim c As Range, LastRow As Long

Set Ws1 = Sheets("Sheet1")
Set Ws2 = Sheets("Sheet2")

SData = CStr(Ws1.Range("A3").Value)
If SData = "" Then Exit Sub
i = 5
LastRow = Ws1.Cells(Rows.Count, "A").End(xlUp).Row
If LastRow < i Then
LastRow = i
End If
Ws1.Range(Ws1.Cells(i, "A"), Ws1.Cells(LastRow, "C")).ClearContents
With Ws2
For Each c In .Range(.Cells(1, "C"), .Cells(Rows.Count, "C").End(xlUp))
VRet = InStr(1, CStr(c.Value), SData, vbTextCompare)
Debug.Print "A3="; SData; ; " : 位置="; VRet; " : 対象="; CStr(c.Value)
If VRet = 1 And Len(c.Value) >= 10 Then
Ws1.Cells(i, "A").Resize(1, 2).Value = c.Resize(1, 2).Value
'とりあえずSheet2のB列のデータ(C列のデータに同期したデータ)をSheet1のC列に
Ws1.Cells(i, "C").Value = .Cells(c.Row, "B").Value
i = i + 1
End If
Next
End With
End Sub

回答No.5

Chiquilin

コードがデタラメ過ぎて何が何やら……
AdvancedFilterで抽出すればいいのでは？

回答No.4

SI299792

最初、見たことない、こんな命令あるのか、と思ってやってみたら、エラーになりました。
オートフィルターを使う方法もあります。

Option Explicit
'
Sub Macro1()
　　Dim I As Worksheet
　　Dim REnd As Long
'
　　Sheets("Sheet1").Select
　　Set I = Sheets("Sheet2")
　　I.AutoFilterMode = False
　　REnd = I.Cells(Rows.Count, "C").End(xlUp).Row
　　Application.ScreenUpdating = False
　　Range("A5:B" & Rows.Count).ClearContents
　　I.Range("C2:D" & REnd).AutoFilter 1, [A3] & "*"
　　I.Range("C3:D" & REnd).Copy [A5]
　　I.AutoFilterMode = False
End Sub

回答No.3

kkkkkm

> 文字の文字列(大文字、小文字を区別しない)

これがA3の文字列が大文字でも小文字でも検索先(Sheet２のC列)では大文字小文字を区別しないでしたら

文字列を含む場合は
If VRet > 0 And Len(c.Value) >= 10 Then

Sub Test1()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim SData As String, i As Long, VRet As Variant
Dim c As Range

Set Ws1 = Sheets("Sheet1")
Set Ws2 = Sheets("Sheet2")
SData = CStr(Ws1.Range("A3").Value)
i = 5
With Ws2
For Each c In .Range(.Cells(1, "C"), .Cells(Rows.Count, "C").End(xlUp))
VRet = InStr(1, CStr(c.Value), SData, vbTextCompare)
If VRet = 1 And Len(c.Value) >= 10 Then
Ws1.Cells(i, "A").Resize(1, 2).Value = c.Resize(1, 2).Value
i = i + 1
End If
Next
End With
End Sub

補足

ご回答ありがとうございます。

試しに実行してみましたが、例えば(abcde)と入力してみたのですがabcdeから始まる文字列ではなくすべてのデータが表示されました。
大変申し訳ございませんが、再度ご知恵を頂けますと幸いです。
付帯してお知恵を拝借させて頂きたいのですが、Sheet2のB列にあるデータ(C列のデータに同期したデータ)をSheet1のB列に同じ様に表示する事は出来ますか？
何卒宜しくお願い致します。

回答No.2

kkkkkm

No1の補足です。

A3に12345のような数値でも検索する場合

以下に変更してください。

SData = Ws1.Range("A3").Value & "*"
を
SData = CStr(Ws1.Range("A3").Value) & "*"

If c.Value Like SData And Len(c.Value) >= 10 Then
を
If CStr(c.Value) Like SData And Len(c.Value) >= 10 Then

回答No.1

kkkkkm

> A3の文字列から始まるデータ(10文字以上)

始まり10文字以上のデータですよね。
含むでしたら以下に変更してください。

SData = "*" & Ws1.Range("A3").Value & "*"

Sub Test()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim SData As Variant, i As Long
Dim c As Range

Set Ws1 = Sheets("Sheet1")
Set Ws2 = Sheets("Sheet2")
SData = Ws1.Range("A3").Value & "*"
i = 5
With Ws2
For Each c In .Range(.Cells(1, "C"), .Cells(Rows.Count, "C").End(xlUp))
If c.Value Like SData And Len(c.Value) >= 10 Then
Ws1.Cells(i, "A").Resize(1, 2).Value = c.Resize(1, 2).Value
i = i + 1
End If
Next
End With
End Sub