EXCEL VBA: 次の処理のマクロボタン作成

質問

ConvertシートのA列にあるフルパス付きファイル名を
B列から右方向に最大L列までパス区切り文字(\)で分割済みです。
（但し、1行目は見出し行）

列方向（横方向）の分割部分を、横＿縦シートの５行目から行方向（下方向）にそのままの順番で配置換え

テスト目的で以下のコードを考えて、1行分(i=2)は配置換え出来るのを確認しています。

ここから横＿縦シートのどこかにマクロボタンを配置して
クリックすると以下を処理したいです。
１）range（”A5”）以下の書き出し分を削除 > 次の書き出しに備える
２）i=3 として 次の書き出しを行う

イメージとしては、1行分は配置換えして確認して、ボタンクリックで次を表示して確認を繰り返す

ボタンに登録するコードを教えてください。

可能なら、前を表示や処理停止のボタンも作成したいと思っていますのでご指導下さい。

Sub フルパス分割()
Dim tmp As Variant
Dim Ln As Long, i As Long, ii As Long
Dim ws1 As Worksheet, ws3 As Worksheet

Set ws1 = Worksheets("Everything")
Set ws3 = Worksheets("Convert")

Ln = ws1.Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To Ln
ws3.Cells(i, 1) = ws1.Cells(i, 1)
tmp = Split(ws3.Cells(i, 1), "\")

For ii = LBound(tmp) To UBound(tmp)
ws3.Cells(i, ii + 2) = tmp(ii)
Next

Next

End Sub

Sub 並べ替え()

Dim Ln As Long, i As Long
Dim Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim tmp As Variant

Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("横＿縦")

Ln = ws3.Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To Ln
tmp = Split(ws3.Cells(i, 1), "\")
ws3.Range(Cells(i, 2), Cells(i, UBound(tmp) + 2)).Copy
ws4.Cells(i + 3, 1).PasteSpecial Transpose:=True
Stop
Next

End Sub

回答No.14

kkkkkm · ベストアンサー

> Sub 並べ替え(ByVal BkFlg As Boolean) がどこからも呼ばれていないのに気が付きました

Worksheet_Change内で並べ替えしてるので不要です。
'並び替え実行のコード
以下の部分
と
並べ替え(ByVal BkFlg As Boolean)の
'使用列Aのクリアー
以下と比べてください。

並べ替え(ByVal BkFlg As Boolean)のそこの部分をWorksheet_Changeにコピペして多少変更しただけです。

> 旧マクロと「蛇足的おまけの提案」のマクロを1つのxlmsに混在していた状態なので
> コードが見えなくなりました。

現在のファイルをコピーして
コピーしたほうのマクロをすべて消して
「蛇足的おまけの提案」のマクロだけを記載してください。

お礼

kkkkkmさん、

<Worksheet_Change内で並べ替えしてるので不要です。

理屈がやっと判りました。
標準モジュールばかりに目が言ってシートモジュール内の
worksheet_Changeの事が目が行きませんでした。

以下だけシートモジュールに追加して旧コードと同じ表示形式となりました。
'見出し行 (Flacのフルパス)
Range("A4") = "Flacのフルパス名 " & "/ 表示の行番号 = " & i

「蛇足的おまけの提案」のマクロだけを記載したBOOKにSAVEしたので
全体のコードも短くなりました。

＞なにかごちゃごちゃになってておかしかったり遅くなったりしているのではないですか。

ベストアンサーに選択する
動作が重い感じだったのも無くなりました。

お陰様で今回も無事目的が叶いました。
アドバイスありがとうございました。

回答No.13

kkkkkm

> Sub 総行数表示()
>
> '総行数の表示
> ws4.Range("F1") = ws3.Cells(Rows.Count, 1).End(xlUp).Row ーーーーー＞ 変更

このようなコードを示した覚えがありません
もともとNuboChanさんのコードでは
ws4.Range("E1") = "/" & ws3.Cells(Rows.Count, 1).End(xlUp).Row
だったと思いますが、変更まではこれが実行されていたのではないですか。

> '開始行と最終行をセット
> ws4.Range("F1").Value = Ln ーーーーー＞ 変更

こちらだけあるはずです

> そうしたら、最終行を指定()で下記で表示されるはずのA2に何も表示されなくなりました。

最終行を指定()も存在しません。

なにかごちゃごちゃになってておかしかったり遅くなったりしているのではないですか。

お礼

kkkkmさん、お手数をおかけしてすいません。

＞このようなコードを示した覚えがありません

私の旧コードとkkkkmさんの修正コードが混在するような状況と成っていたので
F1を使うコードは、取り下げて最初のE1を使いコードに戻して
私の旧コード（使用しなくなったがそのまま残されていたコード）を削除しました。

こうしないと、検索でコードを探してやり取りする場合
今回のように混乱が生じる原因となるからです。

これで、良いかなと思ったところで
Sub 並べ替え(ByVal BkFlg As Boolean) がどこからも呼ばれていないのに気が付きました。
このマクロはもう必要なくなったのでしょうか ？

旧マクロと「蛇足的おまけの提案」のマクロを1つのxlmsに混在していた状態なので
コードが見えなくなりました。
全くの混乱状態です。

以下が精算後のマクロコードですが、確認をお願いします。

（長文となり「お礼」と「補足する」の2箇所に分かれています。）

Option Explicit
Public Const F_ROW As Long = 2

Sub EventsON()
Application.EnableEvents = True
End Sub

'Convertシート作成
Sub フルパス分割()
Dim tmp As Variant
Dim Ln As Long, i As Long, ii As Long
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet

Set ws1 = Worksheets("Everything")
Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("横＿縦")

Ln = ws3.Cells(Rows.Count, 1).End(xlUp).Row

For i = F_ROW To Ln
ws3.Cells(i, 1) = ws1.Cells(i, 1)
tmp = Split(ws3.Cells(i, 1), "\")

For ii = LBound(tmp) To UBound(tmp)
ws3.Cells(i, ii + 2) = tmp(ii)
Next
Next

'開始行と最終行をセット
ws4.Range("D1").Value = F_ROW
ws4.Range("E1").Value = Ln

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

End Sub

Sub 次を表示()
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦")

If ws4.Range("D1").Value >= ws4.Range("E1").Value Then
MsgBox "パスを表示する行番号が最大値を超えました。" & _
"もうDATAは存在しません。"
Exit Sub
End If
ws4.Range("D1").Value = ws4.Range("D1").Value + 1
Set ws4 = Nothing
End Sub

Sub 前を表示()
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦")

If ws4.Range("D1").Value <= F_ROW Then
MsgBox "パスを表示する行番号が最小値に達しました。" & _
"これ以下のDATAは存在しません。"
Exit Sub
End If
ws4.Range("D1").Value = ws4.Range("D1").Value - 1
Set ws4 = Nothing
End Sub

Sub 並べ替え(ByVal BkFlg As Boolean)
Dim si As Long
Dim Ln As Long

Dim ws3 As Worksheet
Set ws3 = Worksheets("Convert")
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦")

Ln = ws3.Cells(Rows.Count, 1).End(xlUp).Row

si = ws4.Range("D1")

If BkFlg = True Then
si = si - 1
If si < 2 Then
MsgBox "パスを表示する行番号が最小値に達しました。" & _
"これ以下のDATAは存在しません。"
End
Else
End If
Else
If si = 0 Then
si = 2
Else
si = si + 1
End If

If si > Ln Then
MsgBox "パスを表示する行番号が最大値を超えました。" & _
"もうDATAは存在しません。"
si = Ln
Exit Sub
Else
End If
End If
'MsgBox "現在の行番号 = " & si

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

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

'並び替えのコード
Dim i As Long
Dim tmp As Variant

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

'ファイル名表示
Dim ws2 As Worksheet
Set ws2 = Worksheets("Mp3")

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

補足

'Sub 総行数表示()
' Dim ws3 As Worksheet, ws4 As Worksheet
' Static Ln As Long
' Set ws3 = Worksheets("Convert")
' Set ws4 = Worksheets("横＿縦")
'
' '現在の行数（ターゲット）の表示
' 'ws4.Range("D1") = 2
' '総行数の表示
' ws4.Range("E1") = "/" & ws3.Cells(Rows.Count, 1).End(xlUp).Row
'
'End Sub

'Sub 並び替え_直接指定()
' Dim i As Long
' Dim ws3 As Worksheet, ws4 As Worksheet
' Dim tmp As Variant
'
' Set ws3 = Worksheets("Convert")
' Set ws4 = Worksheets("横＿縦")
'
' 'call 総行数表示()
' 総行数表示
'
' '使用列Aのクリアー
' ws4.Range(ws4.Cells(Rows.Count, 1).End(xlUp), ws4.Cells(5, 1)).ClearContents
'
' '行の直接指定
' i = ws4.Range("D1")
'
' '見出し行（Flacのフルパス）
' Range("A4") = "Flacのフルパス名 " & "/ 表示の行番号 = " & i
'
' tmp = Split(ws3.Cells(i, 1), "\")
' ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2)).Copy
' ws4.Cells(5, 1).PasteSpecial Transpose:=True
'
' 'ファイル名表示
' Dim ws2 As Worksheet
' Set ws2 = Worksheets("Mp3")
'
' ws4.Range("A2") = ws2.Cells(i, 3)
'
'End Sub

Sub 最初を表示()
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦")

ws4.Range("D1").Value = F_ROW
Set ws4 = Nothing
End Sub

Sub 最終を表示()
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦")

ws4.Range("D1").Value = ws4.Range("E1").Value
Set ws4 = Nothing
End Sub

’----------------------
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 i As Long
Dim ws3 As Worksheet
Dim tmp As Variant

Set ws3 = Worksheets("Convert")
'使用列Aのクリアー
Range(Cells(Rows.Count, 1).End(xlUp), Cells(5, 1)).ClearContents

i = Range("D1").Value
tmp = Split(ws3.Cells(i, 1), "\")
ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2)).Copy
Cells(5, 1).PasteSpecial Transpose:=True

Dim ws2 As Worksheet
Set ws2 = Worksheets("Mp3")

Range("A2") = ws2.Cells(i, 3)
Set ws2 = Nothing
Set ws3 = Nothing
'↓イベントの発生を再開します。
Application.EnableEvents = True

End Sub

回答No.12

kkkkkm

一部訂正

buf = ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2))

