矩形範囲の複数列を縦１列に並べ替えエクセル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.25 ベストアンサー 回答者： eden3616 回答日時： 2014/05/11 09:21

>ご指示のVBAはEnd Subによりメッセージ表示までで終わってしまいますが

>▼▼▼以下でコード用のコード▼▼▼
>のほうはどのように処理すればいいのでしょうか。

Sub～End Sub
が呼び出し元のプログラムで

Function ～End Function
が呼び出し先の関数プログラムです

呼び出し元から値を関数プログラムへ渡すことで、関数プログラムは処理を行い
呼び出し元へ処理結果を返します。
呼び出し元ではそれを表示しているため、
両方のコードを記述する必要があります。


>なお、前問のVBAは、MSXML2使ったダウンロードという前提で
>VBAがつくられているようです。

XMLでは文字参照が用いられています。
http://ja.wikipedia.org/wiki/Extensible_Markup_L …


>質問が波及してしまってすみません。
>必要であれば、そのQNoを記述しますが、この項目でこれに関する質問を続けることが適切かどうかで気にしています。

参考になればと前回答をさせてはいただきましたが、
やはり表題と異なる内容になってきているため一度締めるほうが適切かと。
http://psguide.okwave.jp/guide/prohibition.html
「■分割質問・締め切らずに関連質問」に関わってまいります。

確認したい事柄に対して具体的に結果と材料を提示して頂ければ的を得て回答できると思います。

この回答への補足

教えていただいたVBA、おかげさまで問題なく作動しております。このたびは大変ありがとうございました。
また機会がありました時はこれに懲りずにどうぞよろしくお願いいたします。

補足日時：2014/05/14 11:30

この回答へのお礼

文字参照の件はVBAコードがまだ理解できていませんが、たしかに冒頭質問から離脱してしまいますので、お説のとおりこの件のやりとりについては終了させていただきます。
当初質問については現時点では問題なく動作していますので、これで締め切ることもかまいませんが、週１回データが発生するため実使用しながらその間様子をみてなにかありましたらご相談したいので、１週間くらいこのまま締め切らずにおきたいと思います、あしからずご了承ください。
重ね重ねありがとうござしました。

お礼日時：2014/05/11 09:54

No.24 回答者： eden3616 回答日時： 2014/05/10 23:44

「&#数値;」は数値文字参照における10進数表記になります。

http://ja.wikipedia.org/wiki/%E6%96%87%E5%AD%97% …

「'」はシングルクォーテーション（アポストロフィ）の数値文字参照となります。
http://ja.wikipedia.org/wiki/%E2%80%99
（上記Wikiの符号位置の項目に記載されております）

ですので、数値文字参照をデコードするような処理を組み込めばよいかと。
VBAではChr(39)で「'」を取得できます。
これを用いてデコード用の関数「deco」を作成してみました。
以下を標準モジュールに貼り付けてから「テスト」を実行してみてください。
＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿

Sub テスト()
'型宣言
Dim word As String

'文章を変数wordに格納
word = ""はダブルクォート" _
& vbCrLf & "$はドル" _
& vbCrLf & "%はパーセント" _
& vbCrLf & "&はアンパサンド" _
& vbCrLf & "'はアポストロフィー"

'変数wordをデコードしてダイアログで表示
MsgBox deco(word)
End Sub

'▼▼▼以下でコード用のコード▼▼▼
Function deco(target As String) As String
'型宣言
Dim rematch
Dim hit As String
Dim re As Object
Dim word As String
Dim i As Long
'正規表現を利用するための準備
deco = target
Set re = CreateObject("VBScript.RegExp")
'正規表現のパラメータをセット
re.Global = True
re.ignorecase = False
re.pattern = "&#\d+;"
'正規表現で検索
Set rematch = re.Execute(target)
'マッチした部分を格納
For i = 0 To rematch.Count - 1
hit = hit & rematch(i).Value & ","
Next i
'不要な部分を削除
hit = Replace(hit, "&", "")
hit = Replace(hit, "#", "")
hit = Replace(hit, ";", "")
hit = Left(hit, Len(hit) - 1)
'「,」で分割して配列に格納
code = Split(hit, ",")
'文章を置換して返す
For i = 0 To UBound(code)
deco = Replace(deco, "&#" & code(i) & ";", Chr(Int(code(i))))
Next i
Exit Function
End Function

￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣￣
変数wordに格納した以下の文章が

"はダブルクォート
$はドル
%はパーセント
&はアンパサンド
'はアポストロフィー

