【ご質問】Excel2003のVBA作成について

質問

Excel2003のVBA作成について、ご教授ねがいます。期限もなく本当に困っております。

■　実現したいこと

Excelシートの1シート目にあるデータを所属コード毎に振り分け、自動で2シート目、3シート目に振り分けたい。
※1シート目のデータ自体は、所属コード毎に既にソートされている状態

(1)　Excelの1シート目に以下のような全データ１０００件程度ある。

　　 所属コード／所属名／個人番号／個人名
　　 001／東京／111／山田華子
　　 001／東京／112／鈴木太郎
　　 002／大阪／331／安井徹
　　 005／福岡／444／山下健二

(2)　所属コード毎に2シート目、3シート目に振り分けたい。
　　 2シート目：001／東京／123／山田華子
　　　　　　　　 001／東京／112／鈴木太郎

　　 3シート目：002／大阪／331／安井徹
　　 4シート目：005／福岡／444／山下健二

■　環境

WindowsXP、office2003

■　スキル

簡単なコードを読み・修正ことができる程度です。１からコードを作成するスキルはありません。

■　補足

Excel・Access、どちらでも構いません。

同様のファイルが１００個、所属が１２００ほどあるため、マンパワーでは難しく、プログラムにてできたらと思っております。宜しくお願いいたします。

回答No.3

tom04

こんばんは！
一例です。
Alt＋F11キー　→　画面左下の「This Workbook」をダブルクリックして
↓のコードをコピー＆ペーストしマクロを実行してみてください。

Sub test()
Dim i, k, N As Long
Dim str As String
Dim ws As Worksheet
Set ws = Worksheets(1)
Application.ScreenUpdating = False
For i = 2 To Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For k = 1 To Worksheets.Count
Select Case Len(ws.Cells(i, 1))
Case 1
str = "00" & ws.Cells(i, 1)
Case 2
str = "0" & ws.Cells(i, 1)
Case Else
str = ws.Cells(i, 1)
End Select
If Worksheets(k).Name = str Then
N = N + 1
End If
Next k
If N = 0 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = str
End If
N = 0
Next i
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
For k = 2 To Worksheets.Count
Select Case Len(ws.Cells(i, 1))
Case 1
str = "00" & ws.Cells(i, 1)
Case 2
str = "0" & ws.Cells(i, 1)
Case Else
str = ws.Cells(i, 1)
End Select
If str = Worksheets(k).Name Then
If Worksheets(k).Cells(1, 1) = "" Then
ws.Rows(1).Copy Destination:=Worksheets(k).Cells(1, 1)
End If
If WorksheetFunction.CountIf(Worksheets(k).Columns(3), ws.Cells(i, 3)) = 0 Then
ws.Rows(i).Copy Destination:= _
Worksheets(k).Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
End If
Next k
Next i
Application.ScreenUpdating = True
End Sub

※　二度For～NextでLoopしています。
他に良い方法があればごめんなさいね。m(_ _)m

回答No.2

hallo-2007

お急ぎの上、スキルが乏しく
且つ
＞同様のファイルが１００個、所属が１２００ほどある

まず、状況を解決するにはかなりのレベルが必要です。
情報も少ないです。
１、ひとつのファイルはシートが１枚なのか。
２、所属ごとにシートを追加した場合、シート数は幾つぐらいになるのか。
３、１２００の所属の一覧のデータはあるのか。
４、それぞれのファイル名や保存されたフォルダが統一されているのか
最後に
部署ごとに作成したシートをどのように活用するのか
仮に、現在、１枚のシートをもつファイルが１００個あるのを
部署ごとに数百のシートをもつファイルを１００個作って、便利になりますか？

私であれば
１、新規のファイルを作成
２、１００個のファイルを開いて、新規の１枚のシートに追加していく。
　　データの一元化　と呼びます。情報が分散していると使いにくいですよね。
３、一元化されたデータから所属の一覧表を作成する。
　　関数でもピボットテーブルでも可能です。
４、一元化されたデータシートと所属を入力してデータを抽出シートを追加する。
　　所属ごとのシートは作りません。
　　あるセルに所属を入力すると
　　以下の行に条件にあったデータが一覧として抽出される機能を作ります。
資料の配布には、ここで作成した一つのファイルで済みますし、印刷して配布するのみ簡単
決して、所属ごとにシート数を増やしてはいけません。
何百もシートがあると移動するだけでも大変になります。

