| |
こんな感じで、どうでしょーか ?
Sub Code集計()
Dim i As integer, j As Integer, Scnt As Integer
Dim Sary() As String, Snm As String
Application.ScreenUpdating = False
Scnt = Worksheets.Count
ReDim Sary(0): Sary(0) = ""
For i = 1 To Scnt
With Worksheets(i)
If InStr(1, .Name, "-") = 0 Then GoTo NLine
If Right$(.Name, 1) = "計" Then Exit For
Snm = Split(.Name, "-")(0) & "計"
If IsError(Application.Match(Snm, Sary, 0)) Then
j = j + 1: ReDim Preserve Sary(j): Sary(j) = Snm
.Copy After:=Worksheets(SCnt)
Worksheets(SCnt + 1).Name = Snm
Else
.Range("D18:D30").Copy
Worksheets(Snm).Range("D18").PasteSpecial _
xlPasteValues, xlPasteSpecialOperationAdd
Application.CutCopyMode = False
End If
End With
NLine:
Next i
On Error Resume Next
Worksheets(1).Activate
Application.ScreenUpdating = True
Erase Sary
End Sub
|
|
Kein
- 06/4/8(土) 12:38 -
