[[20181010233142]]　『縦一列にしたい。』（mayumi）　ページの最後に飛ぶ

『縦一列にしたい。』（mayumi）

今とても困っている作業があります。

具体的に申しますと、

あいうえお
かきくけこ
さしすせそ
たちつてと
なにぬねの
はひふへほ

となっているものを、

（空白セル）
あ
か
さ
た
な
は
（空白セル）
い
き
し
ち
に
ひ
（空白セル）
う
く
す
つ
ぬ
ふ
（空白セル）

という感じで、毎日200以上の処理をシているのですが、とても大変で、なにか簡単にできる方法はございませんか？

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

「あいうえお」
これは１つのセルにですか？

それとも

 A　 B　 C　 D　 E
あ　い　う　え　お
ですか？

（名無し） 2018/10/10(水) 23:57

名無しさんが確認されているように、複数行、複数列を１列に直したいということであれば、似たような話が過去に投稿されてましたね。
[[20180907131433]]『表をリストに変換する方法』（かんがえすぎ）

そして、↑でも、同様の趣旨のコメントをしたかとおもいますが、マクロでもＯＫというのであれば、こんなコードで実現できるようにおもいます。（未テストなのでミスってたらごめんなさい）

    Sub 選択範囲を１列に変換()
        Dim i As Long
        With Selection
            If .Columns.Count < 2 Then Exit Sub
            For i = 2 To .Columns.Count
                .Columns(i).Copy .Cells(1).Offset((i - 1) * .Rows.Count + 1)
            Next i
            Intersect(.Cells, .Cells.Offset(, 1)).Clear
        End With
    End Sub

（もこな２） 2018/10/11(木) 01:01

Sub main()
'「あいうえお」が１つのセルの場合の例
'Sheet1からSheet2に展開

    Dim dt As Variant, c As Range, r As Range, k As Variant, i As Long, x As Long, y As Long
    Sheets("Sheet2").Cells.ClearContents
    For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
        If Len(c.Value) > y Then y = Len(c.Value)
        x = x + 1
    Next c
    ReDim dt(x, 1 To y)
    For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
        For i = 1 To y
            dt(c.Row, i) = Mid(c.Value, i, 1)
        Next i
    Next c
    Set r = Sheets("Sheet2").Range("A1")
    For Each k In dt
        r.Value = k
        Set r = r.Offset(1)
    Next k
End Sub

（mm） 2018/10/11(木) 10:03

 データ範囲が A1:E6 のデータだと解釈して、G列に表示させる方法

 G1:=IFERROR(INDEX($A$1:$E$6,MOD(ROW(),7),INT(ROW()/7)+1),"")

 これをG2以下にフィル　ではいかがでしょう？

（jimihen） 2018/10/11(木) 15:22

 一セルに[あいうえお] 対応　＾＾
