| |
▼りん さん: こんにちは｡
サンプルを作ってみました｡
分ける前のシート名はSheet1としました｡
後は､自動的に部門名のシートを追加して振り分けます｡
1 行目には項目名が入っているものとし､データは2行目からです｡
参考になれば幸いです｡
試してみて下さい｡
Sub test()
Dim n As String
Dim c, L As Long
Dim ws1 As Worksheet
On Error GoTo ErrorHandler
Set ws1 = Sheets("Sheet1")
L = ws1.Range("A65536").End(xlUp).Row
For i = 2 To L
n = ws1.Range("D" & i) '部門名抽出
c = Sheets(n).Range("A65536").End(xlUp).Row '部門のシートの最終行位置
ws1.Rows(i).Copy Destination:=Sheets(n).Rows(c + 1)
Next i
Exit Sub
ErrorHandler: '部門のシートが無い時の処理
Worksheets.Add.Move after:=Worksheets(Worksheets.Count) '最後のシートの後へ追加
Worksheets(Worksheets.Count).Name = n '部門の名前をシートの名前にする
ws1.Rows(1).Copy Destination:=Sheets(n).Rows(1) '1行目の項目名をコピー
Resume
End Sub
|
|
パピー（ＰＡＰＩー）
- 03/6/17(火) 16:24 -