以下の文章にデコードされて表示されます

"はダブルクォート
$はドル
%はパーセント
&はアンパサンド
'はアポストロフィー

この回答へのお礼

質問が波及してしまってすみません。
ご指示のVBAはEnd Subによりメッセージ表示までで終わってしまいますが
▼▼▼以下でコード用のコード▼▼▼
のほうはどのように処理すればいいのでしょうか。

なお、前問のVBAは、MSXML2使ったダウンロードという前提で
VBAがつくられているようです。
必要であれば、そのQNoを記述しますが、この項目でこれに関する質問を続けることが適切かどうかで気にしています。

お礼日時：2014/05/11 06:32

No.23 回答者： eden3616 回答日時： 2014/05/10 23:40

投稿するまえに確認のためのテストです。

この回答は無視してください。

& vbCrLf & "$はドル" _

re.pattern = "&#\d+;"

「&#数値;」

No.22 回答者： eden3616 回答日時： 2014/05/10 20:25

>直接関係なくて恐縮ですが、VBAの詳しい方にお聞きしたかったのですが、

>WEBからVBAでデータを取り込んだときに最近「'」
>等一部の文字が「'」等となってしまうこと

同じように見受けられますが・・・。
OKWebの仕様により投稿時に依存文字は置換されている可能性があります。
（○の中に1が入った環境文字は(1)に置換されます）

エクセルにおいてシングルフォーテーションマーク「'」の意味は
セル内の先頭に記述されますと文字列を指定するための記号として扱われます。
シート内のセルに取り込まれたデータを書き出しているのであれば
たとえば、全角の「’」は「'」と認識されてセル内に表示されなくなります。

おそらくWebクエリからHTMLソースを取得して文字列加工を行っているとは思いますが、
これ以外の問題であればコード内で該当の文字列をどのように処理しているかが不明確ですので想定ではお答えしかねます。

たとえば取得した「'」の文字コードと、WEBで使われている元の「'」の文字コードを比較すれば、VBA内部でどのように処理されるのかが見えるかと思います。

この回答へのお礼

すみません。質問の内容が自動変換されていて見当ちがいになってしまいました。
「'」であるべきものが
＆
＃
０
３
９
；
（変換されてしまうため縦かつ大文字に書きました）
これが横に書かれてなってしまうものです。
ほかにもかっことかも似たような記号になっています。
以前はこのようなことはなく、またクエリで取り込んだ場合は正常になります。

お礼日時：2014/05/10 20:39

No.21 回答者： eden3616 回答日時： 2014/05/10 19:56

>範囲の指定さえしておけば、N列でなくとも、最左列が自動的に決まるのですね。

はい、そのように処理されます。

以下の2行は開始値を1から始め、行・列数の数までiを変動させています。
For j = 1 To myRng.Rows.Count
For i = 1 To myRng.Columns.Count

範囲がN1：T50の場合、
myRng.Rows.Countの値は1行～50行目の行数なので、50
myRng.Columns.Countの値はN～T列の列数なので、7
が取得されます。
よって行方向ではjが1から50まで変動し、列方向ではiが1から7まで変動します。

実際のセルの値を取得する処理が以下の部分になります
word = word & myRng.Cells(j, i).Value

ここでmyRngで設定された範囲のうち左上のセルをCells(1, 1)としたとき、
Cells(j, i)のセルのValue（セルの値）を変数wordに代入しています。
（word = word & 追加文字列　とすることでwordの後に追加文字列を結合することができます）

N1：T50が対象の範囲とすれば、N1がCell(1,1)に該当し、N2はCell(2,1)、O1はCell(1,2)で取得されます。
つまり
N1　O1　P1
N2　O2　P2　・・・
N3　O3　P3
　　・
　　・
　　・
は以下のようにmyRng.Cell(j,i)が繰り返し処理により変動することで範囲内のセルを全て対象に処理されます。
myRng.Cell(1,1)　myRng.Cell(1,2)　myRng.Cell(1,3)
myRng.Cell(2,1)　myRng.Cell(2,2)　myRng.Cell(2,3)　・・・
myRng.Cell(3,1)　myRng.Cell(3,2)　myRng.Cell(3,3)
　　・
　　・
　　・


>関数だと列の数え方が1列めを0として数えることもあった気がしましたが、これだと1から1ずつ増やすということになりましょうか(1 To myRng.Columns.Count)