Valueが抜けてました。
無くてもエラーにはなりませんが、付けるようにしておいた方がいいので。

buf = ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2)).Value

補足

kkkkkmさん、コードの修正ありがとうございます。

以下報告します。

>ws4.Range("E1").Value = "/" & Ln
にはなっていません。

間違いなく、
ws4.Range("E1").Value = Ln
です。

是正策で
E1="/"として区別記号のみとして
F1に最終列番号が表示されるにしました。

そのため、E1だったコードをF1に以下の５箇所を変更しました。

Sub 総行数表示()

'総行数の表示
ws4.Range("F1") = ws3.Cells(Rows.Count, 1).End(xlUp).Row ーーーーー＞ 変更

Sub フルパス分割()

'開始行と最終行をセット

ws4.Range("F1").Value = Ln ーーーーー＞ 変更

Sub 次を表示()

If ws4.Range("D1").Value >= ws4.Range("F1").Value Then ーーーーー＞ 変更

Sub 最後を表示()

ws4.Range("D1").Value = ws4.Range("F1").Value ーーーーー＞ 変更

Private Sub Worksheet_Change(ByVal Target As Range)

Range("D1").Value > Range("F1").Value Then ーーーーー＞ 変更

’----------------------

そうしたら、最終行を指定()で下記で表示されるはずのA2に何も表示されなくなりました。
それ以後クリックしてコマンドを実行するとのA2の表示がおかしくなり、
一度直接、D1に数値を指定すると正常になります。
最終行を指定すると又同じ現象がでます。

