人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

Excelで、

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

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

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

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

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

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

●質問者: Solais
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:Excel ソート ファイル 佐藤 加藤
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● SALINGER
●100ポイント ベストアンサー

マクロを作りました。

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

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

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

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

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

ダミー


2 ● ffjj
●10ポイント

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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