Excelで、


[田中] | [鈴木] | [一郎] | [花子]
[木村] | [木村] | [佐藤] |
[花子] | [鈴木] | [一郎] | [田中]
[加藤] | [畑山] | [三郎] | [桜子]
[木村] | [佐藤] | [次郎]
[山本] | [川村] | [弥生]
[三郎] | [畑山] | [加藤] | [桜子]
[川村] | [弥生] |
[鈴木] | [一郎] | [田中] | [花子]
[畑山] | [加藤] | [三郎] | [桜子]
[木村] | [佐藤] |
[川村] | [弥生] | [山本]
[次郎] | [木村] | [佐藤] | [次郎]
[桜子] | [畑山] | [加藤] | [三郎]
[一郎] | [鈴木] | [田中] | [花子]

のようになっているファイル(実際には行数がもっと多いです)で、
重複している部分を整理し、

[田中] | [鈴木] | [一郎] | [花子]
[木村] | [佐藤] | [次郎]
[加藤] | [畑山] | [三郎] | [桜子]
[山本] | [川村] | [弥生]

のようにさせたいのですが、

ソート機能でうまくいきません。

良いやり方がありましたらご教授ください。よろしくお願いします。

回答の条件
  • URL必須
  • 1人5回まで
  • 登録:2007/06/10 04:03:29
  • 終了:2007/06/10 20:05:37

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692007/06/10 11:57:24

ポイント100pt

マクロを作りました。

まず、この表をどう判断するかなんですが、行ごとに特定のグループにわかれていて

グループから二人とか三人の組み合わせが行として列挙されている表であると解釈し

最終的にグループを列挙すればいいと判断しました。

マクロでやっていることは横にソートして重複している名前を消し

4人の行から同じ行を消すということです。

ネストが複雑になっているので見づらくてすいません。

Sub MacroGroup()
    Dim myRow As Long
    Dim i As Integer
    Dim j As Long
    Dim k As Long
    Dim bl As Boolean
    
    myRow = 1
    While Cells(myRow, 1).Value <> ""
        '横にソートします
        Range(Cells(myRow, 1), Cells(myRow, 4)).Sort Key1:=Range(Cells(myRow, 1), Cells(myRow, 4)), Orientation:=xlLeftToRight
        
        '重複する名前を消します
        For i = 2 To 4
            If Cells(myRow, i - 1).Value = Cells(myRow, i).Value And Cells(myRow, i).Value <> "" Then
                Cells(myRow, i).Delete Shift:=xlToLeft
                i = i - 1
            End If
        Next
        myRow = myRow + 1
    Wend
        
    j = 1
    myRow = 1
    While Cells(myRow, 1).Value <> ""
        If Cells(myRow, 4).Value <> "" Then
            bl = True
            For k = 1 To j
                If Cells(k, 1).Value = Cells(myRow, 1).Value And _
                    Cells(k, 2).Value = Cells(myRow, 2).Value And _
                    Cells(k, 3).Value = Cells(myRow, 3).Value And _
                    Cells(k, 4).Value = Cells(myRow, 4).Value Then
                    bl = False
                    Exit For
                End If
            Next k
            If bl Then
                Rows(j).Insert Shift:=xlDown
                Rows(myRow + 1 & ":" & myRow + 1).Copy (Rows(j & ":" & j))
                Rows(myRow + 1 & ":" & myRow + 1).Delete Shift:=xlUp
                j = j + 1
            Else
                Rows(myRow & ":" & myRow).Delete Shift:=xlUp
                myRow = myRow - 1
            End If
        End If
        myRow = myRow + 1
    Wend
    myRow = j
    While Cells(myRow, 1).Value <> ""
        If Cells(myRow, 3).Value <> "" Then
            bl = True
            For k = 1 To j
                If Cells(k, 1).Value = Cells(myRow, 1).Value And _
                    Cells(k, 2).Value = Cells(myRow, 2).Value And _
                    Cells(k, 3).Value = Cells(myRow, 3).Value Then
                    bl = False
                    Exit For
                End If
            Next k
            If bl Then
                Rows(j).Insert Shift:=xlDown
                Rows(myRow + 1 & ":" & myRow + 1).Copy (Rows(j & ":" & j))
                Rows(myRow + 1 & ":" & myRow + 1).Delete Shift:=xlUp
                j = j + 1
            Else
                Rows(myRow & ":" & myRow).Delete Shift:=xlUp
                myRow = myRow - 1
            End If
        End If
        myRow = myRow + 1
    Wend
    myRow = j
    While Cells(myRow, 1).Value <> ""
        If Cells(myRow, 2).Value <> "" Then
            bl = True
            For k = 1 To j
                If Cells(k, 1).Value = Cells(myRow, 1).Value And _
                    Cells(k, 2).Value = Cells(myRow, 2).Value Then
                    bl = False
                    Exit For
                End If
            Next k
            If bl Then
                Rows(j).Insert Shift:=xlDown
                Rows(myRow + 1 & ":" & myRow + 1).Copy (Rows(j & ":" & j))
                Rows(myRow + 1 & ":" & myRow + 1).Delete Shift:=xlUp
                j = j + 1
            Else
                Rows(myRow & ":" & myRow).Delete Shift:=xlUp
                myRow = myRow - 1
            End If
        End If
        myRow = myRow + 1
    Wend


