【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

提示ソースを出来るだけ活かそうと思いましたが、いまいち意図がわからず挫折しました。
「大阪」「東京」「名古屋」と言うシートが存在する前提のマクロです。

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