関数というか、配列でしたらプログラムでは0が開始値になります。
今回の繰り返し処理を行っている「For～Next」は変数の値を開始値から開始値になるまで変動し繰り返し処理します。
繰り返し処理の中で、変動の増減値を省略した場合は1加算されます。
（本来は「For i = 1 To myRng.Columns.Count Step 1」のようにStep ○で増減値を明記しますが上記では省略しています）


>今まで「行の削除」とばかり思い込んできましたがテキストに書き出すということで「出力しない」という手法になるのですね。

処理の書き方にもよりけりですが、
今回の処理はテキストデータの加工→テキストファイルへ出力を繰り返しているだけで
出力するときに条件を判断して、出力するかしないかを判定しています。


>エクセル上で同様の処理をする場合、行の削除は下から順に行うと処理をするいうことで覚えていましたので、

はい、そのとうりです。
削除の場合はエクセルの仕様で空白になるのではなくシフト（詰められます）されます。
ご存知の通り、行の削除を若い数から行うと先ほどのForループにより次の行番号を処理しようとしたときに
前のループ内で行を削除すると次の行が上に１行シフトしますので
次の行を処理するときに１つ飛ばしになってしまう事になります。
このため、削除した行を判断して処理する対象の行をそのつど変更する処理を加える必要があります。

この工程を加えず、手軽に行削除する方法は下から順に処理を行うという方法になります。
Forで行番号を指定するときに行の最大値を開始値として、最小値まで「Step -1」で処理を行う事で実現できます。
これでしたら対象行より上は初期のデーたのままですので削除による行シフトが影響しません。


>てっきり行削除するのかと思い、他の列に影響することを避けるため、NからTのデータは元データに影響のない行、
>例えばA1000以下に設定するようなこともしていましたが、書き出しの場合はその必要がないことがわかりました。

必要なものをチョイスして上から順番に書き出すだけですので、不要なものは読み飛ばすだけで良いため
取得元のデータは変わらず、削除の時のように行や列のシフトが発生しませんので気をつける必要はありません。


今回は元のデータを読み取って不要な部分を読み飛ばして出力する処理になりますが
元のデータを作業用として崩しても構わないのであれば、
最終の出力状態へエクセルシートのデータを加工（削除や移動など）を行ったうえで
テキストファイルへ1行目から書き出す方法もあります。

No.20 回答者： eden3616 回答日時： 2014/05/10 18:29

>なおひとつだけお尋ねしておきたいのですが、

>N列が空白であれば問答無用でその行はテキストデータに出力しません。
>というのはどの部分で記述されているのでしょうか。
>ほかに応用したい場合に覚えておきたいためよろしくお願いします。

N～T列の処理内容を具体的に記述いたします。

'(2)N～T列をタブ区切りでテキストデータへ出力

'新しく使用する変数flagを型宣言します
Dim flag As Integer

'変数jの値を1から1ずつ増やしながら行の数だけ繰り返し
For j = 1 To myRng.Rows.Count

'変数wordと変数flagの値を初期値に設定
word = ""
flag = 0

'変数iの値を1から1ずつ増やしながら列の数だけ繰り返し
For i = 1 To myRng.Columns.Count

'▼▼▼▼各セルに対する処理▼▼▼▼

'対象のセルが空白でなければflagの値を1増やします
'（テキストデータを出力するかどうかの条件Ａとします）
If myRng.Cells(j, i).Value <> "" Then
flag = flag + 1
End If

'出力するテキストデータの文字列を作成します
'変数wordに現在のセルの値を結合
word = word & myRng.Cells(j, i).Value

'変数iの値が選択した列の数未満であれば、タブを変数wordの後に結合
'（このIf文により末尾以外にタブが追加されます）
If i < myRng.Columns.Count Then word = word & vbTab

'▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲

'列ループの最後
Next i

'以下の条件Ａ、Ｂを両方満たす場合のみテキストデータを出力します。
'条件Ａ　flagの値が1以上
'条件Ｂ　最左列が空白以外
'つまり以下の場合はテキストデータを出力しません。
'現在の行において、N～T列のひとつも空白以外のセルがない場合
'最左列（N列）が空白の場合
If flag > 0 And myRng.Cells(j, 1).Value <> "" Then objTS.WriteLine word

'行ループの最後
Next j


「問答無用でその行はテキストデータに出力しません」と表記しましたが
適切には上記条件ＡまたはＢにより出力されなくなります。

ちなみに「flag > 0 And myRng.Cells(j, 1).Value <> ""」の部分は
条件Ａの判定式　：　flag > 0
条件Ｂの判定式　：　myRng.Cells(j, 1).Value <> ""
条件ＡとＢを両方満たす場合を示す比較演算子　：　Ａｎｄ
ということになります。

