[[20150114141815]]　『並び替えについて』（sarara）　ページの最後に飛ぶ

『並び替えについて』（sarara）

並び替えについて教えてください。

SHeet1に下記のような一覧表があります。

番号　　氏名１　氏名２　氏名３　出張名　　旅費　旅費　旅費

１　　　山本　　田中　　清水　　視察　　　10,000　　10,000　 10,000
２　　　安部　　空白　　空白　　研修　　　 5,000 　　　 0　　　　　0
３　　　中村　　福島　　空白　　会議　　　 3,000　　3,000　　　　0
・　　　　　・　　　・　　　　　・　　　　　・　　　　　・　・
・　　　　　・　　　・　　　　　・　　　　　・　　　　　・　　　　・

氏名が３列に渡っているのを、Sheet2へ下記のように氏名を１列にまとめたいと考えています。

空白のセルは詰めて、まとめたいのですが、自動記録やVBAで一発で並び替える方法はありますか？

番号　　氏名　　出張名　　旅費

１　　　山本　　視察　　　10,000　
１　　　田中　　視察　　　10,000
１　　　清水　　視察　　　10,000
２　　　安部　　研修　　　 5,000
３　　　中村　　会議　　　 3,000
３　　　福島　　会議　　　 3,000
・　　　　・　　　　　・　　　　・　　　
・　　　　・　　　　　・　　　　・　　　

＜使用 Excel：Excel2007、使用 OS：Windows7 ＞

 単純にループ！
    Sub aaa()
        Dim a
        Dim ans
        Dim i As Long
        Dim j As Long
        Dim n As Long
        n = 2
        a = Range("A1").CurrentRegion.Value
        ReDim ans(1 To UBound(a, 1) * 3, 1 To 4)
        ans(1, 1) = a(1, 1)
        ans(1, 2) = Left(a(1, 2), 2)
        ans(1, 3) = a(1, 5)
        ans(1, 4) = a(1, 6)
        For i = 2 To UBound(a, 1)
            For j = 2 To 4
                If a(i, j) <> "" Then
                    ans(n, 1) = a(i, 1)
                    ans(n, 2) = a(i, j)
                    ans(n, 3) = a(i, 5)
                    ans(n, 4) = a(i, j + 4)
                    n = n + 1
                Else
                    Exit For
                End If
            Next j
        Next i
        With Sheets.Add
            .Range("A1").Resize(UBound(ans, 1), 4).Value = ans
        End With
    End Sub

（稲葉） 2015/01/14(水) 15:50

稲葉様

ありがとうございました！

うまく並び替え出来ました＾＾
（sarara） 2015/01/14(水) 22:40

すみません。
番号と氏名の間に月日を入れた場合の並び替えを教えていただけないでしょうか。

番号　月日　　氏名１　氏名２　氏名３　出張名　　旅費　旅費　旅費

１　　4/1　　　山本　　田中　　清水　　視察　　　10,000　　10,000　 10,000
２　　5/1　　　安部　　空白　　空白　　研修　　　 5,000 　　　 0　　　　　0
３　　6/1　　　中村　　福島　　空白　　会議　　　 3,000　　3,000　　　　0

　　　　　　　　↓

番号　月日　　　氏名　　出張名　　旅費

１　　　4/1　　　山本　　視察　　　10,000　
１　　　4/1　　　田中　　視察　　　10,000
１　　　4/1　　　清水　　視察　　　10,000
２　　　5/1　　　安部　　研修　　　 5,000
３　　　6/1　　　中村　　会議　　　 3,000
３　　　6/1　　　福島　　会議　　　 3,000

（sarara） 2015/01/14(水) 23:10

 簡単なループ処理です
 まずご自身で書き換えてみてください
 そうすれば仕様変更にも自分で対応できるようになりますよ！
 解らなければ、なにをどうしたけど、求める結果を得られなかったなど
 し質問していただければ、お答えいたします
（稲葉） 2015/01/15(木) 07:10

コードの意味が分からなかったので、私なりに調べましたが
今ひとつ分かりませんでした（泣）
稲葉さんが書いてくれたそれぞれのコードがどういう動作をし、
どういう結果になるのかが分かれば、多少は分かると思うのですが・・

