【EXCEL】複数行を1行に

質問

エクセルにまだまだ不慣れなもので、質問させてください。
下の図《1》のようなデータが大量にあります。CSV形式に出力したいのですが《2》のように並べ替えなければいけませんよね？(←ここら変の知識も未熟なものですみません。。)
《1》のようなデータを《2》のような並びにする事は可能でしょうか？
ちなみに《1》のようなデータは、一行ずつ空白行をはさみ、下まで何百件も並んでいます。また、1データの行数もランダムです。

何か良い方法がありましたら是非ご教授下さい。よろしくお願い致します。

《1》
A 　B 　　C 　　D 　　E 　　F
1　●●
2　■■
3　▲▲
4　◎◎

《2》
A 　　B 　C 　D 　E 　 F
1　●● ■■ ▲▲ ◎◎
2
3
4

回答No.8

Wendy02

こんばんは。Wendy02です。

使わないかもしれませんが、マクロで考えてみました。基本的なエラー処理は含めています。

●●
■■
▲▲
～改行～
○○
□□
△△

以下のようにCSVに出力される

　 Ａ　Ｂ　Ｃ　Ｄ　Ｅ　Ｆ

1　●　●　■　■　▲　▲
2　○　○　□　□　△　△

あくまでも、2列が条件で、変換して256列の単位を越えるものは、出力されません。また、保存される、CSVのファイル名は、元のブックの名称が使用されます。

'なるべく標準モジュールに登録してください。
'----------------------------------------------------------
'Option Explicit

Sub TransposedCSVOut()
　'2列-数行をまとめて、横に変換して出力する
　Dim tmpSht As Worksheet
　Dim AcSht As Worksheet
　Dim myRng As Range
　Dim myArea As Range
　Dim i As Long, j As Integer, k As Integer
　Dim Ar As Range, c As Range
　Dim SaveName As String

　'保存名は、現在のブックの名前を使用します。
　'ただし、同名のCSVファイルがある場合は、枝番がつきます。
　With ActiveWorkbook
　　SaveName = Mid$(.Name, 1, InStrRev(.Name, ".") - 1)
　End With

　Application.ScreenUpdating = False

　Set AcSht = ActiveSheet
　With AcSht
　 '2列の設定は、Resize(,2)
　　Set myRng = .Range("A1", .Range("A65536").End(xlUp)).Resize(, 2)
　End With
　'定数すべて選択
　Set myArea = myRng.SpecialCells(xlCellTypeConstants, 23)

　With ActiveWorkbook
　　Set tmpSht = .Worksheets.Add(After:=.Sheets(.Worksheets.Count))
　End With

　i = 1
　'注意：空白行のない場合は、途中で中断されます。

　For Each Ar In myArea.Areas

　　With Ar
　　 '行が、128行以上では、縦横変換で256列には収まらない
　　　If Ar.Rows.Count > 128 Then
　　　　If MsgBox("変換時に256列越えていますので、排出されません。" & vbCrLf & _
　　　　　"OK =スキップして継続, Cancel = 中止", vbInformation + vbOKCancel + vbDefaultButton2) = vbCancel Then
　　　　　Application.DisplayAlerts = False
　　　　　tmpSht.Delete
　　　　　SaveName = ""
　　　　　Application.DisplayAlerts = True
　　　　　GoTo Quit
　　　　End If
　　　Else
　　　　If WorksheetFunction.CountA(.Cells) > 0 Then
　　　　　For Each c In Ar.Cells
　　　　　　k = k + 1
　　　　　　c.Copy tmpSht.Cells(i, k)
　　　　　Next c
　　　　　i = i + 1
　　　　End If
　　　End If
　　End With
　　k = 0
　Next Ar
　Application.CutCopyMode = False

　If i < 2 Then
　　Application.DisplayAlerts = False
　　tmpSht.Delete
　　SaveName = ""
　　Application.DisplayAlerts = True
　　GoTo Quit
　End If
　tmpSht.Move

　'枝番付け
　Do While Dir(SaveName & ".csv") <> ""
　　If InStrRev(SaveName, "_") > 0 Then
　　　SaveName = Mid$(SaveName, 1, InStrRev(SaveName, "_") - 1)
　　End If
　　j = j + 1
　　SaveName = SaveName & "_" & CStr(j)
　Loop

　'CSV 保存
　ActiveWorkbook.SaveAs SaveName, FileFormat:=xlCSV
　ActiveWorkbook.Close False
Quit:
　AcSht.Select
　Application.ScreenUpdating = True

　If SaveName <> "" Then
　　MsgBox "このブックと同じフォルダに " & SaveName & ".csv で、保存されました。", vbInformation
　Else
　　MsgBox "出力に失敗しました。", vbCritical
　End If

　Set Ar = Nothing
　Set tmpSht = Nothing
　Set myArea = Nothing
　Set myRng = Nothing
　Set AcSht = Nothing
End Sub
'----------------------------------------------------------

お礼

マクロはこれから勉強していこうと思っております。説明して頂きましてどうもありがとう御座いました！