'ファイル名表示

ws4.Range("A2") = ws2.Cells(i, 3)
’------------------------------
＞コピーで遅いのでしたら

記載せたコードに変更した遅くは感じなくなりました。
（少しタイムラグはありますが問題ない範囲と感じます。）

回答No.11

kkkkkm

> E1のセルの書式＞ユーザー設定＞種類で
> "/"#
> を設定していますが違っていますか？

それであってます。

Sub フルパス分割()
で
ws4.Range("E1").Value = Ln
になっていますか。
ws4.Range("E1").Value = "/" & Ln
にしてたら駄目です。

> ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2)).Copy
> の所で遅くなるようです。

コピーで遅いのでしたら

' ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2)).Copy
' Cells(5, 1).PasteSpecial Transpose:=True
を
Dim buf As Variant
を追加して
buf = ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2))
Cells(5, 1).Resize(UBound(buf, 2), 1).Value = WorksheetFunction.Transpose(buf)
にしてみてください。

回答No.10

kkkkkm

> ws4.Range("D1").Value = ws4.Range("E1").Value
> でE1が「/242」と数値では無いためと思われます。

/242は表示だけでセルの中身は242の数値だと思いますが。
E1が(書式設定の表示形式で"/"#)になってますか。

> 一度エラーがでたらクリック（例えば、「前を表示」など）の作動がおかしくなります。

Application.EnableEvents = False
でイベント発生停止したあと
Application.EnableEvents = True
までにエラーになると
Worksheet_Changeは動かなくなります。
仕様です。

> これは、高速化できる改善の善余はありますか ？

ちょっとわかりませが

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

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

を入れて画面表示の更新を一時的に停止すれば何か変化があるかもしれません。

Sub EventsON()
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

に変更しておいてください。

また
以下の部分をコメントにして変化があるかを見て
早くなればどこかの書き込みが遅いと思いますから順にコメント外して実行して遅くなるところを見つけてください。

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

i = Range("D1").Value
tmp = Split(ws3.Cells(i, 1), "\")
ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2)).Copy
Cells(5, 1).PasteSpecial Transpose:=True

Dim ws2 As Worksheet
Set ws2 = Worksheets("Mp3")

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

補足

E1のセルの書式＞ユーザー設定＞種類で
"/"#
を設定していますが違っていますか？

＞以下の部分をコメントにして変化があるかを見て
＞早くなればどこかの書き込みが遅いと思いますから順にコメント外して実行して遅くなるところを見つけてください。

ワークシートモジュールにある
「’使用列Aのクリアー」以下を全てをコメントにして作動させると高速化されたので
上から順番にコメントを外していくと
ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2)).Copy
の所で遅くなるようです。

以下の3箇所はアドバイスを受けて修正（コード追加）しました。

↓イベントの発生を停止します。
'↓イベントの発生を再開します。
Sub EventsON()

回答No.9

kkkkkm

訂正です。

D1のデータは数値として扱いたいので(書式設定の表示形式で"/"#)にしてください。
↓
D1ではなくE1です。

お礼

kkkkkmさん、コードをありがとうございます。

＞コードが難解なのでアドバイスすることが難しく申し訳ないですが、新たなコードを参考に回答します。

すいません。
素人のコードなので「なんでー！！」が多く
改造するより新しくコーディネイトした方が早いのは想像できます。

早速、コードを追加してトレースしてみました。
1箇所を除いて、作動的には、問題ないように見えます。

sub 最後を表示()でエラーが出ます。

シートモジュールの
i=Range("D1").value
の部分で、形が一致しません。

Sub 最後を表示()で
ws4.Range("D1").Value = ws4.Range("E1").Value
でE1が「/242」と数値では無いためと思われます。

それと、仕様だと思いますが

一度エラーがでたらクリック（例えば、「前を表示」など）の作動がおかしくなります。
最初に述べられた
「実際のコードでエラーになった場合、
イベント発生停止状態になっていることがありますので、以下を実行してください。」にある
Sub EventsON()を実行すると解決します。

又、ボタンをクリック後に作動が完結して表示が変化するまでの時間が長くなり
3-5秒ほど必要な時があります。
（1秒以内で終わる場合もあります。）

これは、高速化できる改善の善余はありますか ？

回答No.8

kkkkkm

> 最終的には①の数値がA4の数値に合わせたいのですが

Sub 並べ替え(ByVal BkFlg As Boolean)
の中でD1を書き替えていないためにあわなくなっていると思います。

コードが難解なのでアドバイスすることが難しく申し訳ないですが、新たなコードを参考に回答します。

実際のコードでエラーになった場合、イベント発生停止状態になっていることがありますので、以下を実行してください。
Sub EventsON()
Application.EnableEvents = True
End Sub

ここから実際のコードと説明です
D1のデータは数値として扱いたいので(書式設定の表示形式で"/"#)にしてください。

色んな所で最初の行の2が出てくるので変更する時に一か所の変更で済むようにグローバル定数F_ROWに2をセットします。
Public Const F_ROW As Long = 2
↑標準モジュールの一番上に記載してください

3)のマクロに
Sub 次を表示()
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦")

If ws4.Range("D1").Value >= ws4.Range("E1").Value Then
MsgBox "パスを表示する行番号が最大値を超えました。" & _
"もうDATAは存在しません。"
Exit Sub
End If
ws4.Range("D1").Value = ws4.Range("D1").Value + 1
Set ws4 = Nothing
End Sub

2)のマクロに
Sub 前を表示()
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦")