（sarara） 2015/01/15(木) 13:40

 Range("A1").CurrentRegion.Value
 A1を選択して、Ctrl+Shift+:　を押したときの動作です。
 iは行のループ
 jは列のループを表しています。

    Sub aaa()
        Dim a
        Dim ans
        Dim i As Long
        Dim j As Long
        Dim n As Long
        n = 2
        a = Range("A1").CurrentRegion.Value
        ReDim ans(1 To UBound(a, 1) * 3, 1 To 5)
        ans(1, 1) = a(1, 1)
        ans(1, 2) = a(1, 2)
        ans(1, 3) = Left(a(1, 3), 2)
        ans(1, 4) = a(1, 6)
        ans(1, 5) = a(1, 7)
        For i = 2 To UBound(a, 1)
            For j = 3 To 5
                If a(i, j) <> "" Then
                    ans(n, 1) = a(i, 1)
                    ans(n, 2) = a(i, 2)
                    ans(n, 3) = a(i, j)
                    ans(n, 4) = a(i, 6)
                    ans(n, 5) = a(i, j + 4)
                    n = n + 1
                Else
                    Exit For
                End If
            Next j
        Next i
        With Sheets.Add
            .Range("A1").Resize(UBound(ans, 1), 5).Value = ans
        End With
    End Sub

（稲葉） 2015/01/15(木) 14:06

項目をもう一つ増やしたく、いろいろとコードをいじりましたが、うまくいきませんでした・・・
再度、ご教授いただけないでしょうか・・

番号　月日　　氏名１　氏名２　氏名３　用務先　　出張名　　旅費　旅費　旅費

１　　4/1　　　山本　　田中　　清水　　東京　　　　視察　　　10,000　　10,000　 10,000
２　　5/1　　　安部　　空白　　空白　　大阪　　　　研修　　　 5,000 　　　 0　　　　　0
３　　6/1　　　中村　　福島　　空白　　名古屋　　　会議　　　 3,000　　3,000　　　　0

番号　月日　　　氏名　　　出張先　　出張名　　旅費

１　　　4/1　　　山本　　東京　　　　　視察　　　10,000　
１　　　4/1　　　田中　　東京　　　　　視察　　　10,000
１　　　4/1　　　清水　　東京　　　　　視察　　　10,000
２　　　5/1　　　安部　　大阪　　　　　研修　　　 5,000
３　　　6/1　　　中村　　名古屋　　　会議　　　 3,000
３　　　6/1　　　福島　　名古屋　　　会議　　　 3,000

Sub aaa()

        Dim a
        Dim ans
        Dim i As Long
        Dim j As Long
        Dim n As Long
        n = 2
        a = Range("A1").CurrentRegion.Value
        ReDim ans(1 To UBound(a, 1) * 3, 1 To 6)
        ans(1, 1) = a(1, 1)
        ans(1, 2) = a(1, 2)
        ans(1, 3) = Left(a(1, 3), 2)
        ans(1, 4) = a(1, 6)
        ans(1, 5) = a(1, 7)
        ans(1, 6) = a(1, 8)
        For i = 2 To UBound(a, 1)
            For j = 3 To 6
                If a(i, j) <> "" Then
                    ans(n, 1) = a(i, 1)
                    ans(n, 2) = a(i, 2)
                    ans(n, 3) = a(i, j)
                    ans(n, 4) = a(i, 6)
                    ans(n, 5) = a(i, j + 4)
                    ans(n, 6) = a(i, 7)
                    n = n + 1
                Else
                    Exit For
                End If
            Next j
        Next i
        With Sheets.Add
            .Range("A1").Resize(UBound(ans, 1), 6).Value = ans
        End With
    End Sub

（sarara） 2015/01/15(木) 16:34

 仕様変更がないように、そちらを固めてから再度質問してください。
（稲葉） 2015/01/16(金) 08:28

稲葉様

何度もすみません。
仕様としてはこれが最終の形になります。
コードを見ながら勉強したいと思います。
よろしくお願いいたします。

番号　月日　　氏名１　氏名２　氏名３　出張先　　出張名　　旅費　旅費　旅費

　　　　　　　　　　　　↓

番号　月日　　　氏名　　　出張先　　出張名　　旅費

（sarara） 2015/01/16(金) 09:33

    Sub aaa()
        Dim a
        Dim ans
        Dim i As Long
        Dim j As Long
        Dim n As Long
        n = 2
        a = Range("A1").CurrentRegion.Value
        ReDim ans(1 To UBound(a, 1) * 3, 1 To 6)
        ans(1, 1) = a(1, 1)
        ans(1, 2) = a(1, 2)
        ans(1, 3) = Left(a(1, 3), 2)
        ans(1, 4) = a(1, 6)
        ans(1, 5) = a(1, 7)
        ans(1, 6) = a(1, 8)
        For i = 2 To UBound(a, 1)
            For j = 3 To 5
                If a(i, j) <> "" Then
                    ans(n, 1) = a(i, 1)
                    ans(n, 2) = a(i, 2)
                    ans(n, 3) = a(i, j)
                    ans(n, 4) = a(i, 6)
                    ans(n, 5) = a(i, 7)
                    ans(n, 6) = a(i, j + 5)
                    n = n + 1
                Else
                    Exit For
                End If
            Next j
        Next i
        With Sheets.Add
            .Range("A1").Resize(UBound(ans, 1), 6).Value = ans
        End With
    End Sub
