Verileri şartlara göre sayfalara dağıtma.

[Biray3550]

Merhaba,

Firmaların şartını CariSabit'den A kolonundan Cari kelimesinden alıp Cari sayfasına aktaracak.

Bankaların şartını BankaSabit'den C kolonundaki karşılığına göre Banka veya Virman sayfasına alacak

Borç Çeki , Çek Tahsil , Senet Ödeme ve Senet Tahsil kelimelerini satır içinden alacak ve ilgili sayfalarına aktaracak. Biraz karışık oldu ama, Macro konusunda yardımcı olabilir misiniz? Örnek olarak dosyada gösterdim sayfalara nasıl aktarılması gerektiğini. Umarım anlatabilmişimdir. Teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodu deneyiniz.

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Long
Set s1 = Sheets("Rapor")
For a = 3 To s1.Cells(Rows.Count, "A").End(3).Row
    If WorksheetFunction.CountIf(Sheets("CariSabit").Range("C:C"), s1.Cells(a, "C")) > 0 Then
        Set s2 = Sheets("Cari")
    ElseIf WorksheetFunction.CountIf(Sheets("BankaSabit").Range("B:B"), s1.Cells(a, "C")) > 0 Then
        Set s2 = Sheets(WorksheetFunction.VLookup(s1.Cells(a, "C"), Sheets("BankaSabit").Range("B:C"), 2, 0))
    ElseIf InStr(1, s1.Cells(a, "C"), "BORÇ ÇEKİ", vbTextCompare) > 0 Then
        Set s2 = Sheets("BorçÇeki")
    ElseIf InStr(1, s1.Cells(a, "C"), "ÇEK TAHSİL", vbTextCompare) > 0 Then
        Set s2 = Sheets("ÇekTahsil")
    ElseIf InStr(1, s1.Cells(a, "C"), "SENET ÖDEME", vbTextCompare) > 0 Then
        Set s2 = Sheets("SenetÖdeme")
    ElseIf InStr(1, s1.Cells(a, "C"), "SENET TAHSİL", vbTextCompare) > 0 Then
        Set s2 = Sheets("SenetTahsil")
    Else
        Set s2 = Nothing
    End If
   
    If Not s2 Is Nothing Then
        With s1.Range("A" & a & ":E" & a)
            s2.Cells(Rows.Count, "A").End(3)(2, 1).Resize(1, .Columns.Count).Value = .Value
        End With
    End If
Next
MsgBox "İşlem Tamam"
End Sub

 

[Biray3550]

Çok teşekkür ederim.