Hücre İçeriğine göre Tablo Taşıma

[fealdown]

merhaba iyi günler bir sorum olacaktı, Benim ADANA adında bir sayfam var, bu sayfaya butona basıldığında mailden veri çekmektedir.Butona her basıldığında veri çekme işlemi bittikten sonra Şehir Sutununda "Adana,Mersin,Hatay,Gaziantep,Konya,Karaman" Olanları "ADANA" Sayfasında kalmasını geri kalan şehirlerin olduğu satırıda "ERZURUM" sayfasına taşımasını istiyorum.Nasıl yapabilirim bunu?

 

[Muzaffer Ali]

Merhaba.
Örnek dosyanızı eklerseniz daha iyi olur.

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki kodları ADANA sayfasının kod kısmına kopyalayarak dener misiniz?

Option Compare Text

Private Sub CommandButton1_Click()
    Dim Bak As Range
    Dim Sehirler()
    Dim Shr As Integer
    Dim Gonder As Boolean

    Sehirler = Array("ADANA", "MERSİN", "HATAY", "GAZİANTEP", "KONYA", "KARAMAN")
    
    For Each Bak In Range(("C4:C" & Cells(Rows.Count, "C").End(3).Row))
        For Shr = 0 To UBound(Sehirler) - 1
            If IsError(Bak.Value) Then
                GoTo 1
            ElseIf IsEmpty(Bak.Value) Then
                Exit For
            ElseIf Bak.Value = Sehirler(Shr) Then
                Gonder = False
                Exit For
            Else
                Gonder = True
            End If
        Next
        If Gonder Then
            With Worksheets("ERZURUM")
                Dim Satir As Integer
                Satir = Bak.Row
                Rows(Satir).Cut .Range("A" & .Cells(Rows.Count, "A").End(3).Row + 1)
                Rows(Satir).Delete
            End With
        End If
    Next
1:
End Sub

 

[fealdown]

Çok teşekkür ederim yardımlrınız için.

 

[Muzaffer Ali]

Aşağıdaki kodları deneyiniz.

Private Sub CommandButton1_Click()
    Dim Bak As Long
    Dim Sehirler()
    Dim Shr As Integer
    Dim Gonder As Boolean
    Sehirler = Array("ADANA", "MERSİN", "HATAY", "GAZİANTEP", "KONYA", "KARAMAN")
    For Bak = Cells(Rows.Count, "C").End(3).Row To 4 Step -1
        For Shr = 0 To UBound(Sehirler)
            If IsError(Range("C" & Bak)) Or IsEmpty(Range("C" & Bak)) Then
                Gonder = False
                Exit For
            ElseIf Range("C" & Bak).Value = Sehirler(Shr) Then
                Gonder = False
                Exit For
            Else
                Gonder = True
            End If
        Next
        If Gonder Then
            With Worksheets("ERZURUM")
                Range("A" & Bak & ":N" & Bak).Copy .Range("A" & .Cells(Rows.Count, "A").End(3).Row + 1)
                Range("A" & Bak & ":N" & Bak).Delete
            End With
        End If
    Next
End Sub

 

[fealdown]

teşekkür ederim işe yaradı çok sağolun