矩形範囲の複数列を縦１列に並べ替えエクセルVBA

データD1～H50にデータがあるとします。

これを
D列データ(1～50行)
E列データ(1～50行)
F列データ(1～50行)
G列データ(1～50行)
H列データ(1～50行)

と縦１列(計250行)に並べ変えたいのですが
次の条件によるVBAを教えていただけますか。

D1にカーソルを置く（アクティブセル）
（または自動的にD1から対象とする※この例ではD1ですが、C1等に変更する場合有り）
I列にはデータがない
51の行にはデータがない
すなわち完全孤立矩形です。
D1～50行の途中に関数式のある空白セル（""による非表示、）がある場合その行は削除
D列1行目のセル名をファイル名としてテキスト（外部ファィル）を作成（同一ファイル名の上書きを回避）

なお、A,B,C列、I列や51行にデータが続いていた場合、一定の範囲を囲ってその部分について同作業をする場合のVBAもあわせてお願いします。
その場合のファイル名は範囲左上のセルが対象。

よろしくお願いします

エクセル2013Pro
Windows7Pro(SP1)

No.5 回答者： eden3616 回答日時： 2014/04/29 13:08

No3の中で以下のように回答させて頂いておりますが分かりにくかったようで申し訳ありません。

上記マクロを実行時にあらかじめセルを範囲選択しておけば範囲選択された範囲のみ出力先のセル以下に出力します。


コードの中で以下の処理をしております

'セル範囲が選択中の場合
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関数でSelection.Count（選択したセルの数）が1より多い場合、つまり複数選択の場合に
選択された範囲の左上のセルを始まりの行、列番号とし
右下のセルを終わりの行、列番号として定数に上書きして処理を行います。

つまり、1つのセルが選択されている状態で実行されれば初期値であるst = "D1"及びed = "H50"が適用され、
複数のセルが選択されている状態で実行されれば範囲選択された範囲を取得するようになります。

実行されてみてお望みの結果にならないようであれば修正いたしますので状況と結果のご提示お願いします。
エラーが出た場合はエラーウィンドウからデバックを選んでいただきましたらVBEが開きますので
該当箇所のコードとエラー内容をご提示お願いします。

この回答へのお礼

お手数をおかけしています。
>あらかじめセルを範囲選択しておけば範囲選択された範囲のみ>出力先のセル以下に出力します。

というのは理解しておりました。
これは基本は範囲を選択しておかなくても、アドレス指定をしておけば、それが自動選択されて作成されるほか、あらかじめ範囲選択しておけばそちらで作成できるという選択肢かと思っていました。（これは便利です）
実際どちらでやってもその通りに出力できました。
またH50については、H50のままだと51行め以上にデータがあっても切り捨てられてしまう。
最大値としてとりあえずH80くらいにしておいたら実際にあるH57までのデータが取り込まれました。したがって最大値にしておけばいいと思っています。（定性的な自動選択の場合）


問題点がいくつかありました。
質問にも書いてあるのですが、D列に空白セルがある場合その「行」を削除するが、削除はそのセルに限定されていた。
書き出しファィルの上書き回避（末尾に_1をつけるとか)がされておらず上書きされてしまう。
ファィル名、これは質問の仕方が悪かったのですが、D1というのは選択範囲の第１セルのつもりでしたので、範囲が変わる場合はこのD1も変わります。すなわち範囲の第１セル（左上）の名称を使う。

以上ですがよろしくお願いします。

お礼日時：2014/04/29 13:53

No.4 回答者： eden3616 回答日時： 2014/04/29 12:00

No2のコードですが、

>D列1行目のセル名をファイル名としてテキスト（外部ファィル）を作成（同一ファイル名の上書きを回避）

おもいっきり無視してました申し訳ありません。
以下のVBAコードと入れ替えて使用してください。

変更点は以下の通りです
(1)セルに出力するわけではないので変数trの設定が不要になりました
(2)デフォルトパスにD1セルのファイル名で出力します。
　（デフォルトパスはエクセルメニューの ツール -> オプション -> 全般タブで設定してあるパスです）

