矩形範囲の複数列を縦１列に並べ替えエクセル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.15 回答者： eden3616 回答日時： 2014/05/10 15:12

こちらでの最終コードを張り付けます。

度重なりますが、次の回答にて別途確認事項を投稿させて頂きます。

◆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
Dim fcnt As Long
Dim objFileSys As Object, objTS As Object
Dim word As String
Set objFileSys = CreateObject("Scripting.FileSystemObject")

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

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

'(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
objTS.WriteLine Cells(i, 2).Value & vbTab & Cells(i, 3).Value
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
Next i
objTS.WriteLine word
Next j

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

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

End Sub

この回答へのお礼

ありがとうございます。
今回のVBAでは回答14の修正にあったBC列の追記とNTの追記部分が見当たりませんがよろしいのでしょうか。
（次のご説明であるかもしれませんが）
なお今回のVBAでもやはり空白セルはNT列の書き出しで発生してしまいます。

お礼日時：2014/05/10 15:43

No.14 回答者： eden3616 回答日時： 2014/05/10 09:34

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

(1)(2)(3)の塊を入れ替えれば出力順が変わりますのでお好きな順番で入れ替えれます。


>それと、こういうマクロを教えられるときいつも感じているのですが、対象データの範囲指定というのはどこでどのようにされているのかなかなか理解できません。
>Z～AFの指定は、最初の方にSet myRng = Range("N1:T50")がありましたね。
はい。範囲指定に関する処理とその利用については以下のようになります。

◆N～T列に関しては
(1)Set myRng = Range("N1:T50")で範囲をmyRngに代入（指定）
(2)繰り返し処理では以下のように利用しています。
　・For j = 1 To myRng.Rows.Count
　　変数jの値を1から指定したmyRng範囲の行数まで繰り返し
　・For i = 1 To myRng.Columns.Count
　　変数iの値を1から指定したmyRng範囲の列数まで繰り返し
(3)セルの値はmyRng.Cells(j, i).Valueで取得しています。
　・myRngの中で左上を基準（1,1）として、
　　(j, i)オフセットした位置のValue（値）を取得しています。

◆E～J列に関しては
(1)「'セルアドレスより各行列番号を取得」の部分で左上及び右下のセルの行・列番号を取得して変数に格納
(2)「'セル範囲が選択中の場合」の部分でセルが範囲選択されていれば(1)の値を選択セルで再度取得
(3)繰り返し処理では以下のように利用しています。
　・For retu = stcol To edcol
　　変数retuの値をstcol（左上セルの列番号）からedcol（右下セルの列番号）まで繰り返し
　・For gyou = strow To edrow
　　変数gyouの値をstrow（左上セルの行番号）からedrow（右下セルの行番号）まで繰り返し
(4)セルの値はCells(gyou, retu).Textで取得しています。
　「Value」「Text」の違いはNo13内に記載しています


>それで他のマクロの方にも
>'矩形範囲を Range オブジェクト に格納
>Set myRng = Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight))
(1)Range(A,B)
　セル範囲（A:B）を指定するものです
(2)ActiveCell
　現在選択中のセルが参照されます
(3)ActiveCell.End(xlDown).End(xlToRight)
　現在選択中のセルから行方向へ「Ctrl + ↓」、列方向へ「Ctrl + →」
　を入力したセルが参照されます
(4)上記(1)(2)(3)により現在選択中のセルからその塊の右下のセルまでを範囲としてオブジェクト変数myRngに格納しています。


>それとNTの範囲書き出しですが、結果が「'データの範囲（左上のセルと右下のセル）アドレスを指定」の行だけ、データがなくても0とタブが書き出されてしまいました、（算式は入って空白表示になっています）
空白であるときの処理を追加します。以下の2点を修正してください。
(1)
word = word & myRng.Cells(j, i).Value & vbTab
の箇所を以下のように修正してください。

If myRng.Cells(j, i).Value <> "" Then
word = word & myRng.Cells(j, i).Value & vbTab
End If

(2)
objTS.WriteLine Cells(i, 2).Value & vbTab & Cells(i, 3).Value
の箇所を以下のように修正してください。

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