この回答への補足

直接関係なくて恐縮ですが、VBAの詳しい方にお聞きしたかったのですが、WEBからVBAでデータを取り込んだときに最近「'」等一部の文字が「'」等となってしまうことが多くなったのですが、どこかに設定するところがあるのでしょうか。
VBA全体がわからないとということでしたらご回答不要です。
もしなにか判断できるようでしたらよろしくお願いします。

補足日時：2014/05/10 19:31

この回答へのお礼

十分理解できたかどうかは自信はありませんが、なんとなくわかってきました。
範囲の指定さえしておけば、N列でなくとも、最左列が自動的に決まるのですね。関数だと列の数え方が1列めを0として数えることもあった気がしましたが、これだと1から1ずつ増やすということになりましょうか(1 To myRng.Columns.Count)
。

今まで「行の削除」とばかり思い込んできましたがテキストに書き出すということで「出力しない」という手法になるのですね。
エクセル上で同様の処理をする場合、行の削除は下から順に行うと処理をするいうことで覚えていましたので、てっきり行削除するのかと思い、他の列に影響することを避けるため、NからTのデータは元データに影響のない行、例えばA1000以下に設定するようなこともしていましたが、書き出しの場合はその必要がないことがわかりました。

お礼日時：2014/05/10 19:09

No.19 回答者： eden3616 回答日時： 2014/05/10 17:27

>これをエクセルと同じようなソフトで項目ごとに一括貼り付けるのですが

>残念ながらNTの出力はどうしても空白行が末尾に発生してしまいます。

別ソフトにて末尾にタブが追記されていると不都合があるという事でしたら、
こちらが補足の内容を取り違えておりました。
現コードではN～Tの結合にて結合後にタブを追加していますので末尾にもタブが追加されます。
以下の修正で各行の末尾にタブが追加されなくなります。

回答No15をベースにNo16の修正を適応して頂きましたら、
No18の修正箇所を以下を用いて修正してください。

'(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

この回答へのお礼

末尾のタブというのは行ごとのタブでなく、最初のとき問題だった範囲内にある空白行がデータがなくとも指定行数までタブで表示されてしまうという意味でした。

したがっておっしゃっている行ごとの末尾のタブはまったく気にしていませんでした。たまたま貼り付けている表の項目がT相当で終わっていたため、支障がなかったのかもしれませんが、ない方がすっきりしますので修正させていただきます。
ありがとうございました。

お礼日時：2014/05/10 18:11

No.18 回答者： eden3616 回答日時： 2014/05/10 16:54

>NTの範囲ですが、この中にS列は行により空白になるケースがあります。

>ただこの空白はそのまま、残してタブではさんでおきたいのです。

'(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 & vbTab
Next i
If flag > 0 And myRng.Cells(j, 1).Value <> "" Then objTS.WriteLine word
Next j

としてください。
S列に限らず、O～Tの中で１つでも空白以外があれば、空白セルはタブを残して結合します。
N列が空白であれば問答無用でその行はテキストデータに出力しません。

この回答へのお礼

できましたっ！
いゃあ、うれしいです…
さんざん悩んでいた空白行もすっきりとれました。
それに(2)のNT列書き出しを第３のVBAにも使ってみました。
範囲の指定箇所がわからないので(2)の冒頭に
Set myRng = Range("AC1:AI50")を入れたらこれも見事に書き足されてくれました。
いくつかの類似VBAがあるため、あちこち活用できます。

本当に長時間にわたり教えていただいて感謝感激です。
公の質問サイトを個人教授みたいに利用させてもらい、「教師」に月謝でも払いたいくらいです。（苦笑)
これからじっくり解説説明を読んでVBAの流れを理解しながら勉強させていただきます。
まだしばらくこれを試す機会がありますが、本当にありがとうございました。

なおひとつだけお尋ねしておきたいのですが、
N列が空白であれば問答無用でその行はテキストデータに出力しません。
というのはどの部分で記述されているのでしょうか。
ほかに応用したい場合に覚えておきたいためよろしくお願いします。

いままでも範囲取り出しとか、WEBデータ取込みとか私の質問内容をみていただくとわかるかと思いますが、かなり色々なVBAを教えていただいたものを活用しています。それに今回の書き出しがかなり利用できそうです。
実をいうとその中にまだ若干手直しが必要なものもいくつかあります。またお目にかかる機会がありましたら相談させていただければ光栄です。

お礼日時：2014/05/10 17:48

No.17 回答者： eden3616 回答日時： 2014/05/10 16:07

何度もすいません。

回答No16の回答内で記載しています説明の中で誤りがあります。

「If word = "" Then objTS.WriteLine word」ではなく
「If word <> "" Then objTS.WriteLine word」です。

「■修正に対するお詫び」内の差替えコード及び
「■No14のお礼の内容について」内のN～T列に関する処理コードでは

「If word <> "" Then objTS.WriteLine word」

を使用しています。

この回答へのお礼

NTの書き出しでテストの結果、ひとつ書き忘れていたことがあったため、出力が希望と違っていました。
NTの範囲ですが、この中にS列は行により空白になるケースがあります。ただこの空白はそのまま、残してタブではさんでおきたいのです。
これをエクセルと同じようなソフトで項目ごとに一括貼り付けるのですが、S列に当たる項目が記述がある場合とない場合があってもそのまま貼り付けます。
現在だと、空白セルの削除ということで処理されているかと思いますが、空白削除は範囲の最左列が空白の場合のみその「行」を削除することでお願いできればありがたいです。
よろしくお願いします。

お礼日時：2014/05/10 16:23

No.16 回答者： eden3616 回答日時： 2014/05/10 15:59

■修正に対するお詫び

以下の２点について回答に誤りがあります。申し訳ありません。

(1)
回答No15のコードですが修正漏れがありました。
以下のコードで該当部分を差し換えてください。

▼▼▼▼▼▼以下差替えコード▼▼▼▼▼▼

'区切りをテキストデータへ出力
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列をタブ区切りでテキストデータへ出力
For j = 1 To myRng.Rows.Count
word = ""
For i = 1 To myRng.Columns.Count
If myRng.Cells(j, i).Value <> "" Then
word = word & myRng.Cells(j, i).Value & vbTab
End If
Next i
If word <> "" Then objTS.WriteLine word
Next j

▲▲▲▲▲▲以上差替えコード▲▲▲▲▲▲


(2)
回答No14の(2)の修正内容について記載漏れている箇所がありました。
No14の修正内容に追加で
objTS.WriteLine word
の部分を
If word = "" Then objTS.WriteLine word
としてください。


■空白が出力される件について
>修正箇所がちょっと混乱してしまったのですが、前のものとよく比較してみたら

(1)について
If myRng.Cells(j, i).Value <> "" Then
　　元のコード
End If

(2)について
If Cells(i, 2).Value <> "" Then
　　元のコード
End If
というように「If～End If」ブロックで挟み込むように修正します。
If文は条件式が成立するときのみ、Then～End Ifまでの処理を実行します。

(2)につきましてはお詫びに記載しましたが、追加修正として
If word = "" Then objTS.WriteLine word
のように変更してください。（これが無かったのが原因です）
上記部分は、(2)のIfブロック内の処理にて変数wordに１行分の列方向のデーたをタブ区切りで結合しますが
Ifブロックの条件式「Cells(i, 2).Value <> ""」に該当せず、変数wordの中身が無ければテキストデータに出力しません。


■No14のお礼の内容について

>NT書き出しの修正箇所ですが
提示して頂いたコードに追記する場合は以下のようになります。

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


>それと(2)のほうですが、これはBC列の書き出しの部分でいいんですよね。

If Cells(i, 2).Value <> "" Then
objTS.WriteLine Cells(i, 2).Value & vbTab & Cells(i, 3).Value
End If

B、C列が空白であれば出力を読み飛ばします。
上記(2)の修正は「If Cells(i, 2).Value <> "" Then」B列が空白以外だった場合、
B列「Cells(i, 2).Value」とC列「Cells(i, 3).Value」をタブで結合「 & vbTab & 」して
テキストファイルへ出力「objTS.WriteLine 」しています。

提示して頂いたコードに追記する場合は以下のようになります。

For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(i, 1).Value <> "" Then
objTS.WriteLine Cells(i, 1).Value
End If
Next i


>（というのはBC列は問題なく書き出されていたので）

不要であれば「If～Then」と「End If」を削除してください

この回答へのお礼

12でいただいたコードをその後の修正で行っていましたが、修正箇所が混乱してしまったため、いったん白紙にして再度いただいた15のコードに16の差し換えコードで修正の上利用させていただきました。
残念ながらNTの出力はどうしても空白行が末尾に発生してしまいます。

お礼日時：2014/05/10 16:52