|
こんばんは。
シートを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
|
|