Bul - Düzenle - Aktar. (Çözülmedi !!!)

[REDonWHITE]

Değerli Üstadlar,

Başlıktada belirttiğim gibi, Bul-Düzenle-Kaydet mantığındaki makrolara ihtiyacım var. Detaylar anlaşılır şekilde eklemiş olduğum dosyada mevcut.

Konuyla ilgili forumda 1 aydır araştırıyorum, fakat bulduğum makrolarla sağlıklı birşey yapamadım. Hep birşeyler eksik kaldı.

 

[askm]

Eklediğiniz bağ-yapıştır ile olabilecek şekli için aşağıdaki kodlar işinize yarar sanırım.
İleri geri butonuna atayın.

Sub ASKM_Sırala()
    Sheets("Sayfa2").Select
    Sheets("Sayfa2").Range("C5:O100").AutoFilter
    Sheets("Sayfa2").Range("$C$5:$O$100").AutoFilter Field:=3, Criteria1:=Sheets("Sayfa1").Range("C3")
    Sheets("Sayfa1").Select
End Sub

 

[REDonWHITE]

Değerli Askm,

Öncelikle ilginizden ötürü teşekkür ederim.

Bu verdiğiniz kod sadece sayfa2'de filtreleme yapıyor.

 

[askm]

Sizin Bağ-yapıştır ile getirdiğiniz veri de sayfa2 deki alanın resmini alıyor zaten. Yani filtreli alanın resmini almış olacak.

 

[REDonWHITE]

Ben Sayfa2 resmini bilgi amaçlı olsun diye koydum.
Yapmak istediklerimi yazmıştım.

**Sayfa2'de Renklendirilmiş sütunlar SABİT, Gri sütunlar DEĞİŞKEN verilerdir.

Burada yapmak istediğim;

-KAYIT NO'ya değer girdiğimde; sarı buton yardımıyla Sayfa2'deki ilgili verileri yukarıdaki tabloda bulunan kırmızı çerçeveli alana getirmesi;
Ayrıca Yukarı/Aşağı butonları tıkladıkça ilgili KAYIT NO'ya ait verilen değişmesi.

- KAYIT NO'ya ait verileri silmek istediğimde Sayfa2'den tamamen silmesi ve
"C" ile "O" sütunları arasındaki hücrelerin yukarı kaydırılması.

-KAYIT NO'ya ait verilerde değişiklik yaptığımda , örneğin birden fazla model eklediğimde / çıkardığımda veya TARİH, FİRMA, AÇIKLAMA, ADRES değişikliği yaptığımda gerekli değişikliklerin Sayfa2'ye aktarılması.

- Yeni bir kayıt oluşturduğumda ise Kırmızı buton ile Sayfa2'ye eklenmesi.

NOT : yaklaşık 30.000 satır veri olacağından ileride makronun ağırlaşmadan yapması gerekiyor.

 

[askm]

Aşağıdaki şekilde deneyin.

Sub ASKM_Veri_Çek()
Dim s1, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Dim SonSat, SonSat1 As Long
SonSat = s2.Range("E" & Rows.Count).End(xlUp).Row
SonSat1 = s1.Range("A" & Rows.Count).End(xlUp).Row
s1.Range("A10:H" & SonSat1).ClearContents
a = 10
For i = 6 To SonSat
    If s1.Range("C3") = s2.Cells(i, "E") Then
        s1.Cells(a, 1) = a - 9
        s1.Cells(a, 2) = s2.Cells(i, "F")
        s1.Cells(a, 3) = s2.Cells(i, "G")
        s1.Cells(a, 4) = s2.Cells(i, "J")
        s1.Cells(a, 5) = s2.Cells(i, "K")
        s1.Cells(a, 6) = s2.Cells(i, "L")
        s1.Cells(a, 7) = s2.Cells(i, "N")
        s1.Cells(a, 8) = s2.Cells(i, "O")
        a = a + 1
    End If
Next i
MsgBox "Veriler aktarıldı...", vbInformation, "ASKM"

End Sub

 

[REDonWHITE]

Üstad bu kodla;

Sayfa2'den değişken sütunlardan veri çekebiliyorum, Sabit (Renkli) sütunlardan verileri çekmiyor. Diğer işlemlerde yardım edebilecekmisiniz?

 

[askm]

Sabit (Renkli) sütunlardan verileri çekmiyor.
Bu ne demek anlamadım. Verilerini Sayfa2 de C6 dan O 23 e kadar değil mi örneğinizde.

 

[REDonWHITE]

Renkli sütunlarda bulunan değerler,

Sayfa1'deki üst tarafta bulunan kırmızı işaretli alanada;
C4=TARİH
C5=FİRMA
C6=ADRES
C7=AÇIKLAMA
bilgilerinide getirmesinide istemiştim.

 

