EXCELで振り分け

Aの列に
「1-1.jpg」
「1-3.jpg」
「1-4.jpg」
「2-1.jpg」
「2-2.jpg」
～～
という感じでデータが保存されています。
これを"-1""-3"の部分で列を分けたいと思っています。

1-1.jpg 1-3.jpg 1-4.jpg　1-5.jpg
2-1.jpg 2-3.jpg
3-1.jpg 3-3.jpg 3-4.jpg
という感じです。

・頭の数字は1から700番程度まであり、頭が同じものは同じ行にまとめたいです。
・後ろの-1は-1、-3、-4、-5、-6があります。(Eの列まで利用ということです)
・上の例にも書いていますが、-3、-4、-5、-6は無い物もあります。

何か良い方法はないでしょうか?

No.5 ベストアンサー 回答者： zap35 回答日時： 2007/04/28 13:52

＃０４です。

一部不具合があったので以下に差し替えてください

Sub Macro1()
Dim ws As Worksheet
Dim res, res2 As Range
Dim idx As Long
Dim wkStr As String
　Set ws = ActiveSheet
　Worksheets.Add after:=ActiveSheet
　With ActiveSheet
　　For idx = 1 To ws.Range("A65536").End(xlUp).Row
　　　wkStr = Left(ws.Cells(idx, "A"), InStr(ws.Cells(idx, "A"), "-"))
　　　If Len(wkStr) > 0 Then
　　　　Set res = .Range(.Range("A1"), .Range("A65536").End(xlUp)).Find(wkStr)
　　　　If res Is Nothing Then
　　　　　.Range("A65536").End(xlUp).Offset(1, 0) = wkStr
　　　　End If
　　　　Set res = .Range(.Range("A1"), .Range("A65536").End(xlUp)).Find(wkStr)
　　　　Set res2 = res.EntireRow.Find(ws.Cells(idx, "A").Value)
　　　　If res2 Is Nothing Then
　　　　　res.Offset(0, Application.CountA(res.EntireRow)).Value = _
　　　　　ws.Cells(idx, "A").Value
　　　　End If
　　　End If
　　Next idx
　　.Columns(1).Delete
　End With
End Sub

No.4 回答者： zap35 回答日時： 2007/04/28 13:44

関数も考えたのですが、かなり複雑になりそうだったのでマクロにしてみました。

新しいシートを追加して振り分けるようにしています。

以下のマクロをALT＋F11でVBE画面を開き、「VBAProjectエクスプローラのシート名右クリック」→「挿入」→「標準モジュール」で表示される画面にペーストして下さい。実行はシート画面に戻って、ALT＋F8を押してマクロ一覧からマクロ名を選択して実行します。

Sub Macro1()
Dim ws As Worksheet
Dim res, res2 As Range
Dim idx As Long
Dim wkStr As String
　Set ws = ActiveSheet
　Worksheets.Add after:=ActiveSheet
　With ActiveSheet
　　For idx = 1 To ws.Range("A65536").End(xlUp).Row
　　　wkStr = Left(ws.Cells(idx, "A"), InStr(ws.Cells(idx, "A"), "-"))
　　　If Len(wkStr) > 0 Then
　　　　Set res = .Range(.Range("A1"), .Range("A65536").End(xlUp)).Find(wkStr)
　　　　If res Is Nothing Then
　　　　　.Range("A65536").End(xlUp).Offset(1, 0) = wkStr
　　　　End If
　　　End If
　　Next idx
　　For idx = 1 To ws.Range("A65536").End(xlUp).Row
　　　wkStr = Left(ws.Cells(idx, "A"), InStr(ws.Cells(idx, "A"), "-"))
　　　Set res = .Range(.Range("A1"), .Range("A65536").End(xlUp)).Find(wkStr)
　　　Set res2 = res.EntireColumn.Find(ws.Cells(idx, "A").Value)
　　　If res2 Is Nothing Then
　　　　res.Offset(0, Application.CountA(res.EntireRow)).Value = _
　　　　　　ws.Cells(idx, "A").Value
　　　End If
　　Next idx
　　.Columns(1).Delete
　End With
End Sub

No.3 回答者： pkh4989 回答日時： 2007/04/28 12:59

VBAで如何でしょうか。

C列に展開

Const MaxCol As Integer = 20
Type Rec
wWORK(MaxCol) As String
End Type
Dim tWORK() As Rec
Dim tWorkCnt As Integer

Sub 振り分け()
Dim wMaxRow As Long
Dim wVal As Variant
Dim wIx As Integer
Dim wIy As Integer
Dim wIz As Integer
Dim wStr As String
Dim wFlg As Boolean
Dim wLen As Integer
'
wMaxRow = ActiveSheet.Range("A1").End(xlDown).Row
wVal = ActiveSheet.Range("A1:A" & wMaxRow)
tWorkCnt = 0
For wIx = 1 To UBound(wVal)
wStr = wVal(wIx, 1)
wFlg = False
wLen = InStr(1, wStr, "-")
For wIy = 1 To tWorkCnt
If Left(wStr, wLen - 1) = Left(tWORK(wIy).wWORK(1), wLen - 1) Then
For wIz = 1 To MaxCol
If tWORK(wIy).wWORK(wIz) = "" Then
tWORK(wIy).wWORK(wIz) = wStr
wFlg = True
Exit For
End If
Next
Exit For
End If
Next
If wFlg = False Then
tWorkCnt = tWorkCnt + 1
ReDim Preserve tWORK(tWorkCnt)
tWORK(tWorkCnt).wWORK(1) = wStr
End If
Next
'
For wIx = 1 To tWorkCnt
For wIy = 1 To MaxCol
ActiveSheet.Cells(wIx, wIy + 2) = tWORK(wIx).wWORK(wIy)
Next
Next
End Sub

(1) Alt+F11 (ツール -> マクロ -> Visual Basic Editor)
(2) 挿入 -> 標準モジュール -> 上記のモジュールを貼り付けて実行(F5を押す)する

No.2 回答者： mshr1962 回答日時： 2007/04/28 12:49

頭の数字に抜けはありますか？ある場合にその行は空白になりますけど．．．

B1=IF(COUNTIF($A:$A,ROW()&"-*")>COLUMN()-2,INDEX($A:$A,COLUMN()+MATCH(ROW()&"-1.jpg",$A:$A)-2,1)&"","")
F列までコピーしてから下方にコピーしてください。
これでB:F列に展開できますので結果をコピーして
別シートにでも値として貼り付けてください。

No.1 回答者： Bickyon 回答日時： 2007/04/28 11:44

オートフィルタで、「-1を含む」とか「-3を含む」とか条件を変更しながらコピペするのはどうですか？

この回答への補足

早速の返答ありがとうございます、

その方法で試してみましたが、空白部分がすべて消されてしまうので、
上の例で行くと
1-1.jpg 1-3.jpg 1-4.jpg　1-5.jpg
2-1.jpg 2-3.jpg「3-4.jpg」
3-1.jpg 3-3.jpg「4-4.jpg」
という感じになってしまいます。

他に方法はないでしょうか?

補足日時：2007/04/28 12:04