Bir sayfaya yapıştırılan verileri, rapor sayfasına uygun formatta çıkarma

[excelwebtruser]

1. Selamlar değerli arkadaşlar, ekte bir excel dosyası yüklüyorum.
   1. Listeler Sekmesine Çalışan Listesi yapıştırılıyor. (bu isimler bordro programından raporla alınıyor)
      
   2. Aktar butonuna basılınca şu işlemi yapsın istiyoruz.
      1. Listeler bölümünde bulunan isimleri alfabetik sekmesinden kontrol etsin,
         
      2. Listelere yapıştırılan ad soyadı bulduğunda aynı güzergahını hafızada tutsun, (apor sayfasındaki a sütununa güzergah adını yazıp, yanındaki sütuna ise bu güzergahtaki bütün kişileri Ad SOYAD1 - Ad SOYAD35 gibi bir formatta aynı satıra ve satır kaydırarak yerleştirsin.
         
      3. Bende böylelikle düzenli bir şekilde güzergah isimlerini yazdırmış olabileyim

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodu deneyiniz.

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim s As Object
Dim a As Long
Dim kisi As String, servis As String

Set s1 = Sheets("Listeler")
Set s2 = Sheets("Alfabetik")
Set s3 = Sheets("Rapor Sayfası")
Set s = CreateObject("Scripting.Dictionary")

s3.Range("A2:B" & s3.UsedRange.Rows.Count).ClearContents
For a = 2 To s1.Cells(Rows.Count, 1).End(3).Row
    kisi = s1.Cells(a, "A")
    If WorksheetFunction.CountIf(s2.Range("B:B"), kisi) > 0 Then
        servis = s2.Range("B:B").Find(What:=kisi, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, -1).Value
    Else
        servis = "GÜZERGAH GİRİLMEMİŞ"
    End If
   
    If s.exists(servis) Then
        s(servis) = s(servis) & " - " & kisi
    Else
        s.Add servis, kisi
    End If
Next
s3.Range("A2").Resize(s.Count).Value = Application.Transpose(s.keys)
s3.Range("B2").Resize(s.Count).Value = Application.Transpose(s.items)
s3.Range("A2:B" & s3.UsedRange.Rows.Count).Sort s3.Range("A2")
s3.Cells.EntireRow.AutoFit
End Sub

 

[excelwebtruser]

Merhaba,
Aşağıdaki kodu deneyiniz.

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim s As Object
Dim a As Long
Dim kisi As String, servis As String

Set s1 = Sheets("Listeler")
Set s2 = Sheets("Alfabetik")
Set s3 = Sheets("Rapor Sayfası")
Set s = CreateObject("Scripting.Dictionary")

s3.Range("A2:B" & s3.UsedRange.Rows.Count).ClearContents
For a = 2 To s1.Cells(Rows.Count, 1).End(3).Row
    kisi = s1.Cells(a, "A")
    If WorksheetFunction.CountIf(s2.Range("B:B"), kisi) > 0 Then
        servis = s2.Range("B:B").Find(What:=kisi, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, -1).Value
    Else
        servis = "GÜZERGAH GİRİLMEMİŞ"
    End If

    If s.exists(servis) Then
        s(servis) = s(servis) & " - " & kisi
    Else
        s.Add servis, kisi
    End If
Next
s3.Range("A2").Resize(s.Count).Value = Application.Transpose(s.keys)
s3.Range("B2").Resize(s.Count).Value = Application.Transpose(s.items)
s3.Range("A2:B" & s3.UsedRange.Rows.Count).Sort s3.Range("A2")
s3.Cells.EntireRow.AutoFit
End Sub

s3.Range("A2").Resize(s.Count).Value = Application.Transpose(s..keys)

şu satırda compile error: syntax error hatası verdi


yanıtınız için teşekkür ederim

 

[ÖmerBey]

(s..keys) ifadesindeki ikinci noktadan dolayı olabilir mi?

 

[excelwebtruser]

(s..keys) ifadesindeki ikinci noktadan dolayı olabilir mi?

teşekkür ederim, elinize sağlık şu an çalıştı, ama benim asıl verilerimi yapıştırdığımda aşağıdaki gibi bir hata verdi.

 

[ÖmerBey]

End Sub ifadesinin üstüne MsgBox "Başarıyla çalışmıştır." satırını ilave ediniz.

 

[excelwebtruser]

End Sub ifadesinin üstüne MsgBox "Başarıyla çalışmıştır." satırını ilave ediniz.

Özür dilerim ömer bey benim asıl verilerimi yapıştırınca hem listeye hemde alfabetik kısmına benim asıl verilerimi ekledim. aşağıdaki gibi bir hata verdi

 

[excelwebtruser]

Özür dilerim ömer bey benim asıl verilerimi yapıştırınca hem listeye hemde alfabetik kısmına benim asıl verilerimi ekledim. aşağıdaki gibi bir hata verdi
Ekli dosyayı görüntüle 222304

Ekli dosyayı görüntüle 222305

Sanırım , kopyala yapıştırdan dolayı bir sorun olmuş sadece metni yapıştır diyince sorunum düzeldi gibi tekrar teşekkürler

 

[excelwebtruser]

yinede garip bir hata veriyor, 35 satır kopyaladım başarılı bir şekilde çalıştırdı ama 200 satırlık bir ad soyad listesi kopyaladım yine yukarıdaki hatayı verdi runtime error

 

[excelwebtruser]

ekteki tablodada denedim ama aynı hatayı veriyor

 

[ÖmerBey]

Veri sayısıyla alakalı bir problem oluştu sanıyorum.
Aşağıdaki kodu deneyiniz...

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim s As Object
Dim a As Long
Dim kisi As String, servis As String

Set s1 = Sheets("Listeler")
Set s2 = Sheets("Alfabetik")
Set s3 = Sheets("Rapor Sayfası")
Set s = CreateObject("Scripting.Dictionary")

s3.Range("A2:B" & s3.UsedRange.Rows.Count).ClearContents
For a = 2 To s1.Cells(Rows.Count, 1).End(3).Row
    kisi = s1.Cells(a, "A")
    If WorksheetFunction.CountIf(s2.Range("B:B"), kisi) > 0 Then
        servis = s2.Range("B:B").Find(What:=kisi, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, -1).Value
    Else
        servis = "GÜZERGAH GİRİLMEMİŞ"
    End If
  
    If s.exists(servis) Then
        s(servis) = s(servis) & " - " & kisi
    Else
        s.Add servis, kisi
    End If
Next

dz1 = s.Keys
dz2 = s.Items
For a = LBound(dz1) To UBound(dz1)
    s3.Cells(a + 2, "A") = dz1(a)
    s3.Cells(a + 2, "B") = dz2(a)
Next

s3.Range("A2:B" & s3.UsedRange.Rows.Count).Sort s3.Range("A2")
s3.Cells.EntireRow.AutoFit
MsgBox "Başarıyla çalışmıştır."
End Sub

 

[excelwebtruser]

Veri sayısıyla alakalı bir problem oluştu sanıyorum.
Aşağıdaki kodu deneyiniz...

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim s As Object
Dim a As Long
Dim kisi As String, servis As String

Set s1 = Sheets("Listeler")
Set s2 = Sheets("Alfabetik")
Set s3 = Sheets("Rapor Sayfası")
Set s = CreateObject("Scripting.Dictionary")

s3.Range("A2:B" & s3.UsedRange.Rows.Count).ClearContents
For a = 2 To s1.Cells(Rows.Count, 1).End(3).Row
    kisi = s1.Cells(a, "A")
    If WorksheetFunction.CountIf(s2.Range("B:B"), kisi) > 0 Then
        servis = s2.Range("B:B").Find(What:=kisi, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, -1).Value
    Else
        servis = "GÜZERGAH GİRİLMEMİŞ"
    End If
 
    If s.exists(servis) Then
        s(servis) = s(servis) & " - " & kisi
    Else
        s.Add servis, kisi
    End If
Next

dz1 = s.Keys
dz2 = s.Items
For a = LBound(dz1) To UBound(dz1)
    s3.Cells(a + 2, "A") = dz1(a)
    s3.Cells(a + 2, "B") = dz2(a)
Next

s3.Range("A2:B" & s3.UsedRange.Rows.Count).Sort s3.Range("A2")
s3.Cells.EntireRow.AutoFit
MsgBox "Başarıyla çalışmıştır."
End Sub

Çok teşekkür ederim, sorunum çözüldü.

 

[veyselemre]

Alternatif olsun.

Sub test()
    Dim i&, lst1, lst2

    With Sheets("Listeler")
        lst1 = .Range("A2:B" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With

    With Sheets("Alfabetik")
        lst2 = .Range("A2:B" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With

    With CreateObject("Scripting.Dictionary")

        For i = 1 To UBound(lst2)
            .Item(lst2(i, 2)) = lst2(i, 1)
        Next i

        For i = 1 To UBound(lst1)
            If .exists(lst1(i, 1)) Then
                lst1(i, 2) = .Item(lst1(i, 1))
            Else
                lst1(i, 2) = "GÜZERGAH GİRİLMEMİŞ"
            End If
        Next i

        .RemoveAll

        For i = 1 To UBound(lst1)
            .Item(lst1(i, 2)) = .Item(lst1(i, 2)) & " - " & lst1(i, 1)
        Next i

        Erase lst1, lst2

        If .Count > 0 Then
            lst1 = .Keys
            lst2 = .Items

            With Sheets("Rapor Sayfası")

                .Range("A2:B" & .UsedRange.Rows.Count).ClearContents

                For i = LBound(lst1) To UBound(lst1)
                    .Cells(i + 2, 1) = lst1(i)
                    .Cells(i + 2, 2) = Mid(lst2(i), 4)
                Next i

                .Range("A2:B" & .UsedRange.Rows.Count).Sort .Range("A2")
                .Cells.EntireRow.AutoFit

            End With
        End If

    End With

    Erase lst1, lst2
    MsgBox "Başarıyla çalışmıştır."

End Sub