[askm]

Sub ASKM_Veri_Çek()
Dim s1, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Dim SonSat, SonSat1 As Long
SonSat = s2.Range("E" & Rows.Count).End(xlUp).Row
SonSat1 = s1.Range("A" & Rows.Count).End(xlUp).Row
s1.Range("A10:H" & SonSat1).ClearContents
a = 10
For i = 6 To SonSat
    If s1.Range("C3") = s2.Cells(i, "E") Then
        s1.Range("C4") = s2.Cells(i, "D")
        s1.Range("C5") = s2.Cells(i, "H")
        s1.Range("C6") = s2.Cells(i, "I")
        s1.Range("C7") = s2.Cells(i, "M")
        
        s1.Cells(a, 1) = a - 9
        s1.Cells(a, 2) = s2.Cells(i, "F")
        s1.Cells(a, 3) = s2.Cells(i, "G")
        s1.Cells(a, 4) = s2.Cells(i, "J")
        s1.Cells(a, 5) = s2.Cells(i, "K")
        s1.Cells(a, 6) = s2.Cells(i, "L")
        s1.Cells(a, 7) = s2.Cells(i, "N")
        s1.Cells(a, 8) = s2.Cells(i, "O")
        a = a + 1
    End If
Next i
MsgBox "Veriler aktarıldı...", vbInformation, "ASKM"

End Sub

 

[REDonWHITE]

Üstad elinize sağlık.

Herhangibir değişiklik yapıp sayfa2'ye (kayıtlı olduğu satırdan başlamak koşuluyla) aktarmasını,
ayrıca silmek istediğimizde kullanacağımız makro konusunda yardımcı olabilirseniz çok memnun olurum.

 

[askm]

Dosyanız ektedir.

 

[REDonWHITE]

Üstad gönderdiğiniz dosyayı inceledim. (emeğiniz için teşekkür ediyorum)

Dosyada tüm işlemlere ait Makrolar var fakat;

-"Verileri çekme" muntazam çalışıyor.
-"Değişiklikleri Güncelle" makrosunda; örneğin 5 satırlık veri çekip, bunun 2 satırını silip tekrar güncellediğimde, 3 satırı güncelliyor, sildiğim 2 satırlık veri Sayfa2'de silmiyor.
-"Yeni kayıt oluştur" makrosunda veri giriş sayfasında verileri siliyor (ok). Burda eklemek istediğim yeni kayıt oluştururken, benzersiz kayıt numarası vermesi (Sayfa2/kayıt no sütunundaki, max değer + 1 olacak şekilde) ayrıca,
Sıra no'sunu otomatik vermesi ve TARİH - FİRMA hücresi boş ise kayıt yapmasın uyarı vermesi.

 

[askm]

Acelesi yoksa hafta içi müsait olduğum zaman bakmaya çalışırım.

 

[antonio]

Merhaba,
Ekte ki dosyayı inceleyip dönüş yapabilirseniz, sorunu çözmek kolaylaşabilir.

 

[antonio]

15 No'lu mesajımdaki dosyayı güncelledim.

 

[REDonWHITE]

Üstadım öncelikle teşekkür ediyorum.

Dosyanızı inceledim;
(Ok tuşları ile verilerin gelmesi harika olmuş, herhangi bir sıkıntı görmedim)

(1).KAYIT NO hücresine manuel giriş yaptığımda veriler gelmiyor.

(2).Getirilen verilerde değişiklik yapıp "DEĞİŞİKLİĞİ KAYDET"i tıkladığımda:
*Renkli sütunlardaki (Tarih-Firma-Adres-Açıklama) değişiklileri, ilk satırdaki verilerde yapıyor, diğer satırlara uygulamıyor.
*sayfa1'deki alttaki kırmızı çerçevedeki detay verilerdeki düzeltmelerin hiçbirini yapmıyor. (satır silme/ekleme dahil)

(3).VERİLERİ TEMİZLE dediğimde ise; ilgili Kayıt Noya ait veri satırlarını siliyor,
ben "C" den "O" ya kadar olan sütundaki hücreleri yukarı kaydırılarak silinmesini istiyorum. yani A - B - P - Q - R ... sütunlarda değişiklik yapmamalı.

(4).YENİ KAYIT OLUŞTUR dediğimde sadece bir satırlık (Kayıt No-Tarih-Firma-Adres-Açıklama) veri atıyor.

 

[antonio]

KAYIT NO Hücresine sayıyı manuel olarak girdiğinizde verilerin gelmesi için aşağıdaki kodu aynen kopyalayıp, Sayfa1 e sağ tıkla >> "Kod Görüntüle" >> açılan pencereye yapıştırınız. Diğer durumlar için zaman bulursam bakmaya çalışacağım.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C3:F3]) Is Nothing Then
Call ozetleri_getir
End If
End Sub

 