この回答へのお礼

お手数をおかけします。
NT書き出しの修正箇所ですが
word = word & myRng.Cells(j, i).Value & vbTab
のところというのは、
If myRng.Cells(j, i).Value <> "" Then word = word & myRng.Cells(j, i).Value & vbTab
の部分のword = word以下を書き換えるということでしょうか。（つまりIf myRng.Cells(j, i).Value <> "" ThenのあとだとまたIf から書くことになりますが）
End ifのあとに
Next i
objTS.WriteLine word
Next j
と続くことになりますが、Next iのところで「参照が不正」となってしまいました。下記VBAによる）


修正箇所がちょっと混乱してしまったのですが、前のものとよく比較してみたら
(1)の方は指定箇所のあとに
End Ifを追記するのみ(If myRng.Cells(j, i).Value <> "" Thenはすでに記述されている）
(2)のほうは指定箇所の前に
If Cells(i, 2).Value <> "" Then
と指定箇所のあとにEnd Ifを追記
というような感じに見えたのですがそれでいいのでしょうか。

ちなみに当方の修正(これはA列書き出しにNTを追加したもの=
BC書き出しと並行チェックしているため混同してすみません、BC列書き出しはできているものの空白処理が不可）

'データの書き込み
For i = 1 To myRng.Columns.Count
For j = 1 To myRng.Rows.Count
If myRng.Cells(j, i).Value <> "" Then objTS.WriteLine myRng.Cells(j, i).Value
Next j
Next i
objTS.WriteLine "***********************************************************************"
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
objTS.WriteLine Cells(i, 1).Value
Next i

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

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

Next i
objTS.WriteLine word
Next j

objTS.Close

それと(2)のほうですが、これはBC列の書き出しの部分でいいんですよね。（というのはBC列は問題なく書き出されていたので）

ただこの修正をしましたが、修正が正しくなかったのか、現状だと空白セルは出てきてしまっています。BC列書き出し分、A列書き出し分とも）

回答ページが離れており比較しながらの修正のためうまく修正できていないのかもしれません

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

No.13 回答者： eden3616 回答日時： 2014/05/09 17:43

回答12のコードにおける説明など。

■内容説明
不透明だった部分を以下のように解釈して作成しています。
間違っている部分があれば、該当箇所及び修正内容をご提示ください。

◆コードの解釈
提示して頂いたコード（一部）の内容でしたので勝手に以下のように解釈しました。

(1)範囲の指定はコード内で記述されている（セル選択による指定ではない）
(2)myRngにはN～Tの矩形データの範囲が格納されている
(3)objTSには新規テキストファイルのパスが格納される

提示されたコードの内容としては以下の処理が行われています。

'□myRngで指定されたセル範囲において処理
'◇列の数だけ繰り返し処理
For i = 1 To myRng.Columns.Count
'◇行の数だけ繰り返し処理
　　For j = 1 To myRng.Rows.Count
　　'◇対象セルの値が空白以外の場合はテキストファイルに出力
　　　　If myRng.Cells(j, i).Value <> "" Then objTS.WriteLine myRng.Cells(j, i).Value
　　Next j
Next i

'□区切りになる文字列をテキストデータに出力
objTS.WriteLine "***********************************************************************"

'□1行～A列に何かしら入っている最終行まで繰り返し処理
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
　　'◇A列の対象行をテキストデータに出力
　　objTS.WriteLine Cells(i, 1).Value
Next i

◆目的の解釈
>B列、C列をタブ形式で、その次にN～Tの矩形データをタブ形式で追記させ
(1)「タブ形式で」はB列及びC列の間をタブにより区切ったテキストデータ
(2)エクセルの行区切りはテキストデータにおいて改行により区切る

◆現状プログラムの動作状況について
>第１セルが通常の文字列の場合は問題なく出力ができます。
>そのセルに■を含む文字列があった場合このエラーが発生しました。
>（１行目はタイトル表示のため先頭に■を入れている場合があります）
>おかげさまで無事希望通りの結果が出力できました。

度重なる追加修正お手数おかけしました。
該当のエラーにつきましてはNo10のコードにて正常に動作しているものと判断いたします。

◆今回のコードについて
>追記する列が"A"でなく、B,C列の複数になること

数がB,Cと少ないため行方向の繰り返し処理の中にB列とC列をタブで文字列結合したうえでテキストデータに出力するようにしています。

objTS.WriteLine Cells(i, 2).Value & vbTab & Cells(i, 3).Value

「objTS.WriteLine」はテキストファイルに書き出す命令です
「Cells(i, 2)」や「Cells(i, 3)」はA1セルを基準の1行1列としてi行2列、i行3列という意味になります
「.Value」は対象の値という意味で、セルの書式設定で表示形式を変更している場合の見た目上の文字を取得する場合は「.Text」などに変更してください
「 & vbTab & 」はタブで前後の文字列を結合しています

結合する列数が多くなれば「 & vbTab & Cells(i, 4).Value」のように沢山追記するとコードが長くなるため、列の繰り返し処理を組み込む必要があります。

>N～Tも複数列のため"B,C"のようにするのかわかっていません。

上記コードの解釈(2)であれば、指定（固定）された範囲の値を、行・列方向に繰り返し処理を行うことで範囲内のすべてのセルに対して処理が行えます。
提示されたコードでは行方向の繰り返し処理を列の数だけ行う処理が行われています。
これでは各行における列をタブで区切ってテキストデータに結合する処理が行えませんので、列方向の処理を行の数だけ繰り返すように変更しております。

具体的には「For i = 1 To myRng.Columns.Count」と「For j = 1 To myRng.Rows.Count」を組み替えています。

◆最後に
>お手数ですが追記部分をご教示していただけますか。
>（追記しない今回のものも使いたいので、追記部分だけ明示していただけるとVBAの加工に利用できますのでよろしくお願いします）

上記「今回のコードについて」に記載したとおり、処理手順の書き直しを行っていますのでプログラム全体の入替という形になります。
ベースのコードがあれば追記・修正部分だけの提示が出来るかもしれません。

以上、長文失礼しました。

No.12 回答者： eden3616 回答日時： 2014/05/09 17:39

>そこでVBAで出力させる時に、縦一列のデータの次にB列、C列をタブ形式で、その次にN～Tの矩形データをタブ形式で追記させ、

>それぞれの追記箇所に****************を入れるようにしたいです。

遅くなりました。
以下のVBAコードをご利用ください。
以前のコードと提示して頂いたコードを流用したため統一性がとられておらず雑多なコードで申し訳ない。
また質問内容への返答及びコードの説明等は別の回答で追加します。
（駄文により文字制限をオーバーしてしましました）

■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
Dim fcnt As Long
Dim objFileSys As Object, objTS As Object
Dim word As String
Set objFileSys = CreateObject("Scripting.FileSystemObject")

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

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

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

'(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
Next i
objTS.WriteLine word
Next j

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

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

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

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

この回答への補足

Z～AFの指定は、最初の方に
Set myRng = Range("N1:T50")
がありましたね。
それで他のマクロの方にも

'矩形範囲を Range オブジェクト に格納
Set myRng = Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight))
があったのでここに
Set myRng = Range("Z1:AF150")
と追記したらうまくできました。
お騒がせしました。
BCの仕方との違いはなんでしょうね。

