矩形範囲の複数列を縦１列に並べ替えVBA(続)

質問

• ExcelのVBAを使用して、矩形範囲内の複数の列を縦に一列に並べ替えるコードについて教えてください。
• 現在のコードでは、M1からRの範囲のデータをM1-M**/N1-N**/O1-O**のように縦に並べ替えています。
• 縦に並べ替える順序を任意にしたい場合、どの部分を修正すればよいのでしょうか？

回答No.1

eden3616

以前回答させて頂いたものです。
以下の変更箇所を修正してください。

■変更箇所

(1)「'型宣言」内の最後（Dim fcnt As Longの後）に以下を追加

Dim i As Long
Dim srt As String
Dim retu_s As Variant

(2)「'データの範囲～」の最後（ed = "R200"の後）に以下を追加

srt = "M,P,N"

(3)「'列方向にループ」の最初（For retu = stcol To edcol）を削除

(4)(3)で削除した箇所（「'列方向にループ」と「'行方向にループ」の間）に以下を追加

retu_s = Split(srt, ",")
For Each retu2_s In retu_s
retu = Range(retu2_s & "1").Column

(5)「'行方向にループ」の最後（Next retu）を以下に変更
　　（VBA処理的には「列」処理のループ最後）

Next

■補足
(2)で指定した列順に取得して表示します。
M～R列を漏れなく半角カンマ「,」区切りで記述してください。
（上記コードでは提示して頂いたM、P、Nのみ取得されます）

手軽であるため、上記のような仕様にしましたが、
ExcelのソートのようにMPNの順で優先ソートして範囲内全てを書き出す場合は処理を別途考えます。

お礼

ご回答いただけて光栄です。
質問欄のVBAは当初のもので途中修正していただいており、最終的に下記部分訂正して使用しております。全文記述すると長くなりますので修正箇所のみ書きます。
'型宣言に追加
Dim objFileSys As Object, objTS As Object
Dim word As String
Set objFileSys = CreateObject("Scripting.FileSystemObject")

'データの範囲（左上のセルと右下のセル）アドレスを指定
st = "E1"
ed = "J150"
Set myRng = Range("N1:T150")

以下の部分以降を書き換え
Open tpath For Output As #1
'列方向にループ
For retu = stcol To edcol
～
MsgBox tpath & vbCrLf & "に出力しました"
End Sub

下記のように修正→
'/////　テキスト書き出し処理　/////

'テキストファイルを新規作成
Set objTS = objFileSys.CreateTextFile(tpath)

'(1)E～J列を1列にテキストデータへ出力
'列方向にループ
For retu = stcol To edcol
'行方向にループ
For gyou = strow To edrow
If Cells(gyou, stcol).Text <> "" Then
objTS.WriteLine Cells(gyou, retu).Text
End If
Next gyou
Next retu

'区切りをテキストデータへ出力
objTS.WriteLine "****************************************************"

'(3)B,C列をタブ区切りでテキストデータへ出力
For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i, 2).Value <> "" Then
objTS.WriteLine Cells(i, 2).Value & vbTab & Cells(i, 3).Value
End If
Next i

'区切りをテキストデータへ出力
objTS.WriteLine "***************************************************"

'(2)N～T列をタブ区切りでテキストデータへ出力
Dim flag As Integer
For j = 1 To myRng.Rows.Count
word = ""
flag = 0
For i = 1 To myRng.Columns.Count
If myRng.Cells(j, i).Value <> "" Then
flag = flag + 1
End If
word = word & myRng.Cells(j, i).Value
If i < myRng.Columns.Count Then word = word & vbTab
Next i
If flag > 0 And myRng.Cells(j, 1).Value <> "" Then objTS.WriteLine word
Next j

'テキストファイルを閉じる
objTS.Close

MsgBox tpath & vbCrLf & "に出力しました"

End Sub

