エクセルVBAで複数列データを１列に配列替えしたい

質問

先日この欄で教えていただいたのですが、
確認を忘れてしまい、うまくゆかないので再質問させていただきます。

複数列の複数行（例A列3行～F列20行）に関数式によるデータが入っています。
これを縦１列に配置替えしてテキストにoutputするということで次のVBAを教えてもらったのですが
途中で止まってしまいました。お知恵を貸してください。

Sub closs()
Dim myRng As Range
Dim i As Long
Sheets("データシート").Select
Set myRng = Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight))
Sheets("貼り付け").Select
For i = 1 To myRng.Columns.Count
　Range("A1").Offset((myRng.Rows.Count) * (i - 1)).Resize(myRng.Rows.Count) _
　　= myRng.Columns(i).Value
Next
End Sub

※例としてA列3行～F列20行を１グループとして縦１列に配列替えをしてテキストに出力する。
※マウスによるカーソル位置をデータトップのA3またはそれより上の空欄において実行する。
※グループの途中（例A21～F24）を空欄（関数式なし）として次のグループが存在し、グループか存在する場合同じ作業を繰り返し
別のテキストにoutputする。
※列を増やしたい場合の対応もできるようにしておく。

よろしくお願いします。

回答No.10

DOUGLAS_ · ベストアンサー

＞途中空白行（算式により空白にしている行）
＞行間をつめたい。

　そうでしたか。

　では、
'変数の宣言
に
　Dim j As Long　　　　　　　 '矩形範囲の各列内の行番号
を加え、

　　objTS.WriteLine Join(Application.WorksheetFunction.Transpose(myRng.Columns(i).Value), vbNewLine)

のトコロを

　　For j = 1 To myRng.Rows.Count
　　　If myRng.Cells(j, i).Value <> "" Then objTS.WriteLine myRng.Cells(j, i).Value
　　Next j

に差し替えてみてください。

お礼

おかげさまで希望するところまでたどりつきました。
重ね重ねありがとうございました。

なお、またあとで聞き忘れが出てくるといけないので
しばらくの間閉めないでおきますのでよろしくお願いします。

回答No.9

DOUGLAS_

＞冒頭にある質問内にあるVBA
＞ここにテキスト書き出しをのせたらそのまま使える
　了解しました。

　しかし、「Sub closs()」の

Range("A1").Offset((myRng.Rows.Count) * (i - 1)).Resize(myRng.Rows.Count) _
　　= myRng.Columns(i).Value

という コード は、ワークシート上なればこそできることなので、

＞別のテキスト(EMEditor)への書き出し
＞あるいはクリップボードへの格納
＞EMEditor等別のテキストへの書き出し（その際ファイル名も付加）

というようなことになると、一旦 ワークシート に配置したものを再度 テキスト に書き出す、という冗長な操作になります。

　したがって、「Sub closs()」のような操作ではなくて、下記のようなことになろうかと存じます。

　なお、「ファイル名」は「矩形範囲の左上隅の セル の値」にしておりますので、ここを弄ってお好きな名前を付けてください。

↓「rectangle（矩形）を text に書き出す」という意味の名前を付けました。
Sub rectangle2text()
'変数の宣言
　Dim myRng As Range　　　　　'矩形範囲 の Range オブジェクト
　Dim objFSO As Object　　　　'FileSystemObject オブジェクト
　Dim strSaveFol As String　　'保存先フォルダ名
　Dim strFileName As String　 'ファイル名
　Dim strFullPath As String　 'ファイル の フルパス
　Dim objTS As Object　　　　 'TexobjTStream オブジェクト
　Dim i As Long　　　　　　　 '矩形範囲の列数

'矩形範囲を Range オブジェクト に格納
　Set myRng = Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight))

'オブジェクト の準備
　Set objFSO = CreateObject("Scripting.FileSystemObject")

'ファイル保存先フォルダの指定
　strSaveFol = "H:\"

'矩形範囲の左上隅の セル の値を ファイル名 に指定
　strFileName = myRng.Cells(1).Value

'ファイルのフルパスを設定
　strFullPath = strSaveFol & strFileName & ".txt"

'ファイルを作成
　Set objTS = objFSO.CreateTextFile(Filename:=strFullPath, Overwrite:=True)

'データの書き込み
　For i = 1 To myRng.Columns.Count
　　objTS.WriteLine Join(Application.WorksheetFunction.Transpose(myRng.Columns(i).Value), vbNewLine)
　Next i
　objTS.Close

　Set objTS = Nothing
　Set objFSO = Nothing
　Set myRng = Nothing
End Sub

お礼

お手数をおかけしてすみません。
集計についてはうまくできました。

ただA7にも書いておいたのですが、
※途中空白行（算式により空白にしている行）もそのままあいた形で表示されてしまうので行間をつめたい。
というのがやはり発生してしまうためこれを解決できるとありがたいです。

回答No.8

DOUGLAS_

＞全体配列については今回の質問で記述したVBAを活用し使い分けたい
とのことですが、「以前教えていただいた矩形の配列」というのが何のことか判然としません。

　ということで、それ以降にお書きのこともさっぱり理解できませんので、これも「超苦肉の策」ですが。。。

１）コード の中の３つの「"■*"」をすべて「strFind」に書き換えます。
２）「■■■【１】下準備」の前にでも、下記の コード を挿入してみてください。

　　Dim strFind As String
　　strFind = InputBox("全体(1) か ブロック(2) かを数字で選択してください。", "配列替え パターン の選択")
　　Select Case strFind
　　Case "1"
　　　strFind = "■*SD*"
　　Case "2"
　　　strFind = "■*"
　　Case Else
　　　MsgBox "選択が不正です"
　　　Exit Sub
　　End Select

お礼

正確な記述でなくてすみません。
今回の冒頭にある質問内にあるVBAは
q6887062A17
でDOUGLAS_様に教えていただいた複数列のデータ（矩形）を縦一列にするもので、応用する場合、対象データは矩形になっていることが条件ということを記憶していたのでそのような記述になってしまいました。
これなら■Find等はあっても関係なく、１行目からセルに空白のできる行まで配列できるのでこれを使用しようと思って、ここにテキスト書き出しをのせたらそのまま使えると思いました。
したがって、冒頭質問に対する修正でよろしいかと思います。

補足

お答えいただいた「超苦肉の策」により、配列はうまくゆきました。
ありがとうございました。
なお、冒頭質問に対する修正というのは、別のテキスト(EMEditor)への書き出しあるいはクリップボードへの格納を教えておいていただくと、A7のお礼欄にある趣旨のものに使えるとともに他の機会にも使えるのでこの際お尋ねをしておきました。
※冒頭質問の「例としてA列3の…」をEMEditor等別のテキストへの書き出し（その際ファイル名も付加）と置き換えてください。
（現時点では"貼り付け→Sheet2"になっている部分です）

回答No.7

DOUGLAS_

＞先頭に、そのsheetのA1に記述されている
＞文字列を入れたい

'開始位置にファイル名を格納
Range(Left(strCols, 1) & startRow).Value = strFileName

となっておりますので、「Range(Left(strCols, 1) & startRow)」に「strFileName」を格納してから「データの書き込み」を行なうようになっているのですが、「Range(Left(strCols, 1) & startRow)」にも「そのsheetのA1に記述されている文字列」を入れる場合は、

strFileName = Left(strFileName, 10) & strAddName

を

strFileName = range("A1").value & Left(strFileName, 10) & strAddName

に、「Range(Left(strCols, 1) & startRow)」には「そのsheetのA1に記述されている文字列」を入れずに、「ファィル名」にだけ「そのsheetのA1に記述されている文字列」を入れたい場合は、

strFullPath = strSaveFol & strFileName & ".txt"

を

strFullPath = strSaveFol & Range("A1").Value & strFileName & ".txt"

にしてください。

お礼

ありがとうございました。
ブロック集計のoutputについてはうまくゆきました。