End Sub

ダミー

その他の回答(1件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692007/06/10 11:57:24ここでベストアンサー

ポイント100pt

マクロを作りました。

まず、この表をどう判断するかなんですが、行ごとに特定のグループにわかれていて

グループから二人とか三人の組み合わせが行として列挙されている表であると解釈し

最終的にグループを列挙すればいいと判断しました。

マクロでやっていることは横にソートして重複している名前を消し

4人の行から同じ行を消すということです。

ネストが複雑になっているので見づらくてすいません。

Sub MacroGroup()
    Dim myRow As Long
    Dim i As Integer
    Dim j As Long
    Dim k As Long
    Dim bl As Boolean
    
    myRow = 1
    While Cells(myRow, 1).Value <> ""
        '横にソートします
        Range(Cells(myRow, 1), Cells(myRow, 4)).Sort Key1:=Range(Cells(myRow, 1), Cells(myRow, 4)), Orientation:=xlLeftToRight
        
        '重複する名前を消します
        For i = 2 To 4
            If Cells(myRow, i - 1).Value = Cells(myRow, i).Value And Cells(myRow, i).Value <> "" Then
                Cells(myRow, i).Delete Shift:=xlToLeft
                i = i - 1
            End If
        Next
        myRow = myRow + 1
    Wend
        
    j = 1
    myRow = 1
    While Cells(myRow, 1).Value <> ""
        If Cells(myRow, 4).Value <> "" Then
            bl = True
            For k = 1 To j
                If Cells(k, 1).Value = Cells(myRow, 1).Value And _
                    Cells(k, 2).Value = Cells(myRow, 2).Value And _
                    Cells(k, 3).Value = Cells(myRow, 3).Value And _
                    Cells(k, 4).Value = Cells(myRow, 4).Value Then
                    bl = False
                    Exit For
                End If
            Next k
            If bl Then
                Rows(j).Insert Shift:=xlDown
                Rows(myRow + 1 & ":" & myRow + 1).Copy (Rows(j & ":" & j))
                Rows(myRow + 1 & ":" & myRow + 1).Delete Shift:=xlUp
                j = j + 1
            Else
                Rows(myRow & ":" & myRow).Delete Shift:=xlUp
                myRow = myRow - 1
            End If
        End If
        myRow = myRow + 1
    Wend
    myRow = j
    While Cells(myRow, 1).Value <> ""
        If Cells(myRow, 3).Value <> "" Then
            bl = True
            For k = 1 To j
                If Cells(k, 1).Value = Cells(myRow, 1).Value And _
                    Cells(k, 2).Value = Cells(myRow, 2).Value And _
                    Cells(k, 3).Value = Cells(myRow, 3).Value Then
                    bl = False
                    Exit For
                End If
            Next k
            If bl Then
                Rows(j).Insert Shift:=xlDown
                Rows(myRow + 1 & ":" & myRow + 1).Copy (Rows(j & ":" & j))
                Rows(myRow + 1 & ":" & myRow + 1).Delete Shift:=xlUp
                j = j + 1
            Else
                Rows(myRow & ":" & myRow).Delete Shift:=xlUp
                myRow = myRow - 1
            End If
        End If
        myRow = myRow + 1
    Wend
    myRow = j
    While Cells(myRow, 1).Value <> ""
        If Cells(myRow, 2).Value <> "" Then
            bl = True
            For k = 1 To j
                If Cells(k, 1).Value = Cells(myRow, 1).Value And _
                    Cells(k, 2).Value = Cells(myRow, 2).Value Then
                    bl = False
                    Exit For
                End If
            Next k
            If bl Then
                Rows(j).Insert Shift:=xlDown
                Rows(myRow + 1 & ":" & myRow + 1).Copy (Rows(j & ":" & j))
                Rows(myRow + 1 & ":" & myRow + 1).Delete Shift:=xlUp
                j = j + 1
            Else
                Rows(myRow & ":" & myRow).Delete Shift:=xlUp
                myRow = myRow - 1
            End If
        End If
        myRow = myRow + 1
    Wend


End Sub

ダミー

id:ffjj No.2

ffjj回答回数11ベストアンサー獲得回数02007/06/10 12:22:22

ポイント10pt

以前の質問が参考になるのではないでしょうか。

http://q.hatena.ne.jp/1147441463

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません