ExcelVBA 科目の整列方法について

①　次の表データの各社の科目欄は、まちまちですが、②の標準科目で整理する場合
社名 大科目 科目 　　　　　　2000 2010
A社 資産 現金・預金 　　　　　418525 463782
A社 資産 財政融資資金預託金 540470 637720
A社 資産 貸出 　　　　　　　　4166238 4542799
A社 資産 株式以外の証券 　　1049146 1188598
A社 資産 株式・出資金 　　320016 368177
A社 資産 金融派生商品 　　　　　　0 0
A社 資産 預け金 　　　　　　21856 24492
A社 資産 企業間・貿易信用 　　　　　　0 0
A社 資産 未収・未払金 　　104541 116420
A社 資産 対外直接投資 　　　3510 3751
A社 資産 対外証券投資 　　　25627 31240
A社 資産 その他対外債権債務 28006 30998
A社 資産 その他 　　　　　　32028 36363
A社 資産 合計 　　　　　　　6709963 7444340
A社 負債 現金・預金 　　　　3296197 3612754
A社 負債 財政融資資金預託金 846623 1000549
A社 負債 貸出 　　　　　　　　935185 997042
A社 負債 株式以外の証券 　　543956 602144
A社 負債 株式・出資金 　　192739 246563
A社 負債 金融派生商品 　　　　　0 0
A社 負債 保険・年金準備金 　　　432124 499327
A社 負債 預け金 　　　　　　34000 35555
A社 負債 未収・未払金 　　　199602 242116
A社 負債 その他対外債権債務 　4025 4927
A社 負債 その他 　　　　　　30647 40155
A社 負債 金融資産･負債差額 194865 163208
A社 負債 合計 　　　　　　　6709963 7444340

②　標準科目（Worksheet(2))は、以下のとおりです。

現金・預金
財政融資資金預託金
貸出
株式以外の証券
株式・出資金
金融派生商品
保険・年金準備金
預け金
企業間・貿易信用
未収・未払金
対外直接投資
対外証券投資
その他対外債権債務
その他
資金過不足（金融取引表）
金融資産・負債差額(金融資産・負債残高表)
合計

③　出来上がりの形は、①の表に②の標準科目がない場合には、不足する標準科目を該当位置に行挿入する（データ欄は、空欄）。つまり、すべての会社の科目の内容を②の標準科目の並びにしたいのです。
④　そこで作成したコードは、以下のとおりですが、無限ループになってうまくいきません。
どこがおかしいのでしょうか？どなたかご教示いただけないでしょうか。

Sub 科目整列()
Dim i As Integer
Dim j As Integer

Range("c3").Activate
Do While ActiveCell.Value <> ""
For j = 2 To 18
If ActiveCell.Value = Worksheets(2).Cells(j, 4).Value Then
ActiveCell.Offset(1, 0).Activate
Else
Selection.EntireRow.Insert
ActiveCell.Value = Worksheets(2).Cells(j, 4).Value
ActiveCell.Offset(1, 0).Activate
End If
Next j
Loop

End Sub

質問者からの補足コメント

• Saturn5さん
  早速ご回答ありがとうございました。
  小生、駆け出しで恐縮ですが、
  
  >for ループ
  >if　シート２　に科目発見　then 1行下がる　ｼﾞｬﾝﾌﾟ※　
  >next
  >行挿入してコピー
  
  の中で、ｼﾞｬﾝﾌﾟ　の意味がよくわからないのですが。
  出来れば、コードで書いていただけるとありがたいのですが、
  すみません、よろしくお願いします。

  No.1の回答に寄せられた補足コメントです。 補足日時：2015/04/02 10:31

• Saturn5さん
  ありがとうございます。
  前のご回答の中で、
  >for ループ
  >if　シート２　に科目発見　then 1行下がる　ｼﾞｬﾝﾌﾟ※　
  >next
  >行挿入してコピー
  >※
  で４行目の《行挿入してコピー》とありますが、ここは、forループの外なので、コピーするものは、どう特定するのでしょうか？
  すみません、よろしくお願いいたします。
  なお、ＶＢＡで組むのは、このほかにも、いろいろな加工をしなければいけないので、ＶＢＡでやりたいと考えております。よろしくお願いいたします。

    補足日時：2015/04/02 16:40

