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

質問

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

回答No.7

eden3616 · ベストアンサー

遅くなりました。

修正、最適化を行った最終のコードを最後に記載しております。

現状において、下記の不明な点がありますので、併せてご確認ください。

■データパターンの出力順番について

(1)元データエリアA,B　→ パターン３
(2)並べ替えエリアE1,J150　→　パターン１
(3)タブ貼り付けエリアN1:T150　→　パターン２

とのことですので
「パターン１、２、３」の順番で区切り記号「******」により出力するということでしょうか？

過去質問を読み返したところ

>ただ、NTデータがBCの前になってしまっていたのでコメントをたよりに入れかえました。

と記述されており、ご提示されているコードからも「パターン１、３、２」の順になっているようですが。
現在は「パターン１、３、２」の順でコードを記述しておりますので、ご確認の上修正願います。

■パターン３について

いままでB,Cで処理を行ってきましたが、A,Bに変更いたしました。

変更される場合はコード内の「'(1)A,B列をタブ区切りでテキストデータへ出力」において
「"A"」、「"B"」の箇所を変更してください。

今までB,Cで行っていたときですが、1行目から「B列の最終行」までの範囲で、
「B列が空白以外」であれば「B列とC列をタブで結合して出力」しておりました。

今回、A,B列の最終行のうち、最終行が多い方をデータ範囲の最終行として選定し、
A,B列を結合したものが空白以外であれば、テキストデータとして出力しています。

■データについて

すでにご覧いただいたかと思いますが、ヒントとしてプロフィールを再度ご確認願います。

■VBAコード

Sub action()
'型宣言
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, dpath As String '◆
Dim fcnt As Long, r_max As Long
Dim i As Long, j As Long '★
Dim srt As String, word As String '★
Dim retu_s As Variant, retu2_s As Variant '★
Dim myRng As Range '★
Dim ngs As Variant, ng As Variant '★
Dim objFileSys As Object, objTS As Object '★

'ファイルの出力先
'dpath = "H:\■DATA\DATAB"
dpath = ThisWorkbook.Path

'データの範囲、取得列の指定
st = "E1"
ed = "O150"
Set myRng = Range("E1:K150") '★
srt = "E,M,F,G,L,N,O" '★

'セルアドレスより各行列番号を取得
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
If Dir(dpath, vbDirectory) = "" Then
MsgBox "パスが不正です" & vbCrLf & vbCrLf & dpath '◆
Exit Sub
End If
tpath = dpath & "\" & fname & ".txt"
Do Until Dir(tpath) = ""
fcnt = fcnt + 1
tpath = dpath & "\" & fname & "_" & fcnt & ".txt"
Loop

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

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

'(2)１列に指定した列順で出力（パターン１）
'列方向にループ
retu_s = Split(srt, ",") '★
For Each retu2_s In retu_s '◆
retu = Range(retu2_s & "1").Column '★
'行方向にループ
For gyou = strow To edrow
If Cells(gyou, retu).Text <> "" Then '◆
If Left(Cells(gyou, retu).Text, 1) <> "■" Then '★
objTS.WriteLine Cells(gyou, retu).Text
End If '★
End If
Next gyou
Next '◆

objTS.WriteLine "****************************************************"

'(1)A,B列をタブ区切りでテキストデータへ出力（パターン３）
r_max = WorksheetFunction.Max( _
Range("A" & Rows.Count).End(xlUp).Row, _
Range("B" & Rows.Count).End(xlUp).Row) '★
For i = 1 To r_max '◆
If Range("A" & i).Text & Range("B" & i).Text <> "" Then '◆
objTS.WriteLine Range("A" & i).Text & vbTab & Range("B" & i).Text '◆
End If
Next i

objTS.WriteLine "***************************************************"

'(3)矩形範囲をタブ区切りでテキストデータ出力（パターン２）
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

お礼

いつもながら貴重な時間をさいていただいてありがとうございます。

◆データパターンの出力順番について
パターンについては私も混乱しちゃっているのですが、
最初に並び替え、次に元データエリアの貼り付け、最後に矩形エリアの貼り付けということですので、ご指示のとおりも「パターン１、３、２」の順ですね。

■パターン３について
実は出力フォームは結局同じなのですが、元データのフォームが色々あって、それにあわせて列の関数をその都度はめこんでおりそのフォームごとに集計方法を色々教えていただいていました。
今回一部統一しようとしている最中なのですが、
そのため当初の質問では、データ列がBとC(AはNoが入れてある）のフォームでの方法ですすめていたと思います。
現在もそのフォームも残っているためBCの場合もあり、修正しながら動作させたいと思っています。

■データについて
ちょっと意味が…？

■VBAコード
これで問題なく出力できました。ありがとうございました。
なお、End Subの前に
Application.Dialogs(xlDialogOpen).Show "H:\SDTXT\*.xlsm"
ThisWorkbook.Close False
を入れています。

これをこのBookの所在Passにしたい場合
ThisWorkbook.Pathにすればいいでしょうか。

なおあわせてお聞きしておきたいのですが、前述のとおり元データによる集計方法がいくつかパターンがあるため、それを今回統一フォームにしているのですが、集計方法にあわせて actionや action3、あるいはそれ以外のVBAをボタンをいくつか作ってフォーム毎に選択しています。
集計パターンにルールがあるのでフォームが統一できればたぶんactionの中でもその書き方をすれば可能のような気がしますが、今回はとりあえず既存のものを使い分けたいと思っています。

これをcall等を使ってひとつのボタンにすることは可能でしょうか。
具体的には
A1の文字列の末尾5文字で判定して
「SD411,SD418,SD425」のときはVBA-1を呼び出す
「SD409」のときはVBA-2を呼び出す
「SD426」のときはVBA-3を呼び出す
その他のときはVBA-4を呼び出す

といった具合です。

補足

■データについて
わかりました。