Excelvbaの構文

質問

はじめまして最近Excelvbaを勉強し始めた初心者です。
早速質問なんですが例えば↓

東京　150　200
大阪　230　100
大阪　100　 50
大阪　100　300
福岡　250　300
沖縄　500　100

こんな表があるとします。
大阪のように同じ名前が連続した時に↓

東京　150　200
大阪　230　100
大阪　100　 50
大阪　100　300
小計　430　450
福岡　250　300
沖縄　500　100

このように大阪の下に小計欄を作成して
合計を求めたいのですが、
連続する可能性のある言葉は把握しています（複数あり）
Excelvbaで出来ますか？
僕なりに考えてみたんですが無理でした・・・
どなたか詳しい方、知恵を貸して下さい。
お願いいたします。

回答No.3

Xen

ファイルは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

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

お礼

ありがとうございます！
leftを使ってみたらできました。
そうですね～ちょっと難しいとこに手をつけたかもしれませんね。
勉強になりました。
ほんとうにありがとうございます、、

回答No.2

Xen

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

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

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の勉強中とのことなのでコードの説明は省きました。
頑張って調べて下さい。

補足

回答ありがとうございます。
処理結果をみて驚いてます！
私も勉強してXenさんみたいになれたらとおもいます。

あと一つ出きれば教えていただきたいのですが、
例えば

ＦＩＬＥ1　　　　　　ＦＩＬＥ2　

東京　　　　　　　　東京　
大坂　　　　　　　　大坂
大坂府　　　　　　　大坂府知事
大坂城　　　　　　　福岡
大坂府知事　　　　　沖縄
福岡
沖縄

こんな2つのFileがあるとします。
これを照合して↓

東京　　　　　　　　東京　
大坂　　　　　　　　大坂
大坂府　　　　　　　
大坂城　　　　　　　　
大坂府知事　　　　　大坂府知事
計　　　　　　　　　計　
福岡　　　　　　　　福岡
沖縄　　　　　　　　沖縄

と完全に合ってない文字を（大坂の部分は把握してます）
見比べて大坂の部分が共通ならカウントして計をつくる。
またもう一つのFileとも見比べて大坂の部分で入ってない欄があったらスペースを入れて同じ列に計を入れたいんです。

If ActiveCell.Text <> ActiveCell.Offset(1, 0).Text Thenの部分を変えるのは何となく分かるんですが・・・
Likeをつかうんですか？
すみませんが知恵を貸して下さい。

回答No.1

G_Amino

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

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

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