• tom04 さん
  ご返信ありがとうございます。
  >Sheet1の「金融資産･負債差額」となっているのにSheet2では「金融資産･負債差額(金融資産・
  >負債残高表)」といった具合に・・・
  すみませんでした。これは、同じなのでSheet2 の方の()内は不要でした。
  また、素晴らしいコードを書いていただき、恐縮です。
  まだ、VBA駆け出しですので、じっくり勉強させていただきます。
  ありがとうございました。

  No.4の回答に寄せられた補足コメントです。 補足日時：2015/04/02 23:35

• WindFaller さん
  ご返信ありがとうございます。
  VBAは、駆け出しですが、Excel自体も、中途半端なので、ご提案の内容、拝見させていただいて
  勉強しながら、チャレンジさせていただきたいと思います。
  どうもありがとうございます。

  No.3の回答に寄せられた補足コメントです。 補足日時：2015/04/02 23:42

No.5 ベストアンサー 回答者： tom04 回答日時： 2015/04/03 19:00

No.4です。

＞同じなのでSheet2 の方の()内は不要でした。
というコトですのでもう少し簡単に出来ます。
↓のコードにしてみてください。

Sub Sample2()
Dim i As Long, j As Long, wS As Worksheet
Set wS = Worksheets(2)
With Worksheets(1)
For i = .Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1
For j = 18 To 2 Step -1
If j > 2 Then
If .Cells(i, "C") = wS.Cells(j, "D") Then
If .Cells(i - 1, "C") <> wS.Cells(j - 1, "D") Then
.Rows(i).Insert
.Cells(i, "C") = wS.Cells(j - 1, "D")
i = i + 1
End If
End If
Else
If .Cells(i + 1, "C") = wS.Range("D3") And .Cells(i, "C") <> wS.Range("D2") Then
.Rows(i).Insert
.Cells(i, "C") = wS.Range("D2")
i = i + 1
End If
End If
Next j
Next i
End With
End Sub

※　前回のコードでも大丈夫だと思いますが、
これでも同じ動きになると思います。m(_ _)m

この回答へのお礼

tom04 さん

ご回答ありがとうございました。
本日、出かけておりましたので、返事が遅れてすみませんでした。
具体的なコードも書いていただきありがとうございました。
これで、再度組んでみたいと思います。
これからもよろしくお願いいたします。
ありがとうございました。

お礼日時：2015/04/03 19:09

No.4 回答者： tom04 回答日時： 2015/04/02 23:26

こんばんは！

質問の内容を確認すると、Sheet1とSheet2の「科目」で若干の違いがあるようですね？
Sheet1の「金融資産･負債差額」となっているのにSheet2では「金融資産･負債差額(金融資産・負債残高表)」といった具合に・・・
Excel的には全く異なるデータになってしまいますので、かなり厄介です。

少し長くなりましたが、その辺を考慮してやってみました。

Sub Sample1()
Dim i As Long, j As Long
Dim str1 As String, str2 As String
Dim buf1 As String, buf2 As String
Dim wS As Worksheet
Set wS = Worksheets(2)
With Worksheets(1)
For i = .Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1
If InStr(StrConv(.Cells(i, "C"), vbNarrow), "(") > 0 Then
str1 = Left(.Cells(i, "C"), InStr(StrConv(.Cells(i, "C"), vbNarrow), "(") - 1)
Else
str1 = .Cells(i, "C")
End If
If InStr(StrConv(.Cells(i - 1, "C"), vbNarrow), "(") > 0 Then
str2 = Left(.Cells(i - 1, "C"), InStr(StrConv(.Cells(i - 1, "C"), vbNarrow), "(") - 1)
Else
str2 = .Cells(i - 1, "C")
End If
For j = 18 To 2 Step -1
If j > 2 Then
If InStr(StrConv(wS.Cells(j, "D"), vbNarrow), "(") > 0 Then
buf1 = Left(wS.Cells(j, "D"), InStr(StrConv(wS.Cells(j, "D"), vbNarrow), "(") - 1)
Else
buf1 = wS.Cells(j, "D")
End If
If InStr(StrConv(wS.Cells(j - 1, "D"), vbNarrow), "(") > 0 Then
buf2 = Left(wS.Cells(j - 1, "D"), InStr(StrConv(wS.Cells(j - 1, "D"), vbNarrow), "(") - 1)
Else
buf2 = wS.Cells(j - 1, "D")
End If
If str1 = buf1 Then
If str2 <> buf2 Then
.Rows(i).Insert
.Cells(i, "C") = wS.Cells(j - 1, "D")
i = i + 1
End If
End If
Else
If .Cells(i + 1, "C") = wS.Range("D3") And .Cells(i, "C") <> wS.Range("D2") Then
.Rows(i).isert
.Cells(i, "C") = wS.Range("D2")
i = i + 1
End If
End If
Next j
Next i
End With
End Sub