問題点
今回のデータ（例411ch)については、全体配列替えと■で始まるブロック配列の両方を若干データ内容を修正の上で行っています。
全体配列替えとは途中に■が入っている行も含む最終データ（例A列100行）までの全部を配列するものです。
（途中空欄行はありません）
ブロック配列は■で始まる行の直前に空欄行を手動で挿入してブロックに分けて配列を行うものです。
（■ではじまる行をファイル名にしている。）
このブロック配列の方は今までご教示いただいた連続書き出しがうまく行きましたが全体配列の方は同じVBAを使った場合、■をFindにしているせいか、
A列の最後に■のある行からのスタートでの配列(例H列70行～）なってしまい、カーソルをおいたH列1行からの配列になってくれませんでした。

そこで全体配列については今回の質問で記述したVBA（以前教えていただいた矩形の配列）を活用し使い分けたいと思いますので、その中で下記の修正したい部分をお教えください。
※貼り付けシート名をEmEditorにするか、またはクリッブボード格納にしたい。
EMEditorに直接張り付ける場合のファイル名はH1に固定
（クリッブボードにした場合、直後に手動でEmEditorに張り付ける）
※途中空白行（算式により空白にしている行）もそのまま表示されてしまうのでこれをつめたい。

回答No.6

DOUGLAS_

＞Do Until endRow < FirstLineと■*を置き換えたらうまくゆきました。
　了解しました。

　ただ、
endRow = Columns(1).Find(What:="：■*", after:=～～
のところは「■」の前の「：」は不要ではないのですね。

＞カーソル位置から右の矩形を対象にする場合、
＞ここの列名を書き換えなくて済むようにできれば

　そうですね。
　本来なら、ご質問文内にある
Set myRng = Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight))
で片付けたいところですが、既存の「Sub Group_for_each_Title_Line～～」をいじった方が簡単でしょうから、
strCols = "HIJKLMNOP"
のところを、
strCols = Mid("ABCDEFGHIJKLMNOP", ActiveCell.Column)
にでもしてみましょうか。（超苦肉の策ですが。。。）

お礼

"：■*"は"■*"の転記ミスでした。
もうひとつ追加のお願いを忘れました。すみません。