（稲葉） 2015/01/16(金) 09:48

稲葉様

本当にありがとうございました！
助かりましたm(_ _)m
これを機にVBAの勉強をしたいと思います。
（sarara） 2015/01/16(金) 09:53

こんにちは

解決しちゃいましたけど、手作業的な処理をVBAで書く場合のコードです。

Sub test()

    Dim sh1   As Worksheet
    Dim sh2   As Worksheet
    Dim i     As Long
    Dim j     As Long
    Dim r     As Range

    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")

    Application.ScreenUpdating = False

    sh2.UsedRange.Delete

    sh1.Range("H1").Value = "旅費1"
    sh1.Range("I1").Value = "旅費2"
    sh1.Range("J1").Value = "旅費3"

    Set r = sh1.Range("A1").CurrentRegion

    j = 1
    For i = 1 To 3
        sh1.Range("A1:B1").Copy sh2.Range("A" & j)
        sh1.Range("F1:G1").Copy sh2.Range("D" & j)
        sh1.Cells(i + 2).Copy sh2.Range("C" & j)
        sh1.Cells(1, i + 7).Copy sh2.Range("F" & j)
        r.AdvancedFilter xlFilterCopy, , sh2.Range("A" & j).Resize(, 6)
        If i > 1 Then
            sh2.Range("A" & j).Resize(, 6).Delete xlShiftUp
        End If
        j = sh2.Range("A1").CurrentRegion.Rows.Count + 1
    Next
    sh1.Range("H1:J1").Value = "旅費"
    sh2.Range("C1").Value = "氏名"
    sh2.Range("F1").Value = "旅費"
    On Error Resume Next
    sh2.Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    sh2.Range("A1").CurrentRegion.Sort _
        Key1:=sh2.Range("A1"), Order1:=xlAscending, _
        Key1:=sh2.Range("B1"), Order1:=xlAscending, Header:=xlYes

    Application.ScreenUpdating = True

End Sub

（ウッシ） 2015/01/16(金) 10:19

ウッシ様

ありがとうございます。

皆さんすごいですね！
パッと解決されてしまうので、職場にいてくれたらなあといつも思います。
またよろしくお願いいたします。
（sarara） 2015/01/16(金) 12:16

 なるほど
 手作業をVBAに表すって方法も面白いですね！

    Sub bbb()
        Dim r As Range
        Dim LR As Long
        Dim WS As Worksheet
        Set WS = ActiveSheet
        With Sheets.Add
            WS.Range("A1").CurrentRegion.Copy .Range("A1")
            Set r = .Range("J2", .Range("A" & Rows.Count).End(xlUp))
            r.Copy .Range("A" & Rows.Count).End(xlUp).Offset(1)
            r.Copy .Range("A" & Rows.Count).End(xlUp).Offset(1)
            .Range("J2", .Range("A" & Rows.Count).End(xlUp)).Sort .Range("A2"), xlAscending

            Set r = .Range("K2:L" & .Range("A" & Rows.Count).End(xlUp).Row)
            r.Offset(, 0).Resize(, 1).Formula = "=SUBSTITUTE(INDEX(C2:E2,,MOD(ROW()+1,3)+1),""0"","""")"
            r.Offset(, 1).Resize(, 1).Formula = "=INDEX(H2:J2,,MOD(ROW()+1,3)+1)"
            r.Value = r.Value
            .Range("L2", .Range("A" & Rows.Count).End(xlUp)).Sort .Range("K2"), xlAscending
            .Range(.Range("A" & Rows.Count).End(xlUp), .Range("K" & Rows.Count).End(xlUp).Offset(1)).EntireRow.Delete

            LR = .Range("A" & Rows.Count).End(xlUp).Row
            .Range("C2:C" & LR).Value = .Range("K2:K" & LR).Value
            .Range("H2:H" & LR).Value = .Range("L2:L" & LR).Value
            .Range("I:L").Delete
            .Range("D:E").Delete

            .Range("J2", .Range("A" & Rows.Count).End(xlUp)).Sort .Range("A2"), xlAscending
        End With
    End Sub

 自分には余計難しくなりました・・・
 Deleteの処理とかずれる
（稲葉） 2015/01/16(金) 13:30

コメント返信：

[ 一覧(最新更新順) ]

[[20150114141815]] 『並び替えについて』（sarara） ページの最後に飛ぶ

[[20150114141815]]　『並び替えについて』（sarara）　ページの最後に飛ぶ