２もマクロが出来れば早いでしょうが、この際、手動で頑張ってください。
３については、ピボットテーブルを使って、所属の一覧表を作成してみてください。
４は
http://www.eurus.dti.ne.jp/yoneyama/Excel/filter3.htm
にフィルターオプションの設定とマクロで抽出を実行させる方法が説明されていますので
ご一読してください。
基本は、データのシート
　　　　部署名一覧のシート
　　　　部署名を入力するとデータを抽出してくれるシート
この３枚で検討してみてください。

試しに、ひとつのファイルを開いて
３と４について試してみてください。
私が何を伝えたいか実感してもらえると思います。

データがシートごとに分散している。ファイルごとに分散していると必ず、この様な状況に
陥ります。
データは、ひとつのファイルで一枚のシートにまとめるように心がけてください。

回答No.1

goota33

以前私が回答したプログラムの中に、
今回質問された内容の動作に応用が利きそうだったので、
そのプログラムを少し改良してお答えします。
とりあえず以下のプログラムを実行すればほぼご希望通りの動作をすると思うので試してみてください。

ただし、このプログラムを実行する際の注意点として、
一番左の列は必ず正順列の所属コードを書いておくこと、
一番左側のシート(最初にExcelを起動したときにSheet1という名前になってるシート)
以外はすべて削除してしまうので、実行する前にバックアップを一応とっておいてください。

Public Sub sub_testText()
Dim i As Long, j As Long, k As Long
Dim lngBeforeNumber As Long
Dim lngAfteraNumber As Long
Dim wbkActiveSheet As Worksheet
Dim rngInputData As Range
Dim r As Range
Dim lngLastRow As Long
Dim lngLastColumn As Long
Dim varInputArray As Variant

Set wbkActiveSheet = ActiveSheet
With Worksheets(1)
lngLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lngLastRow
If i = lngLastRow Then Exit For

lngBeforeNumber = .Cells(i, 1).Value
lngAfterNumber = .Cells(i + 1, 1).Value

If lngBeforeNumber = lngAfterNumber Then

Else
j = j + 1

End If

Next i

j = j + 1
If Worksheets.Count > 1 Then
For i = 2 To Worksheets.Count
Application.DisplayAlerts = False
Worksheets(2).Delete
Application.DisplayAlerts = True

Next i

End If
For i = 1 To j
Worksheets.Add after:=Worksheets(Worksheets.Count)

Next i
wbkActiveSheet.Activate
With Worksheets(1)
lngLastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column

End With

j = 2
k = 1
For i = 2 To lngLastRow
If i = lngLastRow Then Exit For

' MsgBox Worksheets(1).Cells(i, 2).Value
lngBeforeNumber = .Cells(i, 1).Value
lngAfterNumber = .Cells(i + 1, 1).Value
If lngBeforeNumber = lngAfterNumber Then
With Worksheets(j)
If k = 1 And i = 1 Then
Worksheets(1).Range(Worksheets(1).Cells(k, 1), Worksheets(1).Cells(k, lngLastColumn)).Copy Destination:= _
.Range(.Cells(k, 1), .Cells(k, lngLastColumn))
k = k + 1

Else
Worksheets(1).Range(Worksheets(1).Cells(i, 1), Worksheets(1).Cells(i, lngLastColumn)).Copy Destination:= _
.Range(.Cells(k, 1), .Cells(k, lngLastColumn))
k = k + 1

End If
End With
Else
Worksheets(1).Range(Worksheets(1).Cells(i, 1), Worksheets(1).Cells(i, lngLastColumn)).Copy Destination:= _
Worksheets(j).Range(Worksheets(j).Cells(k, 1), Worksheets(j).Cells(k, lngLastColumn))

k = 1
j = j + 1
End If

Next i
Worksheets(1).Range(Worksheets(1).Cells(lngLastRow, 1), Worksheets(1).Cells(lngLastRow, lngLastColumn)).Copy Destination:= _
Worksheets(j).Range(Worksheets(j).Cells(k, 1), Worksheets(j).Cells(k, lngLastColumn))
' Worksheets(j).Cells(k, 1).Value = Worksheets(1).Cells(lngLastColumn, 2).Value

End With

End Sub