Harita üzerinde aynı isimli shape ile liste almada hata

[usta07]

Aşağıdaki Kod ile harita üzerindeki şehir isimlerine tıkladığımda oteller sayfasındaki ilgili şehrin otel listeleri rapor sayfasına iki şehir hariç (İstanbul ve Çanakkale) geliyor. Bu güzide iki şehrimizin otellerinin gelmemesinin sebebini bulamadım.
Ancak her zaman olduğu gibi başımıza proplem olan üç boğazdan ikisidir diye düşünüyorum. Çünkü bu iki şehrimizin ikişer parça shapesleri var, diğer şehirlerimizin birer tane. Herkesin bir boğazı olduğu gibi.
Çözüm üretebilen arkadaşlara şimdiden teşekkür ederim.

Sub OtelListe()
Dim Sehir As String
Dim sh As Shape
Dim wsTR As Worksheet
Dim wsOtel As Worksheet
Dim wsList As Worksheet
Sehir = Application.Caller
Set wsTR = Worksheets("TÜRKİYE")
Set wsOtel = Worksheets("OTELLER")
Set wsList = Worksheets("RAPOR")

For Each sh In Sheets("TÜRKİYE").Shapes
  If sh.Name = Sehir Then
    With sh.Fill
      .ForeColor.SchemeColor = 42
      .Visible = msoTrue
      .Solid
    End With
  Else
    With sh.Fill
      .ForeColor.SchemeColor = 9
      .Visible = msoTrue
      .Solid
    End With
  End If
Next sh

wsTR.Range("A2").Value = Sehir
wsList.Cells.ClearContents

wsOtel.Range("OtelList").AdvancedFilter _
  Action:=xlFilterCopy, _
  CriteriaRange:=wsTR.Range("Olcut"), _
  CopyToRange:=wsList.Range("A1"), Unique:=False
  wsList.Activate
  wsList.Range("A1").Activate
  Set wsTR = Nothing
  Set wsOtel = Nothing
  Set wsList = Nothing
 
End Sub

 

[Levent Menteşoğlu]

Kullandığınız kodun içine aşağıdaki kırmızı renkli satırları eklerseniz sorunu çözmüş olursunuz.

Sub OtelListe()
Dim Sehir As String
Dim sh As Shape
Dim wsTR As Worksheet
Dim wsOtel As Worksheet
Dim wsList As Worksheet
Sehir = Application.Caller
Set wsTR = Worksheets("TÜRKİYE")
Set wsOtel = Worksheets("OTELLER")
Set wsList = Worksheets("RAPOR")

For Each sh In Sheets("TÜRKİYE").Shapes
  If sh.Name = Sehir Then
    With sh.Fill
      .ForeColor.SchemeColor = 42
      .Visible = msoTrue
      .Solid
    End With
  Else
    With sh.Fill
      .ForeColor.SchemeColor = 9
      .Visible = msoTrue
      .Solid
    End With
  End If
Next sh

[B][COLOR=Red]If Sehir = "Freeform 86" Or Sehir = "Freeform 87" Then Sehir = "İstanbul"
If Sehir = "Freeform 85" Or Sehir = "Freeform 50" Then Sehir = "Çanakkale"[/COLOR][/B]

wsTR.Range("A2").Value = Sehir
wsList.Cells.ClearContents

wsOtel.Range("OtelList").AdvancedFilter _
  Action:=xlFilterCopy, _
  CriteriaRange:=wsTR.Range("ölçüt"), _
  CopyToRange:=wsList.Range("A1"), Unique:=False
  wsList.Activate
  wsList.Range("A1").Activate
  Set wsTR = Nothing
  Set wsOtel = Nothing
  Set wsList = Nothing
 
End Sub

 

[usta07]

Kullandığınız kodun içine aşağıdaki kırmızı renkli satırları eklerseniz sorunu çözmüş olursunuz.

Levent Bey,
Elinize, beyninize, yüreğinize sağlık, çok teşekkür ederim.