|
Keinさん、
ご親切にありがとうございます。
さっそく会社に行ってから試したいと思います。
ありがとうございました。
▼Kein さん:
>こんな感じで出来ると思います。
>
>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
|
|