| |
こんな感じで出来ると思います。
Sub Data転記()
Dim MyR As Range, C As Range
Dim Sh As Worksheet
Dim Anm As String, Snm As String
Anm = ActiveSheet.Name
Application.ScreenUpdating = False
Set MyR = Range("C2", Range("C65536").End(xlUp))
Range("C:C").AutoFilter 1, "Tokyo"
On Error GoTo ELine
Set MyR = MyR.SpecialCells(12)
On Error GoTo 0
On Error GoTo NLine
For Each C In MyR
Snm = C.Offset(, -2).Text & "_" & C.Offset(, -1).Text
Set Sh = Worksheets(Snm)
C.EntireRow.Copy Sh.Range("A65536").End(xlUp).Offset(1)
Next
Set MyR = Nothing
Sheets(Anm).AutoFilterMode = False
Application.ScreenUpdating = True: Exit Sub
ELine:
MsgBox "Tokyo の入力セルが見つかりません", 48
Application.ScreenUpdating = True
Sheets(Anm).AutoFilterMode = False: Exit Sub
NLine:
Set Sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
Sh.Name = Snm: Err.Clear
Resume Next
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
