| |
▼mame さん：
>▼じゅんじゅん さん：
>>▼mame さん：
>返信ありがとうございます。
>うーん・・・
>どういえばいいんでしょうか・・・・
>
>イメージとしては、社名、請求額、請求書番号などがダーッと
>書かれたリストがあって、各社ごとに分けてシートを作りたいって感じです。
>社名は決まってなく毎回違いますので、コード内に入れ込む事が
>難しいと思いまして・・・・。
>
>説明がヘタクソですみません。。。。
Sheet１にデータがあって、Ａ列（１行目は項目、２行目以下に社名）のデータ
毎にシート名（社名）を作成し、そのシートに社名毎のデータを転記する。
（同一のシート名が存在していたら、強制削除する）
Sub Test()
Dim Dic As Object
Dim key As Variant
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim Csh As Worksheet
Dim r As Range
Application.ScreenUpdating = False
Set sh1 = Worksheets("Sheet1")
Set Dic = CreateObject("Scripting.Dictionary")
With sh1
For Each r In .Range(.[A2], .Cells(Rows.Count, "A").End(xlUp))
Dic(r.Value) = Empty
Next
End With
For Each key In Dic.keys
For Each Csh In Worksheets
If key = Csh.Name Then
Application.DisplayAlerts = False
Csh.Delete
Application.DisplayAlerts = True
End If
Next
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = key
Set sh2 = Worksheets(key)
With sh1
.Range("A1").AutoFilter Field:=1, Criteria1:=key
.Range("A1").CurrentRegion.Copy Destination:=Worksheets(key).Range("A1")
.AutoFilterMode = False
End With
Next
Set Dic = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
Application.ScreenUpdating = True
End Sub
こう言った事でしょうか？
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
