[エクセル・VBA]縦列の重複するデータを抽出し、横行に一つずつのみ並べかえ表示させる

お世話になります。
エクセルのVBAを使い下記の表のB列[Month]の重複をなくしてG列：金額の隣から右に向けて古い月順に並べ替え表示させようと思っております。
A列...............B列.........C列........D列....E列.....F列......G列
Date..............Month...業者名..摘要..記号1.記号2..金額
2007/11/7..Nov-07..青森KK..アイ..BA....304....386
2008/1/6...Jan-08..岩手(株)..ウエ..CC....318....313
2008/2/1...Feb-08..(有)埼玉..オカ..JG....121....9,480
2008/2/15..Feb-08..(株)東京...キク..AI...183....216
2008/3/6...Mar-08..(株)東京...ケコ..OX...248....1,490
2008/3/11..Mar-08..北海道...サシ..FJ...319....2,730

↓これを下記のように表示させる
..................G列.......H列........I列........J列........K列
←列省略.金額...Nov-07..Jan-08..Feb-08..Mar-08
..................386
..................313
..................9,480
↓行省略.216

しかし、私のVBAでは
...................G列......H列.......I列.......J列.......K列......L列........M列
←列省略.金額..Nov-07.Jan-08.Feb-08.Feb-08.Mar-08.Mar-08
↓行省略.386

となってしまいます。[Month]はA列の[Date]を参照しMMM-YYで表示させています。[Date]はA3から始まっております。B列を完璧に文字列に変換できればいいのですが、それが出来なくて。。。
～VBA～
Sub test()
Dim i As Integer
Dim n As Integer
Dim mnt0 As String
Dim mnt1 As String
i = 4
n = 8
Do Until Cells(i, 2).Value = ""
　　mnt0 = Cells(i - 1, 2).Value
　　mnt1 = Cells(i, 2).Value
　　If mnt1 <> mnt0 Then
　　Cells(3, n).Value = mnt1
　　End If
　　i = i + 1
　　n = n + 1
Loop
End Sub

この表を使ってのゆくゆくの目標は、縦列は金額の大きい順にソートをし、右に新たに設けた[Month]の該当するセルに"*"等の印をつけることです。
よろしくお願い申し上げます。

No.4 ベストアンサー 回答者： onlyrom 回答日時： 2008/06/08 15:44

再度の登場、onlyromです。

＞に変更いたしました。
＞しかしながら、H列以降の表示が
＞Nov-08..........May-08..........Mar-08........
＞(2008/11/7)　(2008/5/8)　(2008/3/8)
＞となってしまい

質問者は自分がなにをやってるのか分かっていますか？
質問者のコードは、予めＢ列（Monthの列）がソートされているものとしてのコードです。
が、コードを修正などして実行したときのデータはＢ列はソートされてないですねよね。
上記結果を見れば一目瞭然です。


＞抽出後の[Month]の処理方法をご指南いただけませんでしょうか

このＭarking_mntのマクロは、Monthの見出し作成が上手くいけば
何ら修正するところはありません。ちゃんと動作します。
付け加えるとしたら、最後に、金額のソート入れるくらいです。



●結論●

【Month見出し作成のマクロ】

（１）マクロの最初に、Month列ソートのコードを追加
（２）次に３行目（見出し）のセルの表示形式を文字列にするために
　　　Rows(3).Rows(3).NumberFormatLocal = "@"
　　　を追加
　　　なぜこのコードが必要なのか追々分かるはずです


【Marking_mntマクロ】

（１）最後に、金額ソートのコードを追加
　

これで質問の件は最終結果まで完璧に出すことができます。
もちろん、最終的には、Month見出し作成と、Markingの２つを合体するでしょうから、
その合体したコードの最初に、前回結果をクリアーするコードも追加する必要があるでしょう。


因みに、Ｎｏ３のお礼コメントの
「H列以降の[Month]も完璧な文字列でした」
これは、Ｂ列が文字列の場合に限り言えることです。
くれぐれも勘違いのないように。(^^;;;

以上。

この回答へのお礼

たびたびのご回答ありがとうございました。
勉強になりました。
また機会がございましたらよろしくお願い申し上げます。

お礼日時：2008/06/08 23:51

No.3 回答者： hotosys 回答日時： 2008/06/07 19:44

最初にH1に何か入っているとエラーになるので、以下にして下さい。

Sub sample()
Range("H1") = ""
Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True
Range(Range("H2"), Range("H2").End(xlDown)).Copy
Range("I1").PasteSpecial Transpose:=True
Columns("H:H").Delete
End Sub

この回答へのお礼

貴殿のコードはちょっと私には難しく1004エラーも出てしまいましたので、下記のように書き換えたらきちんと表示されました。
～
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Range(Cells(3, 2), Cells(LastRow, 2)).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Range(Cells(3, 2), Cells(LastRow, 2)), CopyToRange:=Range("H1"), Unique:=True
Range(Cells(2, 8), Range(Cells(2, 8), Cells(LastRow, 8))).Copy
Cells(3, 9).PasteSpecial Transpose:=True
～
H列以降の[Month]も完璧な文字列でした、ありがとうございます。

お礼日時：2008/06/08 11:08

No.2 回答者： hotosys 回答日時： 2008/06/07 19:21

あまり難しく考えずに、手動でならどうしたらいいかと、それをマクロで記録すれば数行で済む場合もある。

Sub sample()
Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True
Range(Range("H2"), Range("H2").End(xlDown)).Copy
Range("I1").PasteSpecial Transpose:=True
Columns("H:H").Delete
End Sub

No.1 回答者： onlyrom 回答日時： 2008/06/07 16:05

質問者はやる気のある方のようですから、

最終段階（金額ソート、＊を付ける）までのサンプルコードではなく、
ヒントだけにしておきますので、後はトライしてみてください。


（Ｂ列を文字列にする方法）
Text関数をシートに埋め込めば簡単にできます。
もちろんこれもマクロでやってもいいですが。。


　=TEXT(A4,"MMM-YY")


ただ、Ｂ列を文字列にしただけでは提示のコードは上手く動作しません。
Ｂ列を文字列にした後、実行してみてください。
質問者のスキルなら、簡単にコードの修正ができるはずです。

分からないことは再度質問のこと。

以上。

この回答への補足

onlyromさん、
たびたびお世話になります。
>提示のコードは上手く動作しません

Do～
If mnt1 <> mnt0 Then
Cells(3, n).Value = mnt1
i = i + 1
n = n + 1
Else
i = i + 1
End If
Loop～

に変更いたしました。
しかしながら、H列以降の表示が
Nov-08..........May-08..........Mar-08..........Jun-08..........Apr-08
(2008/11/7)　(2008/5/8)　(2008/3/8)(2008/6/8)　(2008/4/8)
となってしまい、当然ながら「最終段階（金額ソート、＊を付ける）・・・」の下記コードは全く合致しません。

Sub marking_mnt()
Dim i As Integer
Dim n As Integer
Dim src_val As String
Dim rtn_val As String
i = 4
n = 8
rtn_val = "*"
Do Until Cells(i, 2).Value = ""
　src_val = Cells(i, 2).Value
　Do Until Cells(3, n).Value = ""
　　If Cells(3, n).Value = src_val Then
　　Cells(i, n).Value = rtn_val
　　n = 8
　　Exit Do
　　Else
　　n = n + 1
　　End If
　Loop
　i = i + 1
Loop
End Sub

よろしければ、抽出後の[Month]の処理方法をご指南いただけませんでしょうか。

補足日時：2008/06/08 11:25