※　じっくり考えればもっと簡単になるかもしれませんが、
とりあえずはこの程度で・・・m(_ _)m

No.3 回答者： WindFaller 回答日時： 2015/04/02 20:20

こんばんは。

>どこがおかしいのでしょうか？
実務を交えたものに関しては、どんなベテランの人でも、なかなか手こずることがあります。今回の内容を、本格的なマクロでするというのは、相当の技量が必要になってしまいます。#1の方のおっしゃるように、関数を交えながら、対処するほうがよいと思います。

もちろん、裏ワザとしては、②が既定なら、それそのものを、Excelのオプションの[詳細設定]の中の[ユーザー設定リスト]に、登録してしまいます。そして、並べ替えの時に、カスタム・ソートすればよいだけです。

>会社の科目の内容を②の標準科目の並びにしたいのです。
要するに番号付けすればよいのではありませんか？
例えば、F列あたりに、番号を振ります。そして、範囲を指定して並替えをします。
別の科目が出てきた時は、現在18科目ですから、19から数字がふられていきます。

'//
Sub TestMacro()
　Dim w1 As Worksheet
　Dim w2 As Worksheet
　Dim ArAc() As Variant
　Dim ArAm As Variant
　Dim ArN As Variant
　Dim rng As Range
　Dim i As Long, j As Long, m As Long, lst As Long, k
　Set w1 = Worksheets("Sheet1")
　Set w2 = Worksheets("Sheet2")
　With w2
　　Set rng = .Range("A2", .Cells(Rows.Count, "A").End(xlUp).Offset(1))
　　ReDim ArAc(1 To rng.Rows.Count)
　　For Each c In rng
　　　i = i + 1
　　　ArAc(i) = c.Value
　　Next
　End With
　ArAm = ArAc()
　With w1
　　.Range("F2").Value = "番号"　'並替えの時のヘッダー
　　lst = .Cells(Rows.Count, "C").End(xlUp).Row
　　For j = 3 To lst
　　　If .Cells(j, "C").Value Like "合計" Then
　　　　.Cells(j, "F").Value = 99 '合計の部分は,99にします。
　　　Else
　　　　k = Application.Match(.Cells(j, "C").Value, ArAc(), 0)
　　　　If IsNumeric(k) Then
　　　　　.Cells(j, "F").Value = k
　　　　Else
　　　　　m = m + 1
　　　　　.Cells(j, "F").Value = i + m
　　　　End If
　　　End If
　　Next
　End With
End Sub
'//

'添付の画像は、合計欄に99がふられていませんが、こんな感じになります。
'この後で、資産の部と、負債の部で、並替えをします。

No.2 回答者： Saturn5 回答日時： 2015/04/02 14:20

実のところを書きますと、私はＶＢやＣのコードはわかるのですが、

ＶＢＡのコーディングはしたことがありません。
多分、ＶＢの小型版＋Ｅｘｃｅｌオブジェクト と考えています。

文中のジャンプとは gotoステートメントです。
検索でヒットした場合はジャンプを抜けないといけません。
全てのループでヒットしなかったときのみ、データ追加です。

何度も書きますが、固定シートを作って数値参照した方が楽ですよ。
それにアクティブセルを動かすプログラムは非常に危険です。

No.1 回答者： Saturn5 回答日時： 2015/04/02 04:40

＜誤＞

for ループ
if　シート２　に科目発見　then 1行下がる
else 行挿入してコピー
next

＜正＞
for ループ
if　シート２　に科目発見　then 1行下がる　ｼﾞｬﾝﾌﾟ※　
next
行挿入してコピー
※

行挿入するのはシート２の科目を検索して、全て無かったあとのことです。

ただし、このような処理はマクロを使うよりも統計関数を使った方が簡単で、
動作が速く、ミスもすｋなくなります。通常のＥｘｃｅｌでは、ほとんどの
処理でＶＢＡを記述しなければいけないことは無いはずです。
出力表の形式は固定されているので、値をsumif関数で拾ってくれば終わりです。