■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 buf As String

'データの範囲（左上のセルと右下のセル）アドレスを指定
st = "D1"
ed = "H50"

'出力先の開始セルアドレスを指定
tr = "D1"
tpath = Application.DefaultFilePath & "\" & Range(tr) & ".txt"

'セルアドレスより各行列番号を取得
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

Open tpath For Output As #1
'列方向にループ
For retu = stcol To edcol
'行方向にループ
For gyou = strow To edrow
If Cells(gyou, retu).Text <> "" Then
Print #1, Cells(gyou, retu).Text
End If
Next gyou
Next retu
Close #1

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

この回答へのお礼

ご多用中ご丁寧なご回答をありがとうございました。
まだ試みていませんが、この中でed = "H50"を設定するようになっていますが、これは可変になるものでしょうか。
例えば、データのD1でShiftを押しEndで右端の列に、そこからshift+Endで右下のセルまでを自動選択する場合、データによって、H50の位置が変化しますが、これだと常に設定セルを終端にしてしまうような気がしました。
それとも最大値としておけば、それ以下の場合はそこまでの範囲が自動的に選択されますでしょうか。

お礼日時：2014/04/29 12:48

No.3 回答者： eden3616 回答日時： 2014/04/29 11:41

VBAでの処理です。

モジュールを作成してほりこんでください。

■設定
範囲を定数として指定できます以下の部分の変数を書き換えてください。
（初期はD1:H50のデータをB1～B250まで出力します）

'データの範囲（左上のセルと右下のセル）アドレスを指定
st = "D1"
ed = "H50"

'出力先の開始セルアドレスを指定
tr = "B1"


■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 trrow As Long, trcol As Long

'データの範囲（左上のセルと右下のセル）アドレスを指定
st = "D1"
ed = "H50"

'出力先の開始セルアドレスを指定
tr = "B1"

'セルアドレスより各行列番号を取得
stcol = Range(st).Column
edcol = Range(ed).Column
trcol = Range(tr).Column
strow = Range(st).Row
edrow = Range(ed).Row
trrow = Range(tr).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

'列方向にループ
For retu = stcol To edcol
'行方向にループ
For gyou = strow To edrow
If Cells(gyou, retu).Text <> "" Then
Cells(trrow, trcol) = Cells(gyou, retu).Text
trrow = trrow + 1
End If
Next gyou
Next retu
End Sub




>なお、A,B,C列、I列や51行にデータが続いていた場合、一定の範囲を囲ってその部分について同作業をする場合のVBAもあわせてお願いします。
その場合のファイル名は範囲左上のセルが対象。

上記マクロを実行時にあらかじめセルを範囲選択しておけば範囲選択された範囲のみ出力先のセル以下に出力します。

No.2 回答者： eden3616 回答日時： 2014/04/29 11:11

VBAより関数のが手っ取り早いとおもいますが。

A列の１～250行に結果を入れる場合

A1に=INDEX($D$1:$H$50,MOD(ROW()-1,50)+1,INT((ROW()+1)/50)+1)を入れて
A250まで数式をフィルハンドルでオートフィルしてください。


以下補足説明＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿

現在の行番号「ROW()で取得」を元にMOD（余りを算出）したり50の倍数値を計算して行、列数を求めていますので
開始行が変わるのであれば、以下の部分の行数を算出しているROW()周辺を増減させて調整してください。

MOD(ROW()-1,50)+1

この回答へのお礼

ありがとうございました。
関数については多少知っているのですが、データシートをWEBから取り込むため毎週多数発生し、例示では50になっていますがシートごとに行数も不定です。
このため各シートに異なる関数を必要行数ごとにCopyする必要があり、またテキストを作成するということでその都度コピペしなければなりません。そこでマクロでいい方法がないかなと考えた訳です。
教えていただいた関数も活用したいと思います。

お礼日時：2014/04/29 11:27

No.1 回答者： MarcoRossiItaly 回答日時： 2014/04/29 11:06

ご質問は何ですか？疑問点は何ですか？