Excelvbaの構文

ファイルはCSV形式でしょうか？
Likeを使う場合は比較する対象が固定の場合が多いので、この場合はLeft関数でいいと思います。

一応こんな感じでしょう。
注意：エラーハンドリングはしてません、必要に応じて追加下さい。
　　　全てのテストケースを網羅した訳ではありません、必要に応じて修正下さい。
　　　また、ソースコードの最適化もあまりしてません。

Sub Create_List()
　Dim R2 As Range

　Range("A1").Activate
　Call Load_File(ActiveWorkbook.Path & "\File1.csv", 1)
　Range("A1").Activate
　Call SubToTal
　Set R2 = ActiveCell
　Call Load_File(ActiveWorkbook.Path & "\File2.csv", 2)
　R2.Activate
　Call SubToTal
　Call Data_Sort1
　Call List_Create
　Call Data_Sort2

End Sub

Sub Load_File(FNM As String, FNO As Integer)
　Dim FID As Integer
　Dim FFLD(2) As Variant
　
　i = 1
　FID = FreeFile(0)
　Open FNM For Input As FID
　Do While Not EOF(FID)
　　Input #FID, FFLD(0), FFLD(1), FFLD(2)
　　ActiveCell.Value = FFLD(0)
　　ActiveCell.Offset(0, 1).Value = FFLD(1)
　　ActiveCell.Offset(0, 2).Value = FFLD(2)
　　ActiveCell.Offset(0, 3).Value = FNO
　　ActiveCell.Offset(1, 0).Activate
　Loop
　Close #FID

End Sub

Sub SubToTal()
　Dim i As Integer
　Dim LSw As Boolean
　Dim TLT(1) As Long
　Dim STTLT As String
　
　i = 1: ActiveCell.Offset(0, 4).Value = 1
　Do While ActiveCell.Text <> ""
　　LSw = True
　　Do While LSw
　　　If ActiveCell.Offset(0, 4).Value <> 1 Then
　　　　ActiveCell.Offset(0, 3).Value = ActiveCell.Offset(-1, 3).Value
　　　　ActiveCell.Offset(0, 4).Value = ActiveCell.Offset(-1, 4).Value + 1
　　　End If
　　　If Left(ActiveCell.Text, 2) <> Left(ActiveCell.Offset(1, 0).Text, 2) Then
　　　　If i > 1 Then
　　　　　ActiveCell.Offset(1, 0).Activate
　　　　　Selection.EntireRow.Insert
　　　　　ActiveCell.Value = ActiveCell.Offset(-1 * i, 0).Text & "計"
　　　　　ActiveCell.Offset(0, 1).Value = TLT(0) + ActiveCell.Offset(-1, 1).Value
　　　　　ActiveCell.Offset(0, 2).Value = TLT(1) + ActiveCell.Offset(-1, 2).Value
　　　　　ActiveCell.Offset(0, 3).Value = ActiveCell.Offset(-1, 3).Value
　　　　　ActiveCell.Offset(0, 4).Value = ActiveCell.Offset(-1, 4).Value + 1
　　　　End If
　　　　i = 1
　　　　LSw = False
　　　　TLT(0) = 0
　　　　TLT(1) = 0
　　　Else
　　　　i = i + 1
　　　　TLT(0) = TLT(0) + ActiveCell.Offset(0, 1).Value
　　　　TLT(1) = TLT(1) + ActiveCell.Offset(0, 2).Value
　　　End If
　　　ActiveCell.Offset(1, 0).Activate
　　Loop
　Loop
End Sub

Sub Data_Sort1()
　Range("A1").Select
　Range(Selection, Selection.End(xlDown)).Select
　Range(Selection, Selection.End(xlToRight)).Select
　Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
　　　OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
　　　:=xlPinYin, DataOption1:=xlSortNormal
　Range("A1").Select
End Sub

Sub List_Create()
　Dim i As Integer

　Do While ActiveCell.Text <> ""
　　If ActiveCell.Offset(0, 3).Text = 2 Then
　　　If ActiveCell.Row <> 1 Then
　　　　If ActiveCell.Text = ActiveCell.Offset(-1, 0).Text Then
　　　　　ActiveCell.Offset(-1, 5).Value = ActiveCell.Text
　　　　　ActiveCell.Offset(-1, 6).Value = ActiveCell.Offset(0, 1).Text
　　　　　ActiveCell.Offset(-1, 7).Value = ActiveCell.Offset(0, 2).Text
　　　　　Selection.EntireRow.Delete
　　　　　ActiveCell.Offset(-1, 0).Activate
　　　　Else
　　　　　ActiveCell.Offset(0, 5).Value = ActiveCell.Text
　　　　　ActiveCell.Offset(0, 6).Value = ActiveCell.Offset(0, 1).Text
　　　　　ActiveCell.Offset(0, 7).Value = ActiveCell.Offset(0, 2).Text
　　　　　ActiveCell.Value = ""
　　　　　ActiveCell.Offset(0, 1).Value = ""
　　　　　ActiveCell.Offset(0, 2).Value = ""
　　　　End If
　　　Else
　　　　ActiveCell.Offset(0, 5).Value = ActiveCell.Text
　　　　ActiveCell.Offset(0, 6).Value = ActiveCell.Offset(0, 1).Text
　　　　ActiveCell.Offset(0, 7).Value = ActiveCell.Offset(0, 2).Text
　　　　Range(ActiveCell.Address & ":" & ActiveCell.Offset(0, 4).Address).Delete Shift:=xlUp
　　　End If
　　End If
　　ActiveCell.Offset(1, 0).Activate
　Loop

End Sub

Sub Data_Sort2()
　Range("A1", ActiveCell.Offset(-1, 7)).Select
　Selection.Sort Key1:=Range("E1"), Order1:=xlAscending, Key2:=Range("D1") _
　　　, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
　　　False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
　　　xlSortNormal, DataOption2:=xlSortNormal
　Columns("D:E").Delete Shift:=xlToLeft
　Range("A1").Select
End Sub

勉強始めたばかりであればもう少し簡単なものから手を付けた方が良いと思いますよ。
本来は少し書いては試しを繰り返して完成させないと勉強にならないので。
まぁ頑張って下さい。

投稿日時 - 2005-10-28 12:46:17

サンプルが欲しいのか分からないのですが....
以下は元のデータシートを直接操作する２例です。


◆重複するデータ数が少ない場合は以下（合計で後戻りするので次の例より遅い）

Sub SubToTal()
　Dim i, j As Integer
　
　Range("A1").Activate
　i = 1
　Do While ActiveCell.Text <> ""
　　If ActiveCell.Text <> ActiveCell.Offset(1, 0).Text Then
　　　If i > 1 Then
　　　　ActiveCell.Offset(1, 0).Activate
　　　　Selection.EntireRow.Insert
　　　　ActiveCell.Value = ActiveCell.Offset(-1, 0).Text & "計"
　　　　For j = -1 To i * -1 Step -1
　　　　　ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value + ActiveCell.Offset(j, 1).Value
　　　　　ActiveCell.Offset(0, 2).Value = ActiveCell.Offset(0, 2).Value + ActiveCell.Offset(j, 2).Value
　　　　Next
　　　　i = 1
　　　End If
　　Else
　　　i = i + 1
　　End If
　　ActiveCell.Offset(1, 0).Activate
　Loop
End Sub


◆重複するデータ数が多い場合は以下（合計で後戻りしないので前のより速い）

Sub SubToTal()
　Dim i　 As Integer
　Dim LSw As Boolean
　Dim TLT(1) As Long
　
　Range("A1").Activate
　i = 1
　Do While ActiveCell.Text <> ""
　　LSw = True
　　Do While LSw
　　　If ActiveCell.Text <> ActiveCell.Offset(1, 0).Text Then
　　　　If i > 1 Then
　　　　　ActiveCell.Offset(1, 0).Activate
　　　　　Selection.EntireRow.Insert
　　　　　ActiveCell.Value = ActiveCell.Offset(-1, 0).Text & "計"
　　　　　ActiveCell.Offset(0, 1).Value = TLT(0) + ActiveCell.Offset(-1, 1).Value
　　　　　ActiveCell.Offset(0, 2).Value = TLT(1) + ActiveCell.Offset(-1, 2).Value
　　　　End If
　　　　i = 1
　　　　LSw = False
　　　　TLT(0) = 0
　　　　TLT(1) = 0
　　　Else
　　　　i = i + 1
　　　　TLT(0) = TLT(0) + ActiveCell.Offset(0, 1).Value
　　　　TLT(1) = TLT(1) + ActiveCell.Offset(0, 2).Value
　　　End If
　　　ActiveCell.Offset(1, 0).Activate
　　Loop
　Loop
End Sub

両コードともに処理完了するまで「Application.ScreenUpdating」を使用して画面更新を行わないことでもう少し高速化出来ますが初心者にはお勧めしません。


VBAの勉強中とのことなのでコードの説明は省きました。
頑張って調べて下さい。

投稿日時 - 2005-10-27 09:54:35

VBAでプログラミングするより、Excelの集計機能を使ってみてはどうでしょう。

「東京」の上に１行追加して、各列の見出しとなる文字列を入力してから、リスト範囲を選択し、[データ(D)]-[集計(B)...]を選択してください。
集計方法などのオプションを選択して[OK]をクリックすると、小計行と総計行が一気に追加されます。

ご希望の結果とは異なりますが、集計行を削除して元に戻すのも簡単なので、何度でもやり直しがききます。お試しください。

投稿日時 - 2005-10-26 23:30:22