ただ空欄行はやはり書き出されてしまいます。

補足日時：2014/05/09 21:03

この回答へのお礼

毎回ながらご丁寧に説明していただけるので感謝しています。
私も与えられたマクロをただ動かすだけでなく、中身を解読することで少しは覚えられることになると思い、ご迷惑な質問も多々あることをお許しください。
今回のマクロではほぼ目的通りになりました。
ただ、NTデータがBCの前になってしまっていたのでコメントをたよりに入れかえました。
それと、こういうマクロを教えられるときいつも感じているのですが、対象データの範囲指定というのはどこでどのようにされているのかなかなか理解できません。
今回の場合もですが、N～T列のデータを転記していますが、記述を読む限りそれらしき指定がみつかりません。
というのも、このNT列書き出しを別のマクロに組み込んでみました。ところがこちらの対象書き出し範囲はZ～AFまでだったため、別のデータ（たぶんN～T）が書き込まれてしまいました。そこで範囲の指定箇所を探し出そうとしたのですが私には理解できませんでした。
それとNTの範囲書き出しですが、結果が「'データの範囲（左上のセルと右下のセル）アドレスを指定」の行だけ、データがなくても0とタブが書き出されてしまいました、（算式は入って空白表示になっています）
ほかの書き出しはデータの範囲で問題はありません。

なお、とりあえず動かしてみたため、その段階での質問をさせていただきましたが、これから回答No13の方もじっくり勉強させていただき、また教えていただくこともあるかと思いますので、とり急ぎお礼とご報告をさせていただきました。

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

No.11 回答者： eden3616 回答日時： 2014/04/30 11:18

>残念ながら当方マクロを覚えようとして参考書を見ながら理解しようとしているのですがなかなか一人では習得できず、悲しい限りで、できる方をうらやましく思います。

これからも少しずつ解釈しながら勉強したいと思っています

私も同じですよ。専門的に勉強したわけではなく仕事でたまたま使うから覚えただけなので独学ですので、荒々しいコードになっている部分もあるかもしれません。
VBはプログラム言語としては手軽な部類に入ると思いますし、参考になるサイトがネットには多数ありますので頑張ってください。
とりあえずVBAでは「マクロの記述」をうまく活用して、記述されたコードを弄れるようになれば良いのではないでしょうか。



>なお、教えいただいたマクロを実作業で使いながら、もし問題点が出たらまたご相談させていただきますので１週間くらい締め切りませんのでよろしくお願いします。

良いですよ～対応できることであればさせて頂きます。
GWに入るのでタイミングによっては返答が遅れる場合があります。


No10の補足事項についてはまた拝見させて頂きます。

No.10 回答者： eden3616 回答日時： 2014/04/29 23:57

>いくつか試した結果、次のような状況が把握できました。

第１セルが通常の文字列の場合は問題なく出力ができます。
ところが、そのセルに■を含む文字列があった場合このエラーが発生しました。
（１行目はタイトル表示のため先頭に■を入れている場合があります）
たぶんこの影響のようです。


No8の修正箇所を以下のようにお願いします。

-------------------------------

'出力先のファイル名を処理
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

-------------------------------

使用できない文字列は
ngs = Split("■,\,/,:,*,?,"",<,>,|", ",")
で指定した文字（追加する場合はカンマ「,」で区切り追加してください）を
fname = Replace(fname, ng, "#")
で#に置換しています


イミディエイトウィンドウは
「Alt+F11」または、表示→マクロ→「action」を選択→編集
で開いた「Microsoft Visual Basic」で
「Ctrl+G」または表示→イミディエイトウィンドウと選択して頂ければ表示されます。

この「Microsoft Visual Basic」が表示され、イミディエイトウィンドウが表示されている状態で
「action」マクロを実行するとイミディエイトウィンドウ内にプログラム中に出力指示した値が表示されます。
Debug.Print 変数　・・・　変数の内容をイミディエイトウィンドウに表示します

この回答への補足

これに関連して追加をお願いできればありがたいですが。
現在、元データのテキストファィルからB列、C列に貼り付け、この結果得られるデータをE列からJ列まで表示しています。
これを教えていただいた並べ替え出力をしているわけですが（例示でD～Hですが実際はE～J)
元データを保存するためにB列、C列を並べ替えせずタブで出力テキストの末尾に手動で貼り付けています。
更に、このデータから別に利用する算式データをN列からT列まで表示しており、この矩形データをそのまま（タブ）同じテキストに手動で貼り付け
いわゆる３種類のデータをひとつにまとめています。
そこでVBAで出力させる時に、縦一列のデータの次にB列、C列をタブ形式で、その次にN～Tの矩形データをタブ形式で追記させ、
それぞれの追記箇所に****************を入れるようにしたいです。
これに類したことは次のVBAで'行っているのでNext i以下を追記すればいいのかなと思いましたが、
追記する列が"A"でなく、B,C列の複数になること、N～Tも複数列のため"B,C"のようにするのかわかっていません。
お手数ですが追記部分をご教示していただけますか。
（追記しない今回のものも使いたいので、追記部分だけ明示していただけるとVBAの加工に利用できますのでよろしくお願いします）
手動のままでもかまわないのですが、この際一緒に処理できれば好都合なので追加相談させてもらいましたが、もし質問の範囲外になるなら無視してもらってけっこうです。

