エクセルVBAで複数列データを１列に配列替えする方法

質問

• エクセルVBAを使用して複数列のデータを縦１列に配列替えする方法について教えてください。
• 具体的なVBAコードを提供して頂けると助かります。
• また、複数の列を配列替えするときに、グループごとに別のテキストに出力したい場合の方法も教えてください。

回答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＋各１行目がファイル名になります。
そしてこの１行目はファイル名に使うとき若干加工する必要があるため、
この１行目をテキストボックスにデフォルトであらかじめ表示させてこれを修正するようにできるとありがたいです。
（「○○特集」の「特集」を削除したり、長すぎタイトルを分かりやすく一部削除したりです）
ただ、「入力がないため終了」とあるので、デフォルトで入っていると終了する場合判断できなくなってしまいますね。
テキストボックスのデフォルトを全削除で終了というふうになりますか。