If ws4.Range("D1").Value <= F_ROW Then
MsgBox "パスを表示する行番号が最小値に達しました。" & _
"これ以下のDATAは存在しません。"
Exit Sub
End If
ws4.Range("D1").Value = ws4.Range("D1").Value - 1
Set ws4 = Nothing
End Sub

4)のマクロに
Sub 最後を表示()
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦")

ws4.Range("D1").Value = ws4.Range("E1").Value
Set ws4 = Nothing
End Sub

1)のマクロに
Sub 最初を表示()
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦")

ws4.Range("D1").Value = F_ROW
Set ws4 = Nothing
End Sub

一番最初に実行するマクロだと思います
このコードを実行したときに最初の行(2行目)のデータが並び替えられて使用列Aに表示されます。
Sub フルパス分割()
Dim tmp As Variant
Dim Ln As Long, i As Long, ii As Long
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet

Set ws1 = Worksheets("Everything")
Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("横＿縦")

Ln = ws1.Cells(Rows.Count, 1).End(xlUp).Row

For i = F_ROW To Ln
ws3.Cells(i, 1) = ws1.Cells(i, 1)
tmp = Split(ws3.Cells(i, 1), "\")

For ii = LBound(tmp) To UBound(tmp)
ws3.Cells(i, ii + 2) = tmp(ii)
Next
Next
'開始行と最終行をセット
ws4.Range("D1").Value = F_ROW
ws4.Range("E1").Value = Ln

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

End Sub

横＿縦のシートモジュールに
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 i As Long
Dim ws3 As Worksheet
Dim tmp As Variant

Set ws3 = Worksheets("Convert")
'使用列Aのクリアー
Range(Cells(Rows.Count, 1).End(xlUp), Cells(5, 1)).ClearContents

i = Range("D1").Value
tmp = Split(ws3.Cells(i, 1), "\")
ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2)).Copy
Cells(5, 1).PasteSpecial Transpose:=True

Dim ws2 As Worksheet
Set ws2 = Worksheets("Mp3")

Range("A2") = ws2.Cells(i, 3)
Set ws2 = Nothing
Set ws3 = Nothing
'↓イベントの発生を再開します。
Application.EnableEvents = True

End Sub

回答No.7

kkkkkm

> 実際、既に 「蛇足的おまけの提案」の方も手を付けていますが
> Static宣言で各Subプロシージャ間でコードが実行されている間は変数の値が保持されるはずが
> 旨くいかない状況です。

siの代わりにセルに値を保持するのでStatic変数はいらないです。

D2に現在のデータの先頭からの位置となっている場合
D2に直接数値を入れてデータの並び替えを実行するには
横＿縦シートの
Private Sub Worksheet_Change(ByVal Target As Range)

End Sub
上記のイベントで並び替えを実行するようにしておけば、各ボタンのイベントではD2に値を代入するだけ(最大値越えなどの処理は必要です)のコードですむと思います。

> ＞使用列Aのクリアー
> ＞'並び替えのコード
> ＞Dim i As Long
>
> この３つの意味が判りません。

使用列Aのクリアー
'並び替えのコード
Dim i As Long
後略

です。以降のコードは元のコードのままでです。

> お勧めとしての”クリアした方が良いのでは無いですか

こちらです。
その前に記載の変更点を変更したうえで並び替えのコードの前にクリアです。

Sub 次を表示()
や
Sub 前を表示()
での
使用列Aのクリアー
は不要になります。

>
> MsgBox "パスを表示する行番号が最大値を超えました。" & _
> "もうDATAは存在しません。"
> si = Ln
> Exit Sub
> End

のEndはいらないです。

お礼

kkkkkmさん、アドバイスを受けてコードを修正して最初のコードは完成しました。

「蛇足的おまけの提案」の方が使い勝手が良いのでそちらに取り掛かりました。
常用するのは「蛇足的おまけの提案」のコードの方なので
最初のコードは、完成したにさせて下さい。

「蛇足的おまけの提案」のコードを新規に作成するのではなく
最初のコードの一部修正（追加、削除）で何とか個人的には80％ほどは作成できたかな？
で現在下記のコードに至っています。

（一度でコードも添付したかったのですが「投稿の文字数制限（4000）に至るので
補足の方と2つに分ける形式となります。すいません。）」

以下の参照図中の①、②、③、④、⑤にそれぞれマクロを指定

参考画像
https://imgur.com/NzrETEv

ごちゃごちゃした見にくいコードですがアドバイスをお願いします。

個人的には、②、③、④、⑤をクリックした場合
最終的には①の数値がA4の数値に合わせたいのですが
D2が変わった時点で又数値が変わるのでマクロが自動起動する事になり
収拾がつかない状態に至りそうで数値を揃えられていません。

「D2が変わった時点で又数値が変わるのでマクロが自動起動する」為に
縦＿横シートモジュールに以下を新規作成
（D1に直接、呼び出す行数を直接指定して並び替えできるように）

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Address = Range("D1").Address Then
Call 並び替え_直接指定
End If
End Sub
’--

Sub 次を表示()
Call 並べ替え(False)
End Sub

Sub 前を表示()
Call 並べ替え(True)
End Sub

Sub 並べ替え(ByVal BkFlg As Boolean)
Dim si As Long
Dim Ln As Long

Dim ws3 As Worksheet
Set ws3 = Worksheets("Convert")
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦")

Ln = ws3.Cells(Rows.Count, 1).End(xlUp).Row

si = ws4.Range("D1")

If BkFlg = True Then
si = si - 1
If si < 2 Then
MsgBox "パスを表示する行番号が最小値に達しました。" & _
"これ以下のDATAは存在しません。"
End
Else
End If
Else
If si = 0 Then
si = 2
Else
si = si + 1
End If

If si > Ln Then
MsgBox "パスを表示する行番号が最大値を超えました。" & _
"もうDATAは存在しません。"
si = Ln
Exit Sub
Else
End If
End If
'MsgBox "現在の行番号 = " & si

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

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

'並び替えのコード
Dim i As Long
Dim tmp As Variant

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

'ファイル名表示
Dim ws2 As Worksheet
Set ws2 = Worksheets("Mp3")

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

End Sub

補足

Sub 総行数表示()
Dim ws3 As Worksheet, ws4 As Worksheet
Static Ln As Long
Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("横＿縦")

'現在の行数（ターゲット）の表示
'ws4.Range("D1") = 2
'総行数の表示
ws4.Range("E1") = "/" & ws3.Cells(Rows.Count, 1).End(xlUp).Row

End Sub

Sub 並び替え_直接指定()
Dim i As Long
Dim ws3 As Worksheet, ws4 As Worksheet
Dim tmp As Variant

Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("横＿縦")

'call 総行数表示()
総行数表示

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

'行の直接指定
i = ws4.Range("D1")

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

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

'ファイル名表示
Dim ws2 As Worksheet
Set ws2 = Worksheets("Mp3")

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

End Sub
Sub 最小行の指定()
Dim i As Long
Dim ws3 As Worksheet, ws4 As Worksheet
Dim tmp As Variant

Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("横＿縦")

'call 総行数表示()
総行数表示

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

'最小行を直接指定
i = 2

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

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

'ファイル名表示
Dim ws2 As Worksheet
Set ws2 = Worksheets("Mp3")

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

End Sub

Sub 最終行の指定()
Dim i As Long
Dim ws3 As Worksheet, ws4 As Worksheet
Dim tmp As Variant

Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("横＿縦")

'call 総行数表示()
総行数表示

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

'最終行を直接指定
i = ws3.Cells(Rows.Count, 1).End(xlUp).Row

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

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

'ファイル名表示
Dim ws2 As Worksheet
Set ws2 = Worksheets("Mp3")

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

End Sub

回答No.6

kkkkkm

すみません
使用列Aのクリアー()
が最初の一回だけだと勘違いしてました。

Sub フルパス分割()
の最後に
End
を入れておいてください。
新規の時にsiを初期化しないと以前のsiの値が残ってますので。

' Static Ln As Long
は
Dim Ln As Long
でいいです。

' If si = 1 Then
' si = 2
は、siの初期値は0ですので
If si = 0 Then
si = 2
にしてください。Convertの2行目からだと思いますので。

あと、最大値最小値を超えたときに先にデータクリアされるのでうーん…な感じです。

If BkFlg = True Then
si = si - 1
If si < 2 Then
MsgBox "パスを表示する行番号が最小値に達しました。" & _
"これ以下のDATAは存在しません。"
si = 2
Exit Sub
' End

略

If si > Ln Then
MsgBox "パスを表示する行番号が最大値を超えました。" & _
"もうDATAは存在しません。"
si = Ln
Exit Sub
' End
Else

Endを入れてると最大値を超えたときにsiが0になりますから、最初のデータから始めることになります。
そのままの位置を保持しておく場合は、上記のようにEndなしのExit Subで抜けてください。

で、'並び替えのコードの前にクリアするのはいかがでしょう。

使用列Aのクリアー
'並び替えのコード
Dim i As Long

お礼

kkkkkmさん、コードの修正 ありがとうございます。

＞使用列Aのクリアー()
＞が最初の一回だけだと勘違いしてました。

それぞれのパス（各1行分）の単独の構造を見たいので毎回、クリアーしています。
列毎に分割した場合、全体をを見るには右方向にカーソルで移動しながらでないと見えないので
下方向の分割の方がカーソルの移動もなく見やすくなります。

以下、修正コードを考慮してコードを変更しました。
（完成形に近づいて、他に考慮すべき事が無いようなら
「蛇足的おまけの提案」のコードの方を追いかけてみます。
実際、既に 「蛇足的おまけの提案」の方も手を付けていますが
Static宣言で各Subプロシージャ間でコードが実行されている間は変数の値が保持されるはずが
旨くいかない状況です。

見せられるコードが出来たら、別トピを立ち上げて改めて質問する予定です。

’-----------------------------------------

最後に記載されている以下の内容ですが、理解が追いついていません。

＞で、'並び替えのコードの前にクリアするのはいかがでしょう。

「いかがでしょう 」 は、
否定的な疑問がある ”クリアするのは如何なものか”の意味なのか ？
又は、
お勧めとしての”クリアした方が良いのでは無いですか"との意味なのか？
判断が付きません。

＞使用列Aのクリアー
＞'並び替えのコード
＞Dim i As Long

この３つの意味が判りません。
Dim i As Long の後にコードは他に無いのでしょうか ？

’-------------------------------

Sub 使用列Aのクリアー()
Dim ws4 As Worksheet, ws3 As Worksheet
Dim Ln As Long
Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("横＿縦")

Ln = ws3.Cells(Rows.Count, 1).End(xlUp).Row
ws4.Range(ws4.Cells(Rows.Count, 1).End(xlUp), ws4.Cells(5, 1)).ClearContents
End Sub

Sub 次を表示()
使用列Aのクリアー
Call 並べ替え(False)
End Sub

Sub 前を表示()
使用列Aのクリアー
Call 並べ替え(True)
End Sub

Sub 並べ替え(ByVal BkFlg As Boolean)
Static si As Long
Dim Ln As Long

Dim ws3 As Worksheet
Set ws3 = Worksheets("Convert")

Ln = ws3.Cells(Rows.Count, 1).End(xlUp).Row

If BkFlg = True Then
si = si - 1
If si < 2 Then
MsgBox "パスを表示する行番号が最小値に達しました。" & _
"これ以下のDATAは存在しません。"
End
Else
End If
Else
If si = 0 Then
si = 2
Else
si = si + 1
End If

If si > Ln Then
MsgBox "パスを表示する行番号が最大値を超えました。" & _
"もうDATAは存在しません。"
si = Ln
Exit Sub
End
Else
End If
End If
MsgBox "現在の行番号 = " & si

'並び替えのコード
Dim i As Long
Dim ws4 As Worksheet
Dim tmp As Variant

Set ws4 = Worksheets("横＿縦")
i = si
tmp = Split(ws3.Cells(i, 1), "\")
ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2)).Copy
ws4.Cells(5, 1).PasteSpecial Transpose:=True

End Sub

回答No.5

kkkkkm

訂正です。