'テキスト書き出し
For i = 1 To myRng.Columns.Count
For j = 1 To myRng.Rows.Count
If myRng.Cells(j, i).Value <> "" Then objTS.WriteLine myRng.Cells(j, i).Value
Next j
Next i
objTS.WriteLine "***********************************************************************"
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
objTS.WriteLine Cells(i, 1).Value
Next i

objTS.Close

補足日時：2014/04/30 08:46

この回答へのお礼

おかげさまで無事希望通りの結果が出力できました。
素人相手に長時間にわたりおつきあいいただきありがとうございました。
残念ながら当方マクロを覚えようとして参考書を見ながら理解しようとしているのですがなかなか一人では習得できず、悲しい限りで、できる方をうらやましく思います。
これからも少しずつ解釈しながら勉強したいと思っています

なお、教えいただいたマクロを実作業で使いながら、もし問題点が出たらまたご相談させていただきますので１週間くらい締め切りませんのでよろしくお願いします。

お礼日時：2014/04/30 07:24

No.9 回答者： eden3616 回答日時： 2014/04/29 18:06

たびたびすみません。

上記のように書き換えた場合
Open tpath For Output As #1

はそのまま後に続いていいのですよね？

はい。続けてください



>やはり同じ場所でエラーになってしまいました。

最終的に出来上がったtpathの値が気になりますね

No8の修正内容の中で以下の部分が間違えておりました。
debug.print "dpath = " dpath
を
debug.print "dpath = " & dpath
としてください。

VBAのイミディエイトウィンドウにdpath=○○と出力されているパスをご確認ください。
正常な表記になっていますでしょうか？

―――――――――――――――――――

こちらのテスト環境に
dpath = "H:\MP3ファイル\MP3\新しいフォルダ"
を作成してもご提示のエラーが再現できません。
お手数ですが以下のコードで再度試してみてください。

―――――――――――――――――――
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
Dim fcnt As Long

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

'セルアドレスより各行列番号を取得
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
dpath = "H:\MP3ファイル\MP3\新しいフォルダ"
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

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

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

この回答へのお礼

いくつか試した結果、次のような状況が把握できました。
第１セルが通常の文字列の場合は問題なく出力ができます。
ところが、そのセルに■を含む文字列があった場合このエラーが発生しました。
（１行目はタイトル表示のため先頭に■を入れている場合があります）
たぶんこの影響のようです。

すみません。それから
VBAのイミディエイトウィンドウってどこにあるのでしょうか。

お礼日時：2014/04/29 18:52

No.8 回答者： eden3616 回答日時： 2014/04/29 16:30

>「パスが見つかりません。

」のエラーがでました。
Open tpath For Output As #1
の部分になります。


'出力先のファイル名を処理
If Cells(strow, stcol).Text = "" Then
fname = "不明(" & Cells(strow, stcol).Address & ")"
Else
fname = Cells(strow, stcol).Text
End If
tpath = Application.DefaultFilePath & "\" & fname & ".txt"
Do Until Dir(tpath) = ""
fcnt = fcnt + 1
tpath = Application.DefaultFilePath & "\" & fname & "_" & fcnt & ".txt"
Loop


上記部分を以下と置き換えてください


'出力先のファイル名を処理
If Cells(strow, stcol).Text = "" Then
fname = "不明(" & Cells(strow, stcol).Address & ")"
Else
fname = Cells(strow, stcol).Text
End If
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



>また、保存を特定のフォルダにしたい場合
tpath =　Application.DefaultFilePath & "\"& fname & ".txt"
のところを
"H:\MP3ファイル\MP3\新しいフォルダ\" & fname & "_" & fcnt & ".txt"
のようしたらいいでしょうか

