| 
    
     |  | こんばんは。 シートを150近くも作るのは大変だろうから、
 シートを追加して処理するのも作ってみたのですが、・・・
 
 エラー処理が怪しいです。
 各集計シートがなければ追加し、必要事項の記入
 あれば次々に転記のはずなのですが・・
 この処理は、どこかでKeinさんが書いたのをROMしてたのですが、
 ROMしたのが、どこかにいっちゃった。残念!!
 
 一応こちらではできてますが、エラー処理が怪しいので
 だめなときは、捨ててください。
 
 Sub test2()
 Dim mySh As Worksheet
 Dim R As Range
 Dim myR As Range
 
 With Worksheets("総合集計表")
 Set myR = .Range("A4", .Range("A65536").End(xlUp))
 For Each R In myR
 On Error GoTo エラー
 Set mySh = Worksheets(R.Text)
 On Error GoTo 0
 With mySh
 If Not IsEmpty(R.Offset(0, 1).Value) Then
 .Range("A65536").End(xlUp).Offset(1).Value = _
 Worksheets("総合集計表").Range("A1").Value
 .Range("B65536").End(xlUp).Offset(1).Value = _
 R.Offset(, 2).Value
 End If
 If IsNumeric(.Range("C65536").End(xlUp).Value) Then
 .Range("C65536").End(xlUp).Offset(1).Value = _
 .Range("C65536").End(xlUp).Value + .Range("C65536").End(xlUp).Offset(1, -1).Value
 Else
 .Range("C65536").End(xlUp).Offset(1).Value = _
 .Range("C65536").End(xlUp).Offset(1, -1).Value
 End If
 End With
 
 Next
 End With
 Exit Sub
 エラー:
 Set mySh = Worksheets.Add(after:=Sheets(Sheets.Count))
 With mySh
 .Name = R.Value
 .Range("A1:B1").Value = Array("コードNo", "営業所名")
 .Range("A2:B2").Value = R.Resize(1, 2).Value
 .Range("A4").Resize(1, 3).Value = Array("年月日", "売上高", "売り上げ累計")
 End With
 Resume
 End Sub
 
 |  |