何でも回せばいいと思い込んでいる老人。。。反省して　MAX（LEN(　～　））とかしたかった
けど挫折しました　＾＾；；；

 Option Explicit
Sub main()
    Dim i As Long, j As Long, buf(), rr As Range, r As Range, cnt As Long, k As Long
    With Worksheets("Sheet1")
        Set rr = .Range("A1").CurrentRegion
        j = 2
        For Each r In rr
            ReDim Preserve buf(i)
            buf(i) = Len(r)
            i = i + 1
        Next
        k = WorksheetFunction.Max(buf)
        Erase buf
    End With
    Workbooks.Add
    With ActiveSheet
        For i = 1 To k
            For Each r In rr.Rows
                If i <= Len(r) Then
                    ReDim Preserve buf(cnt)
                    buf(cnt) = Mid(r, i, 1)
                    cnt = cnt + 1
                End If
            Next
            .Cells(j, 1).Resize(UBound(buf) + 1, 1) = WorksheetFunction.Transpose(buf)
            j = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
            cnt = 0
            Erase buf
        Next
    End With
End Sub
（隠居じーさん） 2018/10/11(木) 15:59

 あいうえお、又は全てが単一セルにある場合

 Sub test()
     Dim myLen As Long, txt As String, x, i As Long, n As Long
     myLen = [max(len(trim(a1:a10000)))]: n = 1
     txt = Join(Filter([transpose(if(a1:a10000<>"",a1:a10000))], False, 0), vbLf)
     With CreateObject("VBScript.RegExp")
         .Global = True: .MultiLine = True
         .Pattern = "^" & Application.Rept("(.)?", myLen)
         For i = 1 To myLen
             x = Split(.Replace(txt, "$" & i), vbLf)
             If Len(Join(x, "")) = 0 Then Exit For
             Cells(n, "e").Resize(UBound(x) + 1).Value = _
             Application.Transpose(x)
             n = n + UBound(x) + 2
         Next
     End With
 End Sub
（seiya） 2018/10/11(木) 17:03

Sub main2()
'簡素化
'「あいうえお」が１つのセルの場合の例
' Sheet1からSheet2に展開

    Dim c As Range, r As Range, i As Long
    Sheets("Sheet2").Cells.ClearContents
    Set r = Sheets("Sheet2").Range("A2")
    Do
        flg = False
        For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
            r.Value = Mid(c.Value, i + 1, 1)
            If r.Value <> "" Then flg = True
            Set r = r.Offset(1)
        Next c
        i = i + 1
        Set r = r.Offset(1)
    Loop While flg = True
End Sub
（mm） 2018/10/11(木) 17:26

すみません。お返事が遅くなりました。ありがとうございました。
ですが、、、実行したあとに気づいたのですが、、、各セルに塗りつぶしの色がされており、皆様をそれぞれ試してみたのですが、塗りつぶしがリセットされています。。。

それと皆様を困惑させてしまったようで大変申し訳ありません。

あいうえお
ですが、
A1に「あ」
B1に「い」
C1に「う」
D1に「え」
E1に「お」
でございます。

（mayumi） 2018/10/15(月) 20:19

あぁ、2018/10/11(木) 01:01のコードミスってますね。・・・・
とりあえず、修正版です。

    Sub 選択範囲を1列に変換_修正版()
        Dim i As Long
        With Selection
            If .Columns.Count < 2 Then Exit Sub
            For i = 2 To .Columns.Count
                .Columns(i).Copy .Cells(1).Offset((i - 1) * (.Rows.Count + 1))
            Next i
            Intersect(.Cells, .Cells.Offset(, 1)).Clear
        End With
    End Sub

そして、
おっしゃるとおりだと、データとしてはこんな感じですよね。

 __A___B___C___D___E___ 
 1 あ  い  う  え  お
 2 か  き  く  け  こ
 3 さ  し  す  せ  そ
 4 た  ち  つ  て  と
 5 な  に  ぬ  ね  の
 6 は  ひ  ふ  へ  ほ

その上で、
＞各セルに塗りつぶしの色がされており、皆様をそれぞれ試してみたのですが、塗りつぶしがリセットされています
とのことですが、私のコードでもだめでしたか？
セルをそのままコピーしてるので普通なら塗りつぶしも一緒にコピーされるとおもいますが・・・・
もしかして、条件付き書式で塗りつぶしとかしてませんか？

（もこな２） 2018/10/15(月) 22:55

返信有難うございます。
もこな２さんがおっしゃる通りに条件付き書式設定で塗りつぶし設定をしています。
これがダメなのでしょうか。

何か方法があるものでしょうか？
（mayumi） 2018/10/15(月) 23:17

わかりました！
まずは、先にVBAで該当セルに色を付ければ、うまくいきました！
（mayumi） 2018/10/16(火) 14:21

コメント返信：

[ 一覧(最新更新順) ]

[[20181010233142]] 『縦一列にしたい。』（mayumi） ページの最後に飛ぶ

[[20181010233142]]　『縦一列にしたい。』（mayumi）　ページの最後に飛ぶ