Private id_ As String
Public FirstName As String
Public Gender As String
Public Birthday As Date
Public Sub Greet()
MsgBox Me.FirstName & "です、こんにちは！"
End Sub
Public Sub Initialize(ByVal rng As Range)
id_ = rng(1).Value
FirstName = rng(2).Value
Gender = rng(3).Value
Birthday = rng(4).Value
End Sub
Public Property Get IsMale() As Boolean
IsMale = (Me.Gender = "male")
End Property
Public Property Get Id() As String
Id = id_
End Property
Public Property Let Id(ByVal newId As String)
If id_ <> "" Then
Debug.Print "Idは上書きすることはできません"
Else
id_ = newId
End If
End Property
Private items_ As Collection
Private Sub Class_Initialize()
Set items_ = New Collection
With Sheet1
Dim i As Long: i = 2
Do While .Cells(i, 1).Value <> ""
Dim p As Person: Set p = New Person
p.Initialize .Range(.Cells(i, 1), .Cells(i, 4))
items_.Add p, p.Id
i = i + 1
Loop
End With
End Sub
Public Property Get Item(ByVal key As Variant) As Person
Set Item = items_.Item(key)
End Property
前回はこのPersonsクラスに、要素を参照するためのItemプロパティを追加しました。
それを検証するための標準モジュールがこちら。
Sub MySub()
Dim myPersons As Persons: Set myPersons = New Persons
With myPersons
Debug.Print .Item(1).FirstName
.Item("a02").Greet
End With
End Sub
Public Function Add(ByVal values As Variant) As Person
Dim p As Person: Set p = New Person
p.Id = values(0)
p.FirstName = values(1)
p.Gender = values(2)
p.Birthday = values(3)
items_.Add p, p.Id
Set Add = p
End Function
Sub MySub()
Dim myPersons As Persons: Set myPersons = New Persons
Dim p As Person
Set p = myPersons.Add(Array("a04", "Jay", "male", #7/7/1995#))
Stop
End Sub
Public Sub Initialize(ByVal values As Variant)
Select Case TypeName(values)
Case "Range"
id_ = values(1).Value
FirstName = values(2).Value
Gender = values(3).Value
Birthday = values(4).Value
Case "Variant()"
id_ = values(0)
FirstName = values(1)
Gender = values(2)
Birthday = values(3)
End Select
End Sub
Personsクラスの各メンバーをシンプルにまとめる
すると、PersonsクラスのAddメソッドは以下のようにシンプルにまとめることができます。
Public Function Add(ByVal values As Variant) As Person
Dim p As Person: Set p = New Person
p.Initialize values
items_.Add p, p.Id
Set Add = p
End Function
Private Sub Class_Initialize()
Set items_ = New Collection
With Sheet1
Dim i As Long: i = 2
Do While .Cells(i, 1).Value <> ""
Me.Add .Range(.Cells(i, 1), .Cells(i, 4))
i = i + 1
Loop
End With
End Sub
Private id_ As String
Public FirstName As String
Public Gender As String
Public Birthday As Date
Public Sub Greet()
MsgBox Me.FirstName & "です、こんにちは！"
End Sub
Public Sub Initialize(ByVal values As Variant)
Select Case TypeName(values)
Case "Range"
id_ = values(1).Value
FirstName = values(2).Value
Gender = values(3).Value
Birthday = values(4).Value
Case "Variant()"
id_ = values(0)
FirstName = values(1)
Gender = values(2)
Birthday = values(3)
End Select
End Sub
Public Property Get IsMale() As Boolean
IsMale = (Me.Gender = "male")
End Property
Public Property Get Id() As String
Id = id_
End Property
Public Property Let Id(ByVal newId As String)
If id_ <> "" Then
Debug.Print "Idは上書きすることはできません"
Else
id_ = newId
End If
End Property
Private items_ As Collection
Private Sub Class_Initialize()
Set items_ = New Collection
With Sheet1
Dim i As Long: i = 2
Do While .Cells(i, 1).Value <> ""
Me.Add .Range(.Cells(i, 1), .Cells(i, 4))
i = i + 1
Loop
End With
End Sub
Public Property Get Item(ByVal key As Variant) As Person
Set Item = items_.Item(key)
End Property
Public Function Add(ByVal values As Variant) As Person
Dim p As Person: Set p = New Person
p.Initialize values
items_.Add p, p.Id
Set Add = p
End Function
前回はAddメソッドを追加しましたので、それを検証するための標準モジュールがこちらです。
Sub MySub()
Dim myPersons As Persons: Set myPersons = New Persons
Dim p As Person
Set p = myPersons.Add(Array("a04", "Jay", "male", #7/7/1995#))
Stop
End Sub
Sub MySub()
Dim myPersons As Persons: Set myPersons = New Persons
Dim p As Person
Set p = myPersons.Add(Array("a04", "Jay", "male", #7/7/1995#))
With myPersons
.Remove 2
.Remove "a01"
End With
Stop
End Sub
Private id_ As String
Public FirstName As String
Public Gender As String
Public Birthday As Date
Public Sub Greet()
MsgBox Me.FirstName & "です、こんにちは！"
End Sub
Public Sub Initialize(ByVal values As Variant)
Select Case TypeName(values)
Case "Range"
id_ = values(1).Value
FirstName = values(2).Value
Gender = values(3).Value
Birthday = values(4).Value
Case "Variant()"
id_ = values(0)
FirstName = values(1)
Gender = values(2)
Birthday = values(3)
End Select
End Sub
Public Property Get IsMale() As Boolean
IsMale = (Me.Gender = "male")
End Property
Public Property Get Id() As String
Id = id_
End Property
Public Property Let Id(ByVal newId As String)
If id_ <> "" Then
Debug.Print "Idは上書きすることはできません"
Else
id_ = newId
End If
End Property
Private items_ As Collection
Private Sub Class_Initialize()
Set items_ = New Collection
With Sheet1
Dim i As Long: i = 2
Do While .Cells(i, 1).Value <> ""
Me.Add .Range(.Cells(i, 1), .Cells(i, 4))
i = i + 1
Loop
End With
End Sub
Public Property Get Item(ByVal key As Variant) As Person
Set Item = items_.Item(key)
End Property
Public Function Add(ByVal values As Variant) As Person
Dim p As Person: Set p = New Person
p.Initialize values
items_.Add p, p.Id
Set Add = p
End Function
Public Sub Remove(ByVal key As Variant)
items_.Remove key
End Sub
Sub MySub()
Dim myPersons As Persons: Set myPersons = New Persons
Dim p As Person
Set p = myPersons.Add(Array("a04", "Jay", "male", #7/7/1995#))
With myPersons
.Remove 2
.Remove "a01"
End With
Stop
End Sub
Public Sub ApplyToSheet()
With Sheet1
.Cells.Clear
.Range(.Cells(1, 1), .Cells(1, 4)) = Array("Id", "FirstName", "Gender", "Birthday")
Dim i As Long: i = 2
Dim p As Person
For Each p In items_
.Range(.Cells(i, 1), .Cells(i, 4)) = Array(p.Id, p.FirstName, p.Gender, p.Birthday)
i = i + 1
Next p
End With
End Sub
流れとしては以下のとおりですね。
Sheet1をいったんクリア
1行目に見出しを再度書き出す
Personsコレクションの要素の数だけ繰り返して
各要素のデータをエクセル表に書き出す
行を1つ追加
エクセル表への反映について動作確認
作成したPersonsコレクションのApplyToSheetメソッドの動作を確認します。
例えば、標準モジュールに以下のようなSubプロシージャを作りました。
Sub MySub()
Dim myPersons As Persons: Set myPersons = New Persons
With myPersons
.Add (Array("a04", "Jay", "male", #7/7/1995#))
.Remove 2
With .Item("a01")
.FirstName = "Bomb"
.Birthday = #11/11/1993#
End With
.ApplyToSheet
End With
End Sub
Public Clients As Collection
Public Sub Store()
Set Clients = New Collection
Dim i As Long: i = 2
Do While Cells(i, 1) <> ""
Dim c As Client: Set c = New Client
c.Init Range(Cells(i, 1), Cells(i, 4))
Clients.Add c, c.Name
i = i + 1
Loop
End Sub
Public Sub Init(ByVal values As Range)
Name = values(1).Value
PostalNumber = values(2).Value
Address1 = values(3).Value
Address2 = values(4).Value
End Sub
Rangeオブジェクトを受け取って、1番目のセルから順番に各プロパティに格納していきます。
データをコレクション化の動作確認
では、標準モジュールに動作確認用のプロシージャを作って確認しましょう。
ちなみに、標準モジュールのモジュール名を「Main」に変更しています。
Sub New請求書マクロ()
wsClient.Store
Dim myClients As Collection: Set myClients = wsClient.Clients
Stop
End Sub
Public Data As Collection
Public Sub Store()
Set Data = New Collection
Dim i As Long: i = 2
Do While Cells(i, 1) <> ""
Dim d As Data: Set d = New Data
d.Init Range(Cells(i, 1), Cells(i, 5))
Data.Add d
i = i + 1
Loop
End Sub
Public Sub Init(ByVal values As Range)
DeliveryDate = values(1).Value
ClientName = values(2).Value
ItemName = values(3).Value
Price = values(4).Value
Quantity = values(5).Value
End Sub
標準モジュールMainを以下のようにコード追加して、動作確認します。
Sub New請求書マクロ()
wsClient.Store
Dim myClients As Collection: Set myClients = wsClient.Clients
wsData.Store
Dim myData As Collection: Set myData = wsData.Data
Stop
End Sub
Public DeliveryDate As Date
Public ClientName As String
Public ItemName As String
Public Price As Long
Public Quantity As Long
Public Sub Init(ByVal values As Range)
DeliveryDate = values(1).Value
ClientName = values(2).Value
ItemName = values(3).Value
Price = values(4).Value
Quantity = values(5).Value
End Sub
Public Data As Collection
Public Sub Store()
Set Data = New Collection
Dim i As Long: i = 2
Do While Cells(i, 1) <> ""
Dim d As Data: Set d = New Data
d.Init Range(Cells(i, 1), Cells(i, 5))
Data.Add d
i = i + 1
Loop
End Sub
Public Name As String
Public PostalNumber As String
Public Address1 As String
Public Address2 As String
Public Sub Init(ByVal values As Range)
Name = values(1).Value
PostalNumber = values(2).Value
Address1 = values(3).Value
Address2 = values(4).Value
End Sub
Public Clients As Collection
Public Sub Store()
Set Clients = New Collection
Dim i As Long: i = 2
Do While Cells(i, 1) <> ""
Dim c As Client: Set c = New Client
c.Init Range(Cells(i, 1), Cells(i, 4))
Clients.Add c, c.Name
i = i + 1
Loop
End Sub
ひな形となる「請求書」シート
もうひとつが「請求書」シートで、これをひな形として請求書を作ります。
クラスとコレクション化の動作確認用マクロ
以上までの動作確認をするために前回作成したのが以下のMainのコードです。
Sub New請求書マクロ()
wsClient.Store
Dim myClients As Collection: Set myClients = wsClient.Clients
wsData.Store
Dim myData As Collection: Set myData = wsData.Data
Stop
End Sub
Sub New請求書マクロ()
wsClient.Store
Dim c As Client
For Each c In wsClient.Clients
Debug.Print c.Name, c.PostalNumber, c.Address1, c.Address2
Next c
End Sub
Sub New請求書マクロ()
wsClient.Store
wsData.Store
Dim c As Client, d As Data
For Each c In wsClient.Clients
Debug.Print "■", c.Name
For Each d In wsData.Data
If c.Name = d.ClientName Then
Debug.Print d.ClientName, d.DeliveryDate, d.ItemName, d.Price, d.Quantity
End If
Next d
Next c
End Sub
Public DeliveryDate As Date
Public ClientName As String
Public ItemName As String
Public Price As Long
Public Quantity As Long
Public Sub Init(ByVal values As Range)
DeliveryDate = values(1).Value
ClientName = values(2).Value
ItemName = values(3).Value
Price = values(4).Value
Quantity = values(5).Value
End Sub
Public Data As Collection
Public Sub Store()
Set Data = New Collection
Dim i As Long: i = 2
Do While Cells(i, 1) <> ""
Dim d As Data: Set d = New Data
d.Init Range(Cells(i, 1), Cells(i, 5))
Data.Add d
i = i + 1
Loop
End Sub
Public Name As String
Public PostalNumber As String
Public Address1 As String
Public Address2 As String
Public Sub Init(ByVal values As Range)
Name = values(1).Value
PostalNumber = values(2).Value
Address1 = values(3).Value
Address2 = values(4).Value
End Sub
Public Clients As Collection
Public Sub Store()
Set Clients = New Collection
Dim i As Long: i = 2
Do While Cells(i, 1) <> ""
Dim c As Client: Set c = New Client
c.Init Range(Cells(i, 1), Cells(i, 4))
Clients.Add c, c.Name
i = i + 1
Loop
End Sub
Sub New請求書マクロ()
wsClient.Store
wsData.Store
Dim c As Client, d As Data
For Each c In wsClient.Clients
Debug.Print "■", c.Name
For Each d In wsData.Data
If c.Name = d.ClientName Then
Debug.Print d.ClientName, d.DeliveryDate, d.ItemName, d.Price, d.Quantity
End If
Next d
Next c
End Sub
Private dayCutoff_ As Date
Public Property Let DayCutoff(ByVal newDayCutoff As Date)
Range("D15").Value = DateSerial(Year(newDayCutoff), Month(newDayCutoff) + 1, 0)
Range("D16").Value = DateSerial(Year(newDayCutoff), Month(newDayCutoff) + 2, 0)
dayCutoff_ = newDayCutoff
End Property
Public Property Get DayCutoff() As Date
DayCutoff = dayCutoff_
End Property
Sub New請求書マクロ()
wsTemplate.DayCutoff = Application.InputBox("年月を入力してください", "対象年月を入力", Format(Date, "yyyy/mm"))
Debug.Print wsTemplate.DayCutoff
'wsClient.Store
'wsData.Store
'
'Dim c As Client, d As Data
'For Each c In wsClient.Clients
'
' Debug.Print "■", c.Name
' For Each d In wsData.Data
' If c.Name = d.ClientName Then
' Debug.Print d.ClientName, d.DeliveryDate, d.ItemName, d.Price, d.Quantity
' End If
'
' Next d
'Next c
End Sub
Public Function MonthEquals(ByVal d1 As Date, ByVal d2 As Date) As Boolean
MonthEquals = (Year(d1) = Year(d2) And Month(d1) = Month(d2))
End Function
すると、データの抽出部分に日付の判定も加えると以下のようになります。
Sub New請求書マクロ()
wsTemplate.DayCutoff = Application.InputBox("年月を入力してください", "対象年月を入力", Format(Date, "yyyy/mm"))
wsClient.Store
wsData.Store
Dim c As Client, d As Data
For Each c In wsClient.Clients
Debug.Print "■", c.Name
For Each d In wsData.Data
If MonthEquals(wsTemplate.DayCutoff, d.DeliveryDate) And (c.Name = d.ClientName) Then
Debug.Print d.ClientName, d.DeliveryDate, d.ItemName, d.Price, d.Quantity
End If
Next d
Next c
End Sub
Public DeliveryDate As Date
Public ClientName As String
Public ItemName As String
Public Price As Long
Public Quantity As Long
Public Sub Init(ByVal values As Range)
DeliveryDate = values(1).Value
ClientName = values(2).Value
ItemName = values(3).Value
Price = values(4).Value
Quantity = values(5).Value
End Sub
Public Data As Collection
Public Sub Store()
Set Data = New Collection
Dim i As Long: i = 2
Do While Cells(i, 1) <> ""
Dim d As Data: Set d = New Data
d.Init Range(Cells(i, 1), Cells(i, 5))
Data.Add d
i = i + 1
Loop
End Sub
Public Name As String
Public PostalNumber As String
Public Address1 As String
Public Address2 As String
Public Sub Init(ByVal values As Range)
Name = values(1).Value
PostalNumber = values(2).Value
Address1 = values(3).Value
Address2 = values(4).Value
End Sub
Public Clients As Collection
Public Sub Store()
Set Clients = New Collection
Dim i As Long: i = 2
Do While Cells(i, 1) <> ""
Dim c As Client: Set c = New Client
c.Init Range(Cells(i, 1), Cells(i, 4))
Clients.Add c, c.Name
i = i + 1
Loop
End Sub
「請求書」シートとその関連処理
さらに、以下が請求書のひな形となる「請求書」シートです。
このシートのシートモジュールwsTemplateにもコードを記述しております。
Private dayCutoff_ As Date
Public Property Let DayCutoff(ByVal newDayCutoff As Date)
Range("D15").Value = DateSerial(Year(newDayCutoff), Month(newDayCutoff) + 1, 0)
Range("D16").Value = DateSerial(Year(newDayCutoff), Month(newDayCutoff) + 2, 0)
dayCutoff_ = newDayCutoff
End Property
Public Property Get DayCutoff() As Date
DayCutoff = dayCutoff_
End Property
Sub New請求書マクロ()
wsTemplate.DayCutoff = Application.InputBox("年月を入力してください", "対象年月を入力", Format(Date, "yyyy/mm"))
wsClient.Store
wsData.Store
Dim c As Client, d As Data
For Each c In wsClient.Clients
Debug.Print "■", c.Name
For Each d In wsData.Data
If MonthEquals(wsTemplate.DayCutoff, d.DeliveryDate) And (c.Name = d.ClientName) Then
Debug.Print d.ClientName, d.DeliveryDate, d.ItemName, d.Price, d.Quantity
End If
Next d
Next c
End Sub
Public Function MonthEquals(ByVal d1 As Date, ByVal d2 As Date) As Boolean
MonthEquals = (Year(d1) = Year(d2) And Month(d1) = Month(d2))
End Function
Sub New請求書マクロ()
wsTemplate.DayCutoff = Application.InputBox("年月を入力してください", "対象年月を入力", Format(Date, "yyyy/mm"))
wsClient.Store
wsData.Store
Dim c As Client, d As Data
For Each c In wsClient.Clients
Dim targetData As Collection: Set targetData = New Collection 'ひな形に貼り付けるデータのコレクション
For Each d In wsData.Data
If MonthEquals(wsTemplate.DayCutoff, d.DeliveryDate) And (c.Name = d.ClientName) Then
targetData.Add d
End If
Next d
wsTemplate.WriteData targetData, c
Next c
End Sub
Public Sub WriteData(ByVal targetData As Collection, ByVal myClient As Object)
Dim i As Long: i = 21
Dim d As Object
For Each d In targetData
Range(Cells(i, 1), Cells(i, 3)) = Array(d.ItemName, d.Price, d.Quantity)
i = i + 1
Next d
Rows(i & ":50").Hidden = True 'データがない行を隠す
With myClient
ClientName = .Name
Range("A3").Value = .Name & "御中"
Range("A5").Value = "〒" & .PostalNumber
Range("A6").Value = .Address1
Range("A7").Value = .Address2
End With
Stop
End Sub
Public DeliveryDate As Date
Public ClientName As String
Public ItemName As String
Public Price As Long
Public Quantity As Long
Public Sub Init(ByVal values As Range)
DeliveryDate = values(1).Value
ClientName = values(2).Value
ItemName = values(3).Value
Price = values(4).Value
Quantity = values(5).Value
End Sub
Public Data As Collection
Public Sub Store()
Set Data = New Collection
Dim i As Long: i = 2
Do While Cells(i, 1) <> ""
Dim d As Data: Set d = New Data
d.Init Range(Cells(i, 1), Cells(i, 5))
Data.Add d
i = i + 1
Loop
End Sub
Public Name As String
Public PostalNumber As String
Public Address1 As String
Public Address2 As String
Public Sub Init(ByVal values As Range)
Name = values(1).Value
PostalNumber = values(2).Value
Address1 = values(3).Value
Address2 = values(4).Value
End Sub
Public Clients As Collection
Public Sub Store()
Set Clients = New Collection
Dim i As Long: i = 2
Do While Cells(i, 1) <> ""
Dim c As Client: Set c = New Client
c.Init Range(Cells(i, 1), Cells(i, 4))
Clients.Add c, c.Name
i = i + 1
Loop
End Sub
「請求書」シート
「請求書」シートは請求書のひな形となるシートです。
このシートモジュールwsTemplateに仕込んでいるコードが以下の通りです。
Private dayCutoff_ As Date
Public ClientName As String
Public Property Let DayCutoff(ByVal newDayCutoff As Date)
Range("D15").Value = DateSerial(Year(newDayCutoff), Month(newDayCutoff) + 1, 0)
Range("D16").Value = DateSerial(Year(newDayCutoff), Month(newDayCutoff) + 2, 0)
dayCutoff_ = newDayCutoff
End Property
Public Property Get DayCutoff() As Date
DayCutoff = dayCutoff_
End Property
Public Sub WriteData(ByVal targetData As Collection, ByVal myClient As Object)
Dim i As Long: i = 21
Dim d As Object
For Each d In targetData
Range(Cells(i, 1), Cells(i, 3)) = Array(d.ItemName, d.Price, d.Quantity)
i = i + 1
Next d
Rows(i & ":50").Hidden = True 'データがない行を隠す
With myClient
ClientName = .Name
Range("A3").Value = .Name & "御中"
Range("A5").Value = "〒" & .PostalNumber
Range("A6").Value = .Address1
Range("A7").Value = .Address2
End With
End Sub
Sub New請求書マクロ()
wsTemplate.DayCutoff = Application.InputBox("年月を入力してください", "対象年月を入力", Format(Date, "yyyy/mm"))
wsClient.Store
wsData.Store
Dim c As Client, d As Data
For Each c In wsClient.Clients
Dim targetData As Collection: Set targetData = New Collection 'ひな形に貼り付けるデータのコレクション
For Each d In wsData.Data
If MonthEquals(wsTemplate.DayCutoff, d.DeliveryDate) And (c.Name = d.ClientName) Then
targetData.Add d
End If
Next d
wsTemplate.WriteData targetData, c
Next c
End Sub
Public Function MonthEquals(ByVal d1 As Date, ByVal d2 As Date) As Boolean
MonthEquals = (Year(d1) = Year(d2) And Month(d1) = Month(d2))
End Function
Public Sub SaveAsNewBook()
Dim wb As Workbook
Copy
Set wb = ActiveWorkbook
Dim fileName As String
fileName = ThisWorkbook.Path & "\" & Format(dayCutoff_, "yyyymm") & "請求書_" & ClientName & ".xlsx"
Application.DisplayAlerts = False
wb.SaveAs fileName
wb.Close
Application.DisplayAlerts = True
End Sub
Sub New請求書マクロ()
wsTemplate.DayCutoff = Application.InputBox("年月を入力してください", "対象年月を入力", Format(Date, "yyyy/mm"))
wsClient.Store
wsData.Store
Dim c As Client, d As Data
For Each c In wsClient.Clients
Dim targetData As Collection: Set targetData = New Collection 'ひな形に貼り付けるデータのコレクション
For Each d In wsData.Data
If MonthEquals(wsTemplate.DayCutoff, d.DeliveryDate) And (c.Name = d.ClientName) Then
targetData.Add d
End If
Next d
With wsTemplate
.ClearData
.WriteData targetData, c
.SaveAsNewBook
End With
Next c
End Sub
