Sayfalara Otomatik aktarma

[Rainbows]

selam arkadaşlar.

elimde su sekilde calısan bir makro var. anasayfadaki a datasını combobox ile a sayfasını secerek aktarıyorum. fakat bu benim cok zamanımı alıyor. müsteribilgi diye yeni bir sheet acıp bütün müsterilerin gitmesi gerekn sayfaları yazdım. fakat bu noktadan sonra ne yapmak gerektigi konusunda tıkandım. yardımcı olursanız sevinirim örnek dosyayı ekliyorum.

 

[Rainbows]

Yardımcı olabilecek birileri yok mudur?

 

[Rainbows]

Yardım lütfen.....

 

[Rainbows]

arkadaşlar olmayacak bir sey mi istedigim??

 

[Orion1]

bu veri yapınız ile vba kullanarak çalışmak çok zor.
sanırım o sebeple sorunuza yanıt alamamışsınız.

 

[Korhan Ayhan]

Selamlar,

Sayfa isimlerinizi kontrol edin.

"MüşteriBilgi" isimli sayfanızdaki sayfa isimleri ile sekme isimlerinizin bazıları eşleşmiyor. Bu sebeple aşağıdaki kod hata verecektir. Düzeltmelerinizi yaptıktan sonra kodu kullanabilirsiniz.

Aşağıdaki kodu bir butona atayıp deneyiniz.

Kod ilgili sayfadaki eski bilgileri silerek yeni verileri aktarır. Eski verileri silmeden aktarım istiyorsanız koda ekleme yapmak gerekecektir.

Option Explicit
 
Sub SAYFALARA_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, Sayfa As Worksheet
    Dim BUL As Range, BUL_CARİ_KOD As Range, Satır As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("MüşteriBilgi")
    Set S2 = Sheets("Anasayfa")
    
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> "MüşteriBilgi" And Sayfa.Name <> "Anasayfa" Then
            Sayfa.Cells.ClearContents
        End If
    Next
    
    For X = 2 To S1.Cells(Rows.Count, 1).End(3).Row
        Set BUL = S2.Range("B:B").Find(S1.Cells(X, 1), , , xlWhole)
        If Not BUL Is Nothing Then
            Set BUL_CARİ_KOD = S2.Range("A" & BUL.Row + 1 & ":A" & Rows.Count).Find("Cari Kod", , , xlWhole)
            If Not BUL_CARİ_KOD Is Nothing Then
                S2.Range("G" & BUL.Row + 4 & ":G" & BUL_CARİ_KOD.Row - 5) = Mid(BUL.Offset(0, 1), 1, InStr(1, BUL.Offset(0, 1), " ") - 1)
                If Sheets(CStr(S1.Cells(X, 3))).Range("A5") = "" Then
                   S2.Range("A" & BUL.Row & ":I" & BUL_CARİ_KOD.Row - 2).Copy Sheets(CStr(S1.Cells(X, 3))).Range("A1")
                Else
                   Satır = Sheets(CStr(S1.Cells(X, 3))).Range("C" & Rows.Count).End(3).Offset(2).Row
                   S2.Range("A" & BUL.Row & ":I" & BUL_CARİ_KOD.Row - 2).Copy Sheets(CStr(S1.Cells(X, 3))).Range("A" & Satır)
                End If
            End If
        End If
    Next
    
    Set BUL = Nothing
    Set BUL_CARİ_KOD = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Rainbows]

Öncelikle ilginiz icin tesekkürler.

ben sayfaları düzelttim. yalnız sadece 2-3 firmayı aktarıyor. dosyanın son halini ekliyorum inceleyebilirseniz sevinirim.

tesekkürler.

 

[Rainbows]

Korhan bey aktarım yapıyor. fakat mesela 3 tane diger firması var. sadece bir tanesini aktarıyor.

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.

 

[Rainbows]

Korhan bey cok tesekkür ediyorum. tam istedigim gibi oldu.sizden bir istegim daha olacak. ekli dosyaya bakabilirmisiniz. gerekli acıklamarı yaptım dosya icinde

tekrar yardımlarınız icin tesekkürler.

 

[Korhan Ayhan]

Selamlar,

Son eklediğiniz dosyanın bu konuyla bir bağlantısını kuramadım. Ayrı konu içerikleri için ayrı başlık açmanız gerekiyor.

 

[Rainbows]

Pardon. Başka konu acıyorum tesekkürler.