以上です。うっかり古いままのVBAで質問してしまいました。
今回の趣旨は１列に並べ替える部分(M1～I150)とそれをタブ用に貼り付けるフォーム(N1-T150)のデータがかなりかぶっているためひとつの表にしてしまいたいのですが、貼り付けフォームはそのままの順序にしておくとして、1列並べ替えはその中から、必要な列を抜き出せればいいと思っています。
もちろん現在でもデータのダブリさえ気にしなければ満足できる仕様となっています。

すなわちEからN列までデータ表を作り、最後のタブ貼り付け部分はE1～K150(従来のN1～T150に相当する部分)を対象とし、１列並び替えはM/E/F/N/H/G/I/Lの列を対象にこの順にしようというものです。
こんな感じでご理解いただけますでしょうか。

補足

修正後のVBAでも、上記ご指示の変更で、必要列の抽出が問題なくできました。
色々修正していただいた後のVBAで影響が出るのを心配しましたが不要でした。
ありがとうございました。

なお、関連してですが、後半のタブ書き出しを単独でVBA処理しているのですが、（N～T列のみの抽出で列並び替え等不要）よくわからないためいただいたVBAから、
'/////　テキスト書き出し処理　/////と
'区切り(B列)をテキストデータへ出力
をはずしただけでそのまま運用して出力しています。
不要そうなのを削除したら動かなくなってしまっため、それ以外の記述はそのまま手をつけていませんので
関連のない記述もそのまま残っています。
不要部分を整理できればと思っています。
※単にZ1～AF150を矩形でタプ抽出、テキスト生成のみです。

Sub action2()
'型宣言
Dim st As String, ed As String
Dim stcol As Long, edcol As Long
Dim strow As Long, edrow As Long
Dim retu As Long, gyou As Long
Dim fname As String, tpath As String
Dim fcnt As Long
Dim objFileSys As Object, objTS As Object
Dim word As String
Set objFileSys = CreateObject("Scripting.FileSystemObject")

'データの範囲（左上のセルと右下のセル）アドレスを指定
st = "K1"
ed = "P400"
Set myRng = Range("Z1:AF400")

'セルアドレスより各行列番号を取得
stcol = Range(st).Column
edcol = Range(ed).Column
strow = Range(st).Row
edrow = Range(ed).Row

'セル範囲が選択中の場合
If Selection.Count > 1 Then
stcol = Selection(1).Column
edcol = Selection(Selection.Count).Column
strow = Selection(1).Row
edrow = Selection(Selection.Count).Row
End If

'出力先のファイル名を処理
If Cells(strow, stcol).Text = "" Then
fname = "不明(" & Cells(strow, stcol).Address & ")"
Else
fname = Cells(strow, stcol).Text
End If
ngs = Split("■,\,/,:,*,?,"",<,>,|", ",")
For Each ng In ngs
fname = Replace(fname, ng, "#")
Next
dpath = ThisWorkbook.Path
If Dir(dpath, vbDirectory) = "" Then
Debug.Print "dpath = " & dpath
MsgBox "パスが不正です"
Exit Sub
End If
tpath = dpath & "\" & fname & ".txt"
Do Until Dir(tpath) = ""
fcnt = fcnt + 1
tpath = dpath & "\" & fname & "_" & fcnt & ".txt"
Loop

'/////　テキスト書き出し処理　/////

'テキストファイルを新規作成
Set objTS = objFileSys.CreateTextFile(tpath)

'区切りをテキストデータへ出力
objTS.WriteLine "***************************************************"
'Set myRng = Range("N1:T150")

'(2)N～T列をタブ区切りでテキストデータへ出力
Dim flag As Integer
For j = 1 To myRng.Rows.Count
word = ""
flag = 0
For i = 1 To myRng.Columns.Count
If myRng.Cells(j, i).Value <> "" Then
flag = flag + 1
End If
word = word & myRng.Cells(j, i).Value
If i < myRng.Columns.Count Then word = word & vbTab
Next i
If flag > 0 And myRng.Cells(j, 1).Value <> "" Then objTS.WriteLine word
Next j

'テキストファイルを閉じる
objTS.Close

MsgBox tpath & vbCrLf & "に出力しました"

End Sub