| |
▼かな さん：
毎回、シートを作り直しています。
シート名が不適切でエラーとなる場合もあるかもしれません。
Sub シート分け2()
Dim ws As Worksheet
Dim n As Long
Dim h As Range
With Worksheets("一覧表")
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name <> .Name Then ws.Delete
Next
Application.DisplayAlerts = True
n = .Range("A1").CurrentRegion.Columns.Count
'転記する
For Each h In .Range("H7:H" & .Range("H65536").End(xlUp).Row)
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(h.Value)
On Error GoTo 0
If ws Is Nothing Then
'支店名シートを新調する
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ws.Name = h.Value
.Rows(1).Resize(, n).Copy ws.Range("A3")
End If
ws.Range("H65536").End(xlUp).EntireRow.Resize(, n).Offset(1).Formula = _
"=" & h.EntireRow.Range("A1").Address(False, False, , True)
Next
End With
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
