Mp3と一致するflacの行をFINDして表示

質問

質問は、下記の付随質問となります。
https://okwave.jp/qa/q9995375.html

Sheet1,2に音楽ファイルを複数抜き出しています

各シートの１行目は、見出し行が存在します。

sheet1(Everthing)の構成 ---> set w1= sheetes("Everthing")
A列：FullPass w1.A2: K:\ABC\DEF.flac
B列：Passのみ w1.B2: K:\ABC\
C列：ファイル名（*****.flac) w1.C2: DEF.flac
’---------------------
sheet2(Mp3)の構成 ---> set w2= sheetes("Mp3")
A列：FullPass w2.A2: C:\A\GHJ.mp3
B列：Passのみ w2.B2: C:\A\
C列：ファイル名（*****.mp3) w2.C2: GHJ.mp3
’----------------
sheet3(Convert) ---> set w3= sheetes("Convert")
は、ws1をパス記号(￥)で区切って列毎に分割して表示した表です。

A列：FullPass w3.A2: K:\ABC\DEF.flac
（w1のA列をそのままコピー）
B列: 分割1 w3.B2: K：
C列： 分割2 w3.C2: ABC
D列： ファイル名（*****.flac) w3.D2: DEF.flac

パス構造が長い場合は、分割個数が増えて

B列: 分割1
C列： 分割2
D列： 分割3
---（途中省略）----
I列： 分割8
J列： ファイル名（*****.flac)

の場合も存在します。
’---------------------------

