【VBA】別々のシートに列ごとコピーしていきたい

エクセルＶＢＡ初心者です

以下のような表を、地区別にわけられたシートで、種別を選んで貼り付けていきたいのですが

地区種別
1大阪金
2東京銀
3名古屋銀
4大阪金
5大阪銅
6名古屋銅
7東京金
8名古屋金
9大阪銅
金と銀のみ、地区に分けられたシートに貼り付け

シート【大阪】
1大阪金
4大阪金

シート【東京】
2東京銀
7東京金

シート【名古屋】
3名古屋銀
8名古屋金

以下のVBAを加工してみましたが組んでみましたがうまくいきません
どうかご教示のほどよろしくお願いします


↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓

Public Sub cptest()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim rng As Range
Dim cel As Range
Dim stcrng As New Collection
Dim lastRow As Integer
Dim cnt As Integer
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
lastRow = Range("G65535").End(xlUp).Row
Set rng = sht1.Range("G1:G" & lastRow)
For Each cel In rng
If cel.Value = "あり" Then
Set cel = sht1.Range(cel.Offset(0, -4), cel.Offset(0, -1))
stcrng.Add cel
End If
Next

sht2.Cells.Clear
cnt = 0
Set rng = sht2.Range("A1")
For Each cel In stcrng
cel.Copy
rng.Offset(cnt, 0).PasteSpecial
rng.Offset(cnt, 4).Value = "＿"
cnt = cnt + 1
Next
Application.CutCopyMode = False
End Sub

No.1 回答者： mt2008 回答日時： 2012/07/11 18:59

提示ソースを出来るだけ活かそうと思いましたが、いまいち意図がわからず挫折しました。

「大阪」「東京」「名古屋」と言うシートが存在する前提のマクロです。

Sub Sample()
　　sCity = Split("大阪,東京,名古屋", ",")
　　Columns("G:G").Select
　　Selection.AutoFilter
　　For i = 0 To UBound(sCity)
　　　　Range("G:G").AutoFilter Field:=1, Criteria1:="=*" & sCity(i) & "*", Operator:=xlAnd, Criteria2:="<>*銅"
　　　　Range("G:G").CurrentRegion.SpecialCells(xlVisible).Copy Worksheets(sCity(i)).Range("G1")
　　Next i
　　Selection.AutoFilter
End Sub