(初期設定で"/"#)
↓
(書式設定の表示形式で"/"#)

回答No.4

kkkkkm

もとの
Sub 並べ替え()
プロシージャ部分は、同じ名前があると混乱のもとになりますのでコメントにしておいてください。

> ＞0に戻したいときに
> ＞いずれかのプロシージャのコードの中に
> ＞End
> ＞と入れておく必要があります。
>
> この意味はよく判りませんでした。

並び替えを行った最後が
siが10で、その後で
クリアー()の後でも、再度並べ替え()を行うと
siは10のまま始まるので(これがブックを閉じない限り延々と加算されますなのです)
クリアー()でsiを初期状態に戻したい場合には

Sub 使用列Aのクリアー()
Dim ws4 As Worksheet
Set ws4 = Worksheets("横＿縦")
ws4.Range(ws4.Cells(Rows.Count, 1).End(xlUp), ws4.Cells(5, 1)).ClearContents
End '←ここに入れてください。
End Sub

> 行に書き出される結果が、先の行問題と同じで旨く処理されていません。

いつも結果の書き出しは5行目からだと思いますから
ws4.Cells(i + 3, 1).PasteSpecial Transpose:=True
は
ws4.Cells(5, 1).PasteSpecial Transpose:=True
でいいのではないでしょうか。

あと
If BkFlg = True Then
si = si - 1
Else
si = si + 1
End If
の部分ですが、データ最大行よりオーバーしたりデータの最小行より小さくなった時に加減算しない処理はしていませんから必要な場合入れておいてください。

ここから添付画像付き蛇足的おまけです。
Staic使わずに実行しているデータの先頭からの位置をどこかのセルに入れておいてそれをもとに前を表示のパターンで
D2に現在のデータの先頭からの位置、E2に全データ数(初期設定で"/"#)
画像で三角作って
右が次を表示
左が前を表示
右の先頭直線付き黒三角が最後のデータ
左の先頭直線付き黒三角が先頭のデータ
それぞれマクロ登録です。
D2に直接数値を入れられるので順番以外で好きなデータの並び替えができます。
おまけですのでさらっとながしてください。

お礼

kkkkkmさんへ、

解説及びコードの修正点のアドバイスありがとうございます。

以下のようにコード修正してみました。

１）Staticの使い方（記載する位置）がよく分からないので
エラー＆トライの繰り返しで適当に記入しているのでおかしな位置に記載していると思います。
（同じコードが複数回出てくるなどおかしな箇所のオンパレード状態です。）

おかしな点指摘下さい。

２）最初の「次を表示()」でターゲット行がB1＝見出し行（1行目）になります。
これを防止するため以下のような苦肉の策で防止しています。
If si = 1 Then
si = 2
Else
si = si + 1
End If

「前を表示()」では、並び替え()の方で1行目なら処理しないで終了するようにしました。

処理列が超えることが無いように処理を追加していますが、実DATAでは試していませんので
おかしなコードかも知れません。

蛇足的おまけの提案ですが、非常に有効なアイデアなので少し頑張ってみます。

Sub 使用列Aのクリアー()
Dim ws4 As Worksheet, ws3 As Worksheet
Static Ln As Long
Set ws3 = Worksheets("Convert")
Set ws4 = Worksheets("横＿縦")

Ln = ws3.Cells(Rows.Count, 1).End(xlUp).Row
ws4.Range(ws4.Cells(Rows.Count, 1).End(xlUp), ws4.Cells(5, 1)).ClearContents
End Sub

Sub 次を表示()
使用列Aのクリアー
Call 並べ替え(False)
End Sub

Sub 前を表示()
使用列Aのクリアー
Call 並べ替え(True)
End Sub

Sub 並べ替え(ByVal BkFlg As Boolean)
Static si As Long
Static Ln As Long

Dim ws3 As Worksheet
Set ws3 = Worksheets("Convert")

Ln = ws3.Cells(Rows.Count, 1).End(xlUp).Row

If BkFlg = True Then
si = si - 1
If si = 1 Then
MsgBox "パスを表示する行番号が最小値に達しました。" & _
"これ以下のDATAは存在しません。"
End
Else
End If
Else
If si = 1 Then
si = 2
Else
si = si + 1
End If

If si > Ln Then
MsgBox "パスを表示する行番号が最大値を超えました。" & _
"もうDATAは存在しません。"
End
Else
End If
End If
MsgBox "現在の行番号 = " & si

'並び替えのコード
Dim i As Long
Dim ws4 As Worksheet
Dim tmp As Variant

Set ws4 = Worksheets("横＿縦")
i = si
tmp = Split(ws3.Cells(i, 1), "\")
ws3.Range(ws3.Cells(i, 2), ws3.Cells(i, UBound(tmp) + 2)).Copy
ws4.Cells(5, 1).PasteSpecial Transpose:=True

End Sub