同じ２列目でDEF.flacとGHJ.mp3のファイル名（拡張子部分は除く）は同名では有りません（一致していません）が
Ws2.C2と同じファイル名(拡張子部分は除く）を持つファイル名(拡張子部分は除く）がW1のC列のどこかに存在する課程で
sheet7に検索して抜き出したいと思います。

sheet7(flac分割)の構造は、
A2： W2のC列 （検索ワードは、A2の拡張子部を除くファイル名を使用）

A4: ”一致するFlac名 " ＋ 行番号

例えば、
A2:JJJ.mp3 でw1.C24が一致するとすると
24行目が求める回答なので

やりたいのは、
A5以下に行方向にw1の24行目を抜き出すです。

’----------------------------
kkkkkｍさんの前回のアドバイスを受けてi=2の場合を作成してみました
エラー無く処理はできました。

応用が効かないのでsheet7のシートモジュールのコードが見えてきません。
アドバイスをお願いします。

Private Sub Worksheet_Change(ByVal Target As Range)

Sub 同じ値のセルを見つけて横_縦並び替え()
Dim r As Range, FindRow As Integer
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim FileNameOnly As String

Set ws1 = Worksheets("Everything")
Set ws2 = Worksheets("Mp3")
Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("Flac検索")

Dim Ln As Long, i As Long

i = 2 '試験運用 Mp3の２行目を指定
'ファイル名部分のみ抜き出し
FileNameOnly = Left(ws2.Cells(i, 3), InStrRev(ws2.Cells(i, 3), ".") - 1)

'ws1からFind
Set r = ws1.Cells.Find(FileNameOnly)

If r Is Nothing Then
MsgBox "指定のflacが見つかりませんでした。", vbExclamation
End
Else
FindRow = r.Row
End If

ws4.Range("A2") = ws2.Cells(i, 3)

'見出し行 (Flacのフルパス)
Range("A4") = "Flacのフルパス名 " & "/ 表示の行番号 = " & FindRow

'使用列Aのクリアー
ws4.Range(Cells(Rows.Count, 1).End(xlUp), Cells(5, 1)).ClearContents

'横/縦並び替え
Dim tmp As Variant

tmp = Split(ws3.Cells(FindRow, 1), "\")
ws3.Range(ws3.Cells(FindRow, 2), ws3.Cells(FindRow, UBound(tmp) + 2)).Copy
Cells(5, 1).PasteSpecial Transpose:=True
ws4.Range("A5").PasteSpecial Transpose:=True

'Next

End Sub

回答No.6

kkkkkm · ベストアンサー

> ws4は、自分自身であるFlac検索のシートマクロでは必要ないのですが
> 他のシートと間違えないようにあえて記載していますが
> 問題が有るでしょうか？

コード内にws4指定のセルとかないので、記載してコメントにしておけばいいのではないでしょうか。
また、ws4指定でセルを指定するとコードを見ただけではWorksheet_Changeのシートのセルなのかどうか不明になります。

> Set r = ws1.Cells.Find(FileNameOnly)

シート全体を検索してますが

sheet1(Everthing)の構成 ---> set w1= sheetes("Everthing")
A列：FullPass w1.A2: K:\ABC\DEF.flac
B列：Passのみ w1.B2: K:\ABC\
C列：ファイル名（*****.flac) w1.C2: DEF.flac

なのでしたら、C列だけでいいのではないでしょうか。

シート全体だとDEFを探したときにDEF.flacの行より先に
K:\ABCDEF\DDD.flac
があるとDDD.flacの行がヒットすると思います。

それと
拡張子の「.flac」を付けて完全一致にしたほうがいいのではないでしょうか

「ABCDEF.flac」と「DEF.flac」があった場合 「DEF」で検索したら、先に「ABCDEF.flac」があればそちらがヒットします。

Find(FileNameOnly & ".flac",LookIn:=xlValues, LookAt:=xlWhole)

また、引数は指定しておいた方がいいみたいです。
参照：
第98回.Findメソッド（Find,FindNext,FindPrevious）
https://excel-ubara.com/excelvba1/EXCELVBA398.html
引数が保存される注意点の部分

前回、動作が遅いの時に
Application.ScreenUpdating = False
の追加を提案しましたが、現状は存在しないみたいですので
Application.ScreenUpdating = True
は不要です。

補足

kkkkkmさん、アドバイスありがとうございます。

＞コード内にws4指定のセルとかないので、記載してコメントにしておけばいいのではないでしょうか。

コメントにしました。

＞シート全体を検索してますが
＞Set r = ws1.Cells.Find(FileNameOnly)

説明を受けてCellだけでは検索ミスの可能性があるので対象範囲を絞る必要があると納得しました。

「シート全体を検索」をC列だけを検索するように
以下に変更しました。

＞また、引数は指定しておいた方がいいみたいです。

URLの説明を読んで
FINDのパラメーターで必要があると思われるパラメーターを追加しました。

'サーチするmp3のファイル名部分のみ（拡張子は除く）
FileNameOnly = Left(ws2.Cells(i, 3), InStrRev(ws2.Cells(i, 3), ".") - 1)

'Flacの名前(C列)にmp3と同じ部分はあるかサーチ？
'What:= -------- 検索するデータの指定
'LookIn:=xlValues 値
'LookAt:=xlWhole 全てが一致するセルを検索
'Matchcase:= False（規定値) 大文字と小文字を区別しない
'MatchByte:= False (規定値) 半角と全角を区別しない

Set r = ws1.Range("C:C").Find(what:=FileNameOnly & ".flac", LookIn:=xlValues, LookAt:=xlWhole)

＞Application.ScreenUpdating = Trueは不要です。

以下のようにコメントアウトにしました。

If r Is Nothing Then '存在しないなら
MsgBox "指定のflacが見つかりませんでした。", vbExclamation
Application.EnableEvents = True
'Application.ScreenUpdating = True
Exit Sub

'------------------------
Worksheet_Changeの最初の方に「最終行」を見失わないように以下を追加しました。
Range("E1") = ws2.Cells(Rows.Count, 1).End(xlUp).Row

回答No.5

kkkkkm

> 以下の１），２）のws4が同じでなくても問題ないですよね ？

参照するD1があるシートを指定しないと駄目です。

Worksheets("横＿縦")のD1を変更して

Worksheets("Flac検索") を参照してるのでしたら駄目です。

お礼

kkkkkmさん、アドバイスありがとうございます。

旧マクロと今回のマクロが混在する状態だったの
旧マクロの縦＿横シートも削除してFlac検索シートのみにしました。
そして、最初を表示()マクロなどの参照先をFlac検索に書き換え（統一）ました。
（その他、見直しのため改変したコードが数か所発生。）

旨く矢印マクロも作動するようになりました。

以下flac検索シートのマクロですが、変更箇所あればお願いします。

Set ws4 = Worksheets("Flac検索") など
ws4は、自分自身であるFlac検索のシートマクロでは必要ないのですが
他のシートと間違えないようにあえて記載していますが
問題が有るでしょうか？

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> Range("D1").Address Then
Exit Sub
End If

If Range("D1").Value < F_ROW Or _
Range("D1").Value > Range("E1").Value Then
MsgBox "パスを表示する行番号が範囲外です。"
Application.EnableEvents = False
Application.Undo '入力したものを取り消します。
Application.EnableEvents = True
Exit Sub
End If

'↓イベントの発生を停止します。
Application.EnableEvents = False

'並び替え実行のコード
Dim r As Range, FindRow As Integer
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim FileNameOnly As String

Dim i As Long
Dim tmp As Variant

Set ws1 = Worksheets("Everything")
Set ws2 = Worksheets("Mp3")
Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("Flac検索")

'横/縦並び替え,行数指定
i = Range("D1").Value

'サーチするmp3のファイル名部分のみ（拡張子は除く）
FileNameOnly = Left(ws2.Cells(i, 3), InStrRev(ws2.Cells(i, 3), ".") - 1)

'Flacにmp3と同じ部分はあるかサーチ？
Set r = ws1.Cells.Find(FileNameOnly)

If r Is Nothing Then '存在しないなら
MsgBox "指定のflacが見つかりませんでした。", vbExclamation
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
Else
FindRow = r.Row '存在したら、その行数を求める
End If

'mp3のファイル名表示
Range("A2") = ws2.Cells(i, 3)

'見出し行 (Flacのフルパス)
Range("A4") = "Flacのフルパス名 / 表示の行番号 = " & FindRow

'使用列Aのクリアー
Range(Cells(Rows.Count, 1).End(xlUp), Cells(5, 1)).ClearContents

'横/縦並び替え
tmp = Split(ws1.Cells(FindRow, 1), "\")
ws3.Range(ws3.Cells(FindRow, 2), ws3.Cells(FindRow, UBound(tmp) + 2)).Copy

Range("A5").PasteSpecial Transpose:=True

Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing
Set ws4 = Nothing

'↓イベントの発生を再開します。
Application.EnableEvents = True

End Sub

回答No.4

kkkkkm

前回の
Worksheet_Change(
のまま
.Find
にすることによって追加した部分や変更した部分(FindRowなんかの部分です)をあてはめたらいけると思います。

i = 2
は、もとの
i = Range("D1").Value
のままです。
Range("D1").Value
が作業の元になる行の値ですから。

MsgBox "指定のflacが見つかりませんでした。", vbExclamation
のあとに
Application.EnableEvents = True
Application.ScreenUpdating = True
を入れておかないと以後_Changeイベントなどが無効のままです。
End
より
Exit Sub
の方がいと思います。

お礼

アドバイス、感謝します。

アドバイスを受けて
sheet7(Flack変換）のシートモジュールに以下の記載しましたが
旨く機能しません。

D1に直接数値を指定すると
抜き出しは旨く処理できているのですが
'見出し行 (Flacのフルパス)
ws4.Range("A4") = "Flacのフルパス名 / 表示の行番号 = " & FindRow
が表示されずません。

又、
前回作成した、「前を表示」などが機能しません。

以下の１），２）のws4が同じでなくても問題ないですよね ？

’-----------------
Sub 前を表示()
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦") ＜------ １）
’-----------------

Sub Worksheet_Change の

Set ws1 = Worksheets("Everything")
Set ws2 = Worksheets("Mp3")
Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("Flac検索") ＜------------- ２）

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> Range("D1").Address Then
Exit Sub
End If

If Range("D1").Value < F_ROW Or _
Range("D1").Value > Range("E1").Value Then
MsgBox "パスを表示する行番号が範囲外です。"
Application.EnableEvents = False
Application.Undo '入力したものを取り消します。
Application.EnableEvents = True
Exit Sub
End If

'↓イベントの発生を停止します。
Application.EnableEvents = False

'並び替え実行のコード
Dim r As Range, FindRow As Integer
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim FileNameOnly As String

Dim i As Long
Dim tmp As Variant

Set ws1 = Worksheets("Everything")
Set ws2 = Worksheets("Mp3")
Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("Flac検索")

'使用列Aのクリアー
Range(Cells(Rows.Count, 1).End(xlUp), Cells(5, 1)).ClearContents

'横/縦並び替え

i = Range("D1").Value

'サーチするmp3のファイル名部分（拡張子は除く）
FileNameOnly = Left(ws2.Cells(i, 3), InStrRev(ws2.Cells(i, 3), ".") - 1)

'flacのどこかにmp3と同じ部分はあるか？
Set r = ws1.Cells.Find(FileNameOnly)

If r Is Nothing Then '存在しないなら
MsgBox "指定のflacが見つかりませんでした。", vbExclamation
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
Else
FindRow = r.Row '存在したら、その行数を求める
End If

'mp3のファイル名表示
ws4.Range("A2") = ws2.Cells(i, 3)

'見出し行 (Flacのフルパス)
ws4.Range("A4") = "Flacのフルパス名 / 表示の行番号 = " & FindRow

'使用列Aのクリアー
ws4.Range(ws4.Cells(Rows.Count, 1).End(xlUp), ws4.Cells(5, 1)).ClearContents

'横/縦並び替え
tmp = Split(ws1.Cells(FindRow, 1), "\")
ws3.Range(ws3.Cells(FindRow, 2), ws3.Cells(FindRow, UBound(tmp) + 2)).Copy

ws4.Range("A5").PasteSpecial Transpose:=True

Set ws2 = Nothing
Set ws3 = Nothing

'↓イベントの発生を再開します。
Application.EnableEvents = True

End Sub

回答No.3

kkkkkm

sheetes("Mp3")
を上から順番の元にしてやりたいという事でしたら
前回のコードを
i = Range("D1").Value
のまま今のFindを生かすコードに変更すればいいような気もしますが。

補足

＞sheetes("Mp3")
＞を上から順番の元にしてやりたいという事でしたら

希望は、Mp3のソート順が望ましいです。

＞前回のコードを
＞i = Range("D1").Value
＞のまま今のFindを生かすコードに変更すればいいような気もしますが。

んー。
知識が追いつかず、ガッテン「なるほど」と行きません。
もう少し、補足をお願いします。

回答No.2

kkkkkm

sheetes("Everthing")
C列：ファイル名
と
sheetes("Mp3")
C列：ファイル名
でした。

> やりたいのは、
> A5以下に行方向にw1の24行目を抜き出すです。

前回はws3のデータを並び替えしてたと思いますし、質問のコードもws3になってます。

ws3でしたら
Worksheets("Convert")
から一行ずつ取り出して横/縦並び替えしてるのに
Worksheets("Mp3")の方からWorksheets("Everything")探して見つかっても並び替えしたデータと合致しないと思うのですが…。
Worksheets("Convert")のその時の行の一番右の列のデータからWorksheets("Mp3")の方を探した方がいいのではないでしょうか。

ws3.Cells(i, Columns.Count).End(xlToLeft).Column

で右端の列番号が取得できます。

補足

>Worksheets("Convert")のその時の行の一番右の列のデータから
>Worksheets("Mp3")の方を探した方がいいのではないでしょうか。

今回私が考えた「Sub 同じ値のセルを見つけて横_縦並び替え()」は

mp3(ws2)からファイル名（拡張子部を除く）を検索すべきターゲットとして
flac(ws1）から探して見つかったら、その行をFindRowとして
ws1の1行目とConvert(ws3)の1行目は同じなので
FindRowでws3を横/縦並び替えする手順ですが

要点は、Mp3のファイル名（拡張子部分は除く）とConvertの番右の列のデータ＝ファイル名（拡張子を除く）
が一致するのを探しても良いです。

要は、拡張子部を除いてMp3のファイル名と同じファイル名を持つflacがどの行にあるか探して
横/縦変化して表示されれば問題は解決します。

作業上kkkkkmさんの推薦の方法がスマートなコードなら
その方向で考えますがどうでしょうか ？

回答No.1

kkkkkm

sheetes("Convert")
D列： ファイル名
を優先キーにして並び替え

sheetes("Mp3")
C列：ファイル名
を優先キーにして並び替え

したら、両方同じ行は同じファイル名にならないでしょうか。

補足

kkkkkmさん、回答感謝します。

>sheetes("Convert")
>D列： ファイル名
>を優先キーにして並び替え

Convertシートのファイル名のみ列は、行によって不揃いです。
"￥”の数で分割数が違うので例えば”D列”が常にファイル名とはなりません。
L:aaa\bbb\ccc\dddd.flac なら 5番目のF列がファイル名
L:fgh\ggg\hjk.flac なら 4番目のE列がファイル名

分割数の最後、最大列数がファイル名の列数です。