[REDonWHITE]

Sayın antonio, teşekkür ediyorum.

(1) nolu sorun giderildi. Elinize sağlık.

Diğer sorunlar konusunda yardım edebilecek misiniz?

 

[antonio]

Modüle 1 içindeki tüm kodlarınızı silin, aşağıdakileri yapıştırın. Bir eksik varsa yine bakmaya çalışacağım.

Dim s1 As Worksheet, s2 As Worksheet, ss As Long, sat As Long, i As Long, _
    alan As Range, hcr As Range, k As Range, tarih As Range, firma As Range, _
    adres As Range, aciklama As Range, kayit_no As Range, z As Object, a, b, n As Long
Sub ozetleri_getir()
Set s1 = Sayfa1
Set s2 = Sayfa2
    ss = s2.Range("E" & Rows.Count).End(3).Row
    a = s2.Range("C6:O" & ss).Value
    ReDim b(1 To 8, 1 To UBound(a))
Set z = CreateObject("Scripting.Dictionary")
    z.CompareMode = vbTextCompare
    n = 1
    s = 1
    For i = 1 To UBound(a)
        fb = a(i, 4) & "#" & a(i, 5)
        If fb <> "" And a(i, 3) = s1.Range("C3") Then
            If Not z.exists(fb) Then
                z.Add fb, n
                z(fb) = n
                s = n
                n = n + 1
            ElseIf z.exists(fb) Then
                s = z(fb)
            End If
                ReDim Preserve b(1 To 8, 1 To n)
                b(1, s) = a(i, 1)
                b(2, s) = a(i, 4)
                b(3, s) = a(i, 5)
                b(4, s) = b(4, s) + a(i, 8)
                b(5, s) = a(i, 9)
                b(6, s) = a(i, 10)
                b(7, s) = a(i, 12)
                b(8, s) = a(i, 13)
        End If
    Next i
    s1.Range("A10:H15").ClearContents
    s1.Range("A10").Resize(s, 8).Value = Application.Transpose(b)
    Erase b
End Sub
Sub ozetleri_sil()
s1.Range("A10:H15").ClearContents
End Sub
Sub yerleri_belirle()
    Set s1 = Sayfa1
    Set s2 = Sayfa2
    ss = s2.Range("E" & Rows.Count).End(3).Row
    Set alan = s2.Range("E5:E" & ss)
    aranan = s1.Range("C3").Value
    Set k = alan.Find(aranan, , xlValues, xlWhole)
    If k Is Nothing Then
        s1.Range("C4:F7").ClearContents
        s1.Range("A10:H15").ClearContents
        Exit Sub
    End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    sat = k.Row
    Set tarih = s2.Range("D" & sat)
    Set firma = s2.Range("H" & sat)
    Set adres = s2.Range("I" & sat)
    Set aciklama = s2.Range("M" & sat)
End Sub
Sub yeni_kayit_ekle()
    Set s1 = Sayfa1
    Set s2 = Sayfa2
    ss = s2.Range("E" & Rows.Count).End(3).Row
    sat = ss + 1
    Set kayit_no = s2.Range("E" & sat)
    Set tarih = s2.Range("D" & sat)
    Set firma = s2.Range("H" & sat)
    Set adres = s2.Range("I" & sat)
    Set aciklama = s2.Range("M" & sat)
    
Application.ScreenUpdating = False
Application.DisplayAlerts = False
  If s1.Range("C4").Value = "" Or s1.Range("C4").Value = "" Then
    MsgBox "Tarih ve Firma bilgisi eksik, kayıt yapılamaz!", vbExclamation, "antonio"
    Exit Sub
  End If
  yeni_no = Application.WorksheetFunction.Max(s2.Range("E6:E" & ss)) + 1
    
  say = Application.WorksheetFunction.CountA(s1.Range("A10:A15"))
    For d = 0 To say - 1
  s2.Range("E" & sat + d).Value = yeni_no 'kayit no
  s2.Range("D" & sat + d).Value = s1.Range("C4").Value      'tarih
  s2.Range("H" & sat + d).Value = s1.Range("C5").Value     'firma
  s2.Range("I" & sat + d).Value = s1.Range("C6").Value     'adres
  s2.Range("M" & sat + d).Value = s1.Range("C7").Value     'açıklama X
  s2.Range("C" & sat + d).Value = s1.Range("A" & d + 10).Value  'SIRA NO
  s2.Range("F" & sat + d).Value = s1.Range("B" & d + 10).Value   'MODEL
  s2.Range("G" & sat + d).Value = s1.Range("C" & d + 10).Value    'SERİ
  s2.Range("J" & sat + d).Value = s1.Range("D" & d + 10).Value    'TUTAR
  s2.Range("K" & sat + d).Value = s1.Range("E" & d + 10).Value    'DİĞER-1
  s2.Range("L" & sat + d).Value = s1.Range("F" & d + 10).Value    'DİĞER-2
  s2.Range("N" & sat + d).Value = s1.Range("G" & d + 10).Value    'TARİH-1
  s2.Range("O" & sat + d).Value = s1.Range("H" & d + 10).Value    'TARİH-2
    Next d
Application.ScreenUpdating = True
Application.DisplayAlerts = True
    MsgBox "Yeni kayıt ilave işlemi tamamlandı.", vbInformation, "antonio"
            s1.Range("C4:F7").ClearContents
            s1.Range("A10:H15").ClearContents
End Sub
Sub verileri_sil()
Dim onay As VbMsgBoxResult
Call yerleri_belirle
'Set s1 = Sayfa1
'Set s2 = Sayfa2
'    ss = s2.Range("E" & Rows.Count).End(3).Row
aranan = s1.Range("C3").Value

    If k Is Nothing Then
        MsgBox "Mevcut kayıtların içinde, silinecek Kayıt No bulunamadı.", vbExclamation, "antonio"
        Exit Sub
    End If
onay = MsgBox(s1.Range("C3").Value & " Kayıt No'lu veriye ait bilgiler kalıcı olarak silinecektir." & vbCrLf & _
    "Silme işlemini onaylıyor musunuz?", vbYesNo, "antonio")
    If onay = vbNo Then Exit Sub
    
    For i = ss To 6 Step -1
        If s2.Range("E" & i).Value = aranan Then
            s2.Rows(i).EntireRow.Delete xlUp
        End If
    Next i
                s1.Range("C4:F7").ClearContents
            s1.Range("A10:H15").ClearContents

Application.ScreenUpdating = True
Application.DisplayAlerts = True
    MsgBox "Silme işlemi tamamlandı.", vbInformation, "antonio"
End Sub
Sub verileri_guncelle()
Call yerleri_belirle
    If k Is Nothing Then
        MsgBox "Mevcut kayıtların içinde, güncellenecek Kayıt No bulunamadı.", vbExclamation, "antonio"
        Exit Sub
    End If
Set tarih = s1.Range("C4")
Set firma = s1.Range("C5")
  If tarih.Value = "" Or firma.Value = "" Then
    MsgBox "Tarih ve Firma bilgileri girilmeden güncelleme yapılamaz!", vbExclamation, "antonio"
    Exit Sub
  End If
  adr = k.Address
  sat = k.Row
  sabit = 9
  Do
  sabit = sabit + 1
  sat = k.Row
  s2.Range("C" & sat).Value = s1.Range("A" & sabit).Value     'SIRA NO
  s2.Range("D" & sat).Value = s1.Range("C4").Value     'tarih
  s2.Range("E" & sat).Value = s1.Range("C3").Value     'kayıt no
  s2.Range("F" & sat).Value = s1.Range("B" & sabit).Value   'MODEL
  s2.Range("G" & sat).Value = s1.Range("C" & sabit).Value    'SERİ
  s2.Range("H" & sat).Value = s1.Range("C5").Value     'kayıt no
  s2.Range("J" & sat).Value = s1.Range("D" & sabit).Value    'TUTAR
  s2.Range("K" & sat).Value = s1.Range("E" & sabit).Value    'DİĞER-1
  s2.Range("L" & sat).Value = s1.Range("F" & sabit).Value    'DİĞER-2
  s2.Range("N" & sat).Value = s1.Range("G" & sabit).Value    'TARİH-1
  s2.Range("O" & sat).Value = s1.Range("H" & sabit).Value    'TARİH-2
Set k = alan.FindNext(k)
Loop While adr <> k.Address And Not k Is Nothing
Set s1 = Nothing
Set s2 = Nothing
Set alan = Nothing
Set k = Nothing
Set tarih = Nothing
Set firma = Nothing
Set adres = Nothing
Set aciklama = Nothing
aranan = 0
sat = 0
Call ozetleri_getir
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Bilgiler güncellendi.", vbInformation, "antonio"
End Sub
Sub kayit_no_bul()

    Call yerleri_belirle
    If k Is Nothing Then
            MsgBox "Firma Bulunamadı.", vbExclamation, "antonio"
        Exit Sub
    End If
    s1.Range("C4").Value = tarih.Value    'tarih
    s1.Range("C5").Value = firma.Value   'firma
    s1.Range("C6").Value = adres.Value   'adres
    s1.Range("C7").Value = aciklama.Value   'açıklama X
    
    Call ozetleri_getir
    
Set s1 = Nothing
Set s2 = Nothing
Set alan = Nothing
Set k = Nothing
Set tarih = Nothing
Set firma = Nothing
Set adres = Nothing
Set aciklama = Nothing
aranan = 0
sat = 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub