Aramak ve Bulunan veriyi başka bir sayfaya yazmak

[relaxim]

Hatırlatayım dedim.
Saygılarımla.

 

[Korhan Ayhan]

Merhaba,

Boş bir modüle aşağıdaki kodu uygulayın.

Function Sayfa_Kontrol(Sayfa_Adı As String) As Boolean
    On Error Resume Next
    Sayfa_Kontrol = CBool(Len(Worksheets(Sayfa_Adı).Name) > 0)
End Function

Daha sonra "GENEL" isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayın. "A" sütununda bir hücreye çift tıkladığınızda işleminiz gerçekleşecektir.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Satır As Long, Bul As Range, Adres As String, SG As Worksheet
    Set SG = Sheets("GENEL")
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    If Target.Row < 2 Then Exit Sub
    Cancel = True
    If Target <> "" Then
        If Sayfa_Kontrol(Target.Text) = True Then
            With Sheets(CStr(Target))
                .Select
                Set Bul = SG.Cells.Find(Target, , , xlWhole)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        If WorksheetFunction.CountIf(.Range("C:C"), SG.Cells(Bul.Row, "C")) = 0 Then
                            Satır = .Cells(Rows.Count, 1).End(3).Row + 1
                            .Range("A" & Satır & ":K" & Satır).Value = SG.Range("A" & Bul.Row & ":K" & Bul.Row).Value
                        End If
                        Set Bul = SG.Cells.FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                End If
            End With
            MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
        Else
            Set Yeni_Sayfa = Sheets.Add
            With ActiveSheet
                .Move After:=Sheets(Worksheets.Count)
                .Name = Target
                .Range("A1:K1").Value = SG.Range("A1:K1").Value
                .Range("A1:J1").HorizontalAlignment = xlCenter
                .Range("A1:J1").Font.Bold = True
                
                Set Bul = SG.Cells.Find(Target, , , xlWhole)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        If WorksheetFunction.CountIf(.Range("C:C"), SG.Cells(Bul.Row, "C")) = 0 Then
                            Satır = .Cells(Rows.Count, 1).End(3).Row + 1
                            .Range("A" & Satır & ":K" & Satır).Value = SG.Range("A" & Bul.Row & ":K" & Bul.Row).Value
                        End If
                        Set Bul = SG.Cells.FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                End If
                
                .Cells.EntireColumn.AutoFit
            End With
            MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
        End If
    End If
    
    Set Bul = Nothing
    Set SG = Nothing
End Sub

 

[relaxim]

Korhan Bey ilgi emek için teşekkürler. Ben beceremedim. Acaba örneğime uygulayarak ekleyebilirmisiniz. Tekrar teşekkürler...

 

[Korhan Ayhan]

Merhaba,

Bu işlem için dosya eklemeye gerek varmı?

Yapmanız gerekenleri tekrar tarif ediyorum.

ALT+F11 tuşlarına basıp kod editörünü açın.
INSERT menüsünü kullanarak çalışmanıza boş bir modül ekleyin. Sağ tarafta boş beyaz bir pencere açılacak. İlk verdiğim kodu bu pencereye aktarın ve kod editörü penceresini tamamen kapatın.
Şimdi karşınızda excel sayfası görünecek.
"GENEL" isimli sayfanızın sekmesi üzerinde sağ klik yapın ve KOD GÖRÜNTÜLE seçeneğini seçin.
Karşınıza sayfanızın kod penceresi açılacaktır. İkinci verdiğim kodu bu pencereye aktarın.
Excel sayfasına dönün ve "A" sütununda bir hücreye çift tıklayın.

Not : Kodlarda daha önce aktarılmış verilerin kontrolü için "C" sütunundaki belge numarası kontrol edilmektedir. Eğer "C" sütununda boş alanlar varsa sorun yaşayabilirsiniz. Başka türlü çözüm bulmak gerekebilir.

 

[relaxim]

Sn Korhan Bey ilginiz için tekrar teşekkürler. Evdeki laptop da Fn+F11 tuşu grafik açıyor anlamadım. İşyerindeki blg. da denedim çalışıyor. Ancak; belirttiğiniz gibi C sütununda boş ve benzer kayıtlar olduğu için aynı firmayı tekrar denediğimizde boş olanları tekrar ekliyor. Bunun için mesela T sütununa verinin girildiği tarih+saat numaraya çevirip benzersiz sütunlar oluşturup, C yerine T sütununu kontrol ettirmeye çalışacağım. Yapamazsam tekrar yardımlarınızı rica edeceğim.

Tekrar teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Kod editörünü açmak için ARAÇLAR-MAKRO-VISUAL BASIC DÜZENLEYİCİSİ menüsünüde kullanabilirsiniz.

Aktarılan veri için boş bir sütuna sembolik bir ifade ("OK" - "X" - "AKTARILDI" gibi) yazdırıp ikinci aktarımda bu alanı sorgulatabilirsiniz. Yapamazsanız yardımcı olurum.

 

[relaxim]

Sn Korhan Bey merheba,

C sütununa Eğer(A2<>"";C1+1;"") bir arttırarak benzersiz kayıt oluşturup aktarmayı hallettim. Tabii K sütunu yerine L olacak şekilde düzenledim. Şimdiki hedefim firmaları gruplayıp daha az sayfa açmak olacak. Yardımlarınız için teşekkürler.

 

[alp_78]

Merhaba;

Öncelikle emeği gecen tüm arkadaşlara teşekkürler bir çok kişinin soruna çözüm bulmuşsunuz. Bu konu altında konu açmamın nedenı bu konuya benzer bir sorum olmasından, soruma gelınce;
50 bin kişilik isim soyisim adres fatura ve ödemediği borç vs. bilgilerini içeren aynı çalışma kitabı içinde farklı sayfalara bölünmüş bir veri tablom var. boş bir sayfada arama butonu ekleyerek o butona isim soyisim veya kişiye ait bir bilgi girdiğimde o kişiye ait verileri başka bir sayfaya yazacak yazılan boş sayfada kişinin tüm borçlarını toplayacak bir uygulama yapmam gerekiyor yardımcı olabilir misiniz

 

[ikikan]

Merhaba,

Aşağıdaki kodlar Süzülmüş olan veriyi ilgili sayfaya aktarır.
Umarım işinize yarar.

Sub Suz_ve_Aktar()
 
    Dim SonSat  As Long, _
        Olcut   As String, _
        s2      As Worksheet
    
    Sheets("GENEL").Select
    With Sheets("GENEL")
        If .AutoFilterMode Then
            With .AutoFilter.Filters(1)
               [COLOR="Red"] If .On Then Olcut = .Criteria1[/COLOR]
            End With
        End If
    End With
    If Olcut = "" Then Exit Sub
    Olcut = Replace(Olcut, "=", "")
    
    If Not SayfaVarMi(Olcut) Then
        Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = Olcut
        Sheets("GENEL").Select
    End If
    
    Range("A1").Activate
    
    Set s2 = Sheets(Olcut)
    On Error Resume Next
    SonSat = s2.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    If SonSat = 0 Then SonSat = 1
    Range("A1").CurrentRegion.Copy s2.Range("A" & SonSat)
    If SonSat > 1 Then s2.Rows(SonSat).Delete
    MsgBox "İşlem Tamam..."
    
End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function

Birden fazla seçim yapılınca kırmızı alan hata veriyor Array işlemini dahil etmenin bir yolu varmıdır ?

Örnek seçim
.AutoFilter Field:=1, Criteria1:=Array( "ankara", "konya", "malatya"), Operator:= xlFilterValue