上記修正の中の
dpath = ThisWorkbook.Path
の部分を
dpath = "H:\MP3ファイル\MP3\新しいフォルダ"
としてください
（最後に「\」はつけないでください）

この回答へのお礼

たびたびすみません。

上記のように書き換えた場合
Open tpath For Output As #1

はそのまま後に続いていいのですよね？

やはり同じ場所でエラーになってしまいました。

お礼日時：2014/04/29 17:29

No.7 回答者： eden3616 回答日時： 2014/04/29 15:24

>これは基本は範囲を選択しておかなくても、アドレス指定をしておけば、それが自動選択されて作成されるほか、あらかじめ範囲選択しておけばそちらで作成できるという選択肢かと思っていました。

（これは便利です）
実際どちらでやってもその通りに出力できました。

はい。どちらの方法でも利用できます。
ご指摘の通り初期設定を空欄「=""」ですとエラーになります。



>またH50については、H50のままだと51行め以上にデータがあっても切り捨てられてしまう。
最大値としてとりあえずH80くらいにしておいたら実際にあるH57までのデータが取り込まれました。したがって最大値にしておけばいいと思っています。（定性的な自動選択の場合）

指定した範囲を全て照査しますので、最大値と捉えてもらって構いません。
多めに設定した場合その分処理を行い時間がかかりますが、セルの値を取得して空白以外は無視しているので対して変わらないかもしれません。



>問題点がいくつかありました。
(1)質問にも書いてあるのですが、D列に空白セルがある場合その「行」を削除するが、削除はそのセルに限定されていた。
　→　D列指定ではなく、選択セル範囲のうち一番左の列という解釈で作成しました

(2)書き出しファィルの上書き回避（末尾に_1をつけるとか)がされておらず上書きされてしまう。
　→　取得したファイル名が既に存在する場合は「_n（nは桁揃え無しの1からの通し番号）」を追加するようにしました
　→　nの値は1から順番に存在を確認するため、「○○_1、_2、_4」が存在していた場合の保存されるファイル名は「○○_3」となります

(3)ファィル名、これは質問の仕方が悪かったのですが、D1というのは選択範囲の第１セルのつもりでしたので、範囲が変わる場合はこのD1も変わります。すなわち範囲の第１セル（左上）の名称を使う。
　→　修正しました
　→　ファイル名を取得するセルが空白「""」の場合「不明(左上のセルアドレス)」というファイル名で保存されるようにしました


以下のコードで置き換えてください

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
Dim fcnt As Long

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

'セルアドレスより各行列番号を取得
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
tpath = Application.DefaultFilePath & "\" & fname & ".txt"
Do Until Dir(tpath) = ""
fcnt = fcnt + 1
tpath = Application.DefaultFilePath & "\" & fname & "_" & fcnt & ".txt"
Loop

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

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

この回答へのお礼

「パスが見つかりません。」のエラーがでました。
Open tpath For Output As #1
の部分になります。

また、保存を特定のフォルダにしたい場合
tpath =　Application.DefaultFilePath & "\"& fname & ".txt"
のところを
"H:\MP3ファイル\MP3\新しいフォルダ\" & fname & "_" & fcnt & ".txt"
のようしたらいいでしょうか

お礼日時：2014/04/29 15:50

No.6 回答者： eden3616 回答日時： 2014/04/29 13:26

No4のコードの中に

「'出力先の開始セルアドレスを指定」

と記述している箇所がございます。
No3のコードをベースに改変した際にコメント文の記述を変更しておりませんでした。
（「'」から始まるコードはコメント文と言われ、プログラムとして実行されないメモとなります）

tr = "D1"
tpath = Application.DefaultFilePath & "\" & Range(tr) & ".txt"

上記箇所の処理は指定してある"D1"の内容を取得し、
デフォルトパスに指定された"D1"のファイル名で保存するための準備の部分になります。
よってD1以外からファイル名を取得する場合はtr = "D1"の部分を変更してください。

処理内容に問題はありませんが、
誤解を招くかもしれませんので補足させて頂きました。