| |
>1.新規シートを作成して→2.オリジナルの表からコピベ→3.台帳（Sheet1）から
>番号を自動で取得（シート名を取得した番号に変更）
こんな感じかな ?
Sub Mk_Sheets()
Dim CpR As Range, MyR As Range, C As Range
Dim Sname As String
Dim MyS As Worksheet, Sh As Worksheet
Set MyS = Worksheets("Sheet1")
Application.ScreenUpdating = False
On Error GoTo ELine
With MyS.Range("C2", MyS.Range("C65536").End(xlUp))
Set CpR = .Offset(, -2).Resize(, 6)
With .Offset(, 253)
.Formula = "=IF(COUNTBLANK($D2:$F2)=3,1,"""")"
Set MyR = .SpecialCells(3, 1)
End With
End With
On Error GoTo 0
For Each C In MyR
Sname = CStr(C.Offset(, -253).Value)
On Error Resume Next
Set Sh = Worksheets(Sname)
If Err.Number <> 0 Then
Set Sh = Worksheets.Add(After:=ActiveSheet)
Sh.Name = Sname: Err.Clesr
End If
On Error GoTo 0
CpR.Copy Sh.Range("A65536").End(xlUp).Offset(1)
Set Sh = Nothing
Next
ELine:
Set MyR = Nothing: Set CpR = Nothing
MyS.Range("IV:IV").ClearContents: Set MyS = Nothing
Application.ScreenUpdating = True
End Sub
|
|
Kein
- 06/5/23(火) 14:20 -