ファィル名を生成する際、先頭に、そのsheetのA1に記述されている「110826SD420」(sheetごとに異なります）といった文字列を入れたいのですが、次の記述あたりに修正できるのでしょうか。
110826SD420■(10文字）＋追加文字がファイル名になります。

**********************
'ファイル名の入力
If Replace(Replace(DataChecker, vbCrLf, ""), "#VALUE!", "") <> "" Then
DataChecker = StrConv(startRow, vbWide) & "行目：「" & _
Left(strFileName, 10) & "」" & "に続く文字列を入力してください。" _
& vbCrLf & vbCrLf & "====================================================" & _
vbCrLf & vbCrLf & DataChecker
strAddName = InputBox(DataChecker, "ファイル名の入力", Mid(strFileName, 11, 100))
If strAddName = "" Then
MsgBox "ファイル名が入力されませんでしたので、終了します。"
GoTo Closing
Else
strFileName = Left(strFileName, 10) & strAddName
'開始位置にファイル名を格納
Range(Left(strCols, 1) & startRow).Value = strFileName
End If
End If
*************************************

回答No.5

DOUGLAS_

＞ちなみにこの"：*／"を"■"に書き換えてみたのですが、
＞VBAが砂時計のまま進まなくなってしまいました。
　そういう場合は、ＶＢＥ において [F8] キー により、ステップ イン デバッグ すると原因がよく判ります。

　つまり、

　　Do Until endRow = FirstLine
　　　TitleLines = TitleLines & " " & endRow
　　　endRow = Columns(1).FindNext(after:=Range("A" & endRow)).Row
　　Loop

で 無限ループ に陥っているのですね。

　それで、内容をよく吟味していないので分かりませんが、
Do Until endRow = FirstLine
ではなくて、
Do Until endRow < FirstLine
ではないかと思いますね。

　それと、
＞"：*／"を"■"に
ではなくて「■*」に書き換えた方がよいかと存じますが、さらに「■*SD*」の方が良いような気がいたします。

お礼

ありがとうございました。
Do Until endRow < FirstLineと■*を置き換えたらうまくゆきました。
（第２グループ以下の１行目はSDが入らないため「■*」だけにしました。）

そこでひとつ質問です。
VBAは次のとおり（途中まで）ですが
配列の対象がH～P列の場合と、I列～P列の場合があります。
そこで矩形の左上１セル目からスタートさせたい場合、下記のVBAでは
セル列をあらかじめ記述してしまっていますが、
カーソル位置から右の矩形を対象にする場合、ここの列名を書き換えなくて済むようにできればと思います。すなわちこの例だとH列からの場合とI列の場合の矩形になります。

'データ読み込み列の順列の設定
'▼書き出し列の増減・順序の変更はここで▼
strCols = "HIJKLMNOP"
***************************************
Sub Group_for_each_Title_Line0827A05()
'変数の宣言
Dim objFSO As Object 'FileSystemObject オブジェクト
Dim objTS As Object 'TexobjTStream オブジェクト
Dim g As Long 'グループカウンタ
Dim DataChecker As Variant 'グループの内容確認用のデータ
Dim strFullPath As String 'ファイル の フルパス
Dim strSaveFol As String '保存先フォルダ名
Dim strFileName As String 'ファイル名
Dim strAddName As String '追記文字

Dim strCols As String '列番号の順列
Dim TitleLines As Variant 'タイトル行番号の配列
Dim FirstLine As Long '第１開始行
Dim startRow As Long '開始行
Dim endRow As Long '終了行（一時流用）
Dim i As Integer '列カウンタ
Dim j As Long '行カウンタ

'Ａ列最終行より後のセルがアクティブのときは即終了
If ActiveCell.Row > Range("A" & Rows.Count).End(xlUp).Row Then
MsgBox "データがありませんので、終了します。"
Range("A1").Select
Exit Sub
End If

'■■■【１】下準備
'オブジェクト の準備
Set objFSO = CreateObject("Scripting.FileSystemObject")

'データ読み込み列の順列の設定
'▼書き出し列の増減・順序の変更はここで▼
strCols = "HIJKLMNOP"

'ファイル保存先フォルダの指定
strSaveFol = "H:\"

'■■■【２】タイトル行の割り出し
'第１開始行
FirstLine = Range("A1").End(xlDown).Row

'アクティブ行が FirstLine 未満の場合は検索開始行を FirstLine に
If ActiveCell.Row < FirstLine Then Range("A" & FirstLine).Select

'アクティブ行のＡ列が空白セルの場合は検索開始行を直下のタイトル行に
If Range("A" & ActiveCell.Row).Value = "" Then _
Range("A" & ActiveCell.Row).End(xlDown).Select

'アクティブ行がタイトル行の場合は、TitleLines に含め
'その他の場合は、上方向にタイトル行を探す
If Range("A" & ActiveCell.Row).Find("■*") Is Nothing Then
TitleLines = Columns(1).Find(What:="■*", after:=Range("A" & ActiveCell.Row), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:= _
xlPrevious, MatchCase:=False, SearchFormat:=False).Row
Else
TitleLines = ActiveCell.Row
End If

'以下、アクティブ行からＡ列最終行まで、タイトル行を探す
endRow = Columns(1).Find(What:="：■*", after:=Range("A" & ActiveCell.Row), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Row
Do Until endRow < FirstLine
TitleLines = TitleLines & " " & endRow
endRow = Columns(1).FindNext(after:=Range("A" & endRow)).Row
Loop

**********************************

補足

ファイル名の入力について
「A1&■＋１０文字＋続く文字」になるように作っていただいていますが
実際には「続く文字」というのはほとんどなく、A1＋各１行目がファイル名になります。
そしてこの１行目はファイル名に使うとき若干加工する必要があるため、
この１行目をテキストボックスにデフォルトであらかじめ表示させてこれを修正するようにできるとありがたいです。
（「○○特集」の「特集」を削除したり、長すぎタイトルを分かりやすく一部削除したりです）
ただ、「入力がないため終了」とあるので、デフォルトで入っていると終了する場合判断できなくなってしまいますね。
テキストボックスのデフォルトを全削除で終了というふうになりますか。

回答No.4

DOUGLAS_

＞矩形の配列替えは前回のとおりやってみて、
＞No1さんのご回答で無事できるようになりました。
とのことですので、こちらの問題には触らないようにします。

＞ANo.27,ANo.28と同じ作業
とのことですが、恐らく、
http://okwave.jp/qa/q6887062.html
の「Sub for_spacediva3」で作成した一覧表からの「配列替え」＆「ブロック ごとの テキスト 保存」ですよね？

http://okwave.jp/qa/q6129006.html
の「Sub Group_for_each_Title_Line」で問題なく動くようですが。。。

お礼

今までDOUGLAS_様に色々な質問をして、その都度ご回答をいただいたため
前後関係がやや不鮮明になりましたので自分なりに整理してみました。
◆１．ミュージックバードWEBからのデータ取得
q6129006A26/30
Sub Using_Web_query30A()
◆２．同データの配列替え
q6129006A30
Sub Group_for_each_Title_Line30B()

◆３．スペースディーバWEBからのデータ取得
q6887062A23-A26
Sub for_spacediva1A26()
◆４．同データの配列替え（上と同じ）
q6129006
Sub Group_for_each_Title_Line30B()

◆５．スターデジオWEBからのデータ取得
q6887062A15-A21
20110727確定A21
Sub use_XMLHTTP04()
◆６．同データの配列替え
q6939731

そこで今回のテーマは◆６．なのですが
矩形のグループは◆２．と類似なのでそのVBAを利用できると思ったのですが
できなかったのは、ファイル名取得の条件に

'その他の場合は、上方向にタイトル行を探す
If Range("A" & ActiveCell.Row).Find("：*／") Is Nothing Then
TitleLines = Columns(1).Find(What:="：*／", after:=Range("A" & ActiveCell.Row), _

の"：*／"が今回の場合はないということなのかもしれません。
タイトルに代用される１行目はデータの中にも登場するように■ではじまる文字列になっています。
（そのほかはスタート位置を変更すること以外はほぼ同じだと思います）
そのために
「ブロック ごとの テキスト 保存」ですよね？
ができないのではないかと思いました。
ちなみにこの"：*／"を"■"に書き換えてみたのですが、VBAが砂時計のまま進まなくなってしまいました。

回答No.3

DOUGLAS_

＃残暑お見舞い申しあげます。精力的に活動されているようですね。

＞例としてA列3行～F列20行を１グループとして
＞縦１列に配列替えをしてテキストに出力する。
　これは、まぁ理解できますが、
＞マウスによるカーソル位置をデータトップのA3
＞またはそれより上の空欄において実行する。
というのは、具体的にはどのような操作でしょうか？

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

＞グループの途中（例A21～F24）を空欄（関数式なし）として
＞次のグループが存在し、グループか存在する場合
＞同じ作業を繰り返し

　そもそも、「Sub closs()」において
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight))
としていらっしゃるところを見ると、予め マウス で アクティブセル を決めておいてから「Sub closs()」を走らす、というような段取りで作業を進めていらっしゃるようですが、マクロ で自動化するということになると、
・予め決めておいた ルール に沿って グループ を配置する
か
・既にある グループ の配置状態から ルール を見つけ出す
のいずれかにより、「グループ の先頭行番号を決定する ルール」を見出すことが必要です。

　例えば、「Ｆ列においては、グループ内 は必ず データ が途切れないし、かつ、グループ でないところの Ｆ列 は、絶対に空 "" になっている」ということであれば、下記のようなことで、[貼り付け] シート に グループ ごとに１列ずつ書き出すことはできます。

Sub closs()
　Dim myRng As Range
　Dim myStart As Range
　Dim i As Long
　Sheets("データシート").Select
　Set myStart = Range("F:F").Find("*")
　Do
　　Set myRng = Range(myStart.End(xlToLeft), myStart.End(xlDown).End(xlToRight))
　　Sheets("貼り付け").Select
　　For i = 1 To myRng.Columns.Count
　　　Range("A1").Offset((myRng.Rows.Count) * (i - 1)).Resize(myRng.Rows.Count) _
　　　　= myRng.Columns(i).Value
　　Next
　　Set myStart = myStart.End(xlDown).End(xlDown)
　　If myStart.Row = Rows.Count Then Exit Do
　　Columns(1).Insert
　Loop
End Sub

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

＞別のテキストにoutputする。
＞"貼り付け"を外部ソフトのテキストに張り付けるには
＞どのような記述になりますでしょうか。
　これは「EmEditor」のことですか？

　まぁ、いずれにいたしましても、
●エクセルマクロで外部ファイルを開きたい
http://okwave.jp/qa/q6129006_6.html
あたりを再度じっくりとお読みください。

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

＞列を増やしたい場合の対応もできるようにしておく。
につきましては、１つの グループ が完全な矩形であるのなら、
～～～.End(xlDown).End(xlToRight)
の部分で、下方向・右方向の端を捕まえていますので、列が増えても問題はないかと存じます。

お礼

こんにちわ
再度お目に止まっていただいて光栄です。
前回ご教示いただきながら、この部分だけうっかり確認しないまま終わってしまったためあとから試したらうまくゆかなくて困っていたところでしたので再質問させていただいた次第です。

なお、当方インターネット障害でしばらくの間NETができずご返事遅れてすみませんでした。

矩形の配列替えは前回のとおりやってみて、No1さんのご回答で無事できるようになりました。
基本的にたとえばH列1－20行～P列１－20行（当初A列～F列で質問しましたが）を１グループとしVBAを走らせる時にH1にカーソルをおいて実行するとH～P列を配列替えの対象とし、I列1行にカーソルを置いたときはI列～P列が対象になればいいのです。
H列より左のセルは空欄（算式が存在）でない場合がありますが、P列より右（Q以降）は空白セル（算式なし）になります。
またH21行～P21行は算式なしの空白行が存在し、H22から次のグループが存在します。

この作業は前回教えていただいた質問欄にあるVBAで「データシート」、「貼り付け」を修正することでとりあえずうまく行くことがわかりました。

そこで追加質問だったのですが、上記例のようにグループが２つ以上ある場合はその都度EMeditorにファイル名を入れて書き出して、次のグループ（スタート位置はその都度手動でカーソルをおく）に移行したいと思いました。
以前に教えていただいたANo.27,ANo.28と同じ作業なのですがフォームが合致しないのかそのマクロで代用してやってみてもうまくゆかなかったので、質問にあるVBAでやってみたいと思っています。

この説明でうまくご理解いただけたでしょうか

回答No.2

piroshi999

>Sheets("データシート").Select

これで止まるってことは、単純にシート名を「データシート」って変えれば済むんじゃないですか？

お礼

「データシート」の意味がわからなかったのでとまどっていた次第です。
（VBAは詳しくないため教わったまま動かしていました）
ご指摘どおり名前の記述を「Sheet1」あるいは"貼り付け"も「Sheet2」に直したらできるようになりました。""はファイル名だったんですね。
ありがとうございました。

なお"貼り付け"を外部ソフトのテキストに張り付けるにはどのような記述になりますでしょうか。

回答No.1

doara_2011

当方、Excel2010と2003で実際に実行してみましたが、
普通に実行できました。(プログラムは一字一句変えてません)
どこで止まってしまったと言うのでしょうか？

＞※マウスによるカーソル位置をデータトップのA3またはそれより上の空欄において実行する。
なんて書いてますが、セルのA3より上の空欄をアクティブにして実行してはダメです。
A3をアクティブにして実行しましょう。

お礼

ありがとうございます。
データのあるTOP(A3)において実行すると

実行エラー時 9
インデックスが有効範囲にありません。

と出てしまい、デバッグでは次の位置で止まっています。

Sheets("データシート").Select

なおエクセルは2010で行いました。