• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Useformda Alt alta çoklu kayıtta yardım

  • Konbuyu başlatan Konbuyu başlatan fatih34
  • Başlangıç tarihi Başlangıç tarihi
F

fatih34

Katılım
2 Ekim 2007
Mesajlar
359
Excel Vers. ve Dili
2010
Üstadlarım iş yerinde hazırladığım Useformla gelen evrakları Sayfa1 deki tabloya kayıt yaptırıyorum. Ve A sütununa verdiği sayıyı gelen evrağın üzerine yazıyorum.

Ancak bazı evraklarda gelen evrak içerisinde birden fazla şikayetçi olunan kişiler bulunmakta. Bunları ayrı ayrı kayıt yaptığım taktirde aynı evrağa fazladan sayı vermek zorunda kalıyorum. Bunun önüne geçmek için A, B,C,D,E,F sütunlardaki bilgiler aynı olacak sadece G sütunundaki bilgiler farklı olacak
İnşallah Anlata bilmişimdir.
 

Ekli dosyalar

Son düzenleme:
her halde bu konuda yardımcı olan yokmu veya başka bir önerisi olan arkadaşlar yokmu
 
Merhaba,
Aşağıdaki kodu dener misiniz.

Not: Şikayetcileri tek satıra yanyana yazmak daha iyi olmaz mı?
Kod: 
Private Sub CommandButton1_Click() 'KAYDET TUŞU (Yeni veri girişi için kullanılmaktadır.)
   Sheets("Sayfa1").Select
    Satır = Range("B65536").End(3).Row + 1 ' Değiştirilen Satır----- A kolonu yerine B kolonu alındı---------
 
    '1 - Doğru veri tabanı oluşturmak için kullanıcının tüm verileri girmesi gerekmektedir.
    'Aşağıdaki sorgularla personele ait tüm bilgilerin girilmesini zorunlu kılıyoruz.
 
    If TextBox1.Text = "" Then
       TextBox1.SetFocus
    Exit Sub
    End If
     If TextBox2.Text = "" Then
       TextBox2.SetFocus
    Exit Sub
    End If
     If TextBox3.Text = "" Then
     TextBox3.SetFocus
    Exit Sub
    End If
     If TextBox4.Text = "" Then
        TextBox4.SetFocus
    Exit Sub
    End If
     If TextBox5.Text = "" Then
     TextBox5.SetFocus
    Exit Sub
    End If
     If TextBox6.Text = "" Then
     TextBox6.SetFocus
    Exit Sub
    End If
        '3 - Kayıt işlemi için gerekli bilgileri ilgili hücrelere aktarıyoruz.
    'Cells(Satır, "A") = Satır - 1
    Cells(Satır, "A") = WorksheetFunction.Max(Range("A2:A" & Satır)) + 1 ' Değiştirilen Satır------
    Cells(Satır, "B") = TextBox1.Text
    Cells(Satır, "C") = TextBox2.Text
    Cells(Satır, "D") = TextBox3.Text
    Cells(Satır, "E") = TextBox4.Text
    Cells(Satır, "F") = TextBox5.Text
    Cells(Satır, "G") = TextBox6.Text
'-----------------------------------------Eklenen Kod---------------------------
If Cells(Satır, 2).Value = Cells(Satır - 1, 2).Value Then
    If Cells(Satır, 3).Value = Cells(Satır - 1, 3).Value Then
        If Cells(Satır, 4).Value = Cells(Satır - 1, 4).Value Then
            If Cells(Satır, 5).Value = Cells(Satır - 1, 5).Value Then
                If Cells(Satır, 6).Value = Cells(Satır - 1, 6).Value Then
                    Application.DisplayAlerts = False
                    Range("A" & Satır - 1 & ":A" & Satır).Merge
                    Application.DisplayAlerts = True
                    Range("A" & Satır - 1 & ":A" & Satır).Select
                    With ActiveCell
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .MergeCells = True
                    End With
                End If
            End If
        End If
    End If
End If
'------------------------------Eklenen Kod Sonu ----------------------------------
       MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation, "Kayıt İşlemi"
    Unload Me
UserForm1.Show
End Sub
 
hocam ilginizden dolayı teşekkür ederim. Dediğiniz doğru ancak, aynı satıra isimleri yazdığım takdirde,
örnek olarak Ahmet, Fatih,ali, zeynep diye kayıt yaptım. İlerleyen zamanda ali hakkında kayıt varmı diye arama yaparsam kaydı getirirmi.
 
fatih34' Alıntı:
..., aynı satıra isimleri yazdığım takdirde,
örnek olarak Ahmet, Fatih,ali, zeynep diye kayıt yaptım. İlerleyen zamanda ali hakkında kayıt varmı diye arama yaparsam kaydı getirirmi.
Genişletmek için tıkla ...

Merhaba,
Aynı satıra yazılan isimleri de bulmak mümkündür. Sorun oluşturmaz.
Mevcut durumu değiştirmeden yukarıdaki kodun işe yarayıp yaramadığını merak ettim.
 
Hocam teşekkür ederim vermiş olduğunuz kodlar işe yarar. İnşallah benim gibi diğre acemi arkadaşlara da yol gösterir örnek çalışma. Hocam elimden geldiği kadarı ile bir şeyler yapmaya çalışıyorum. Sizin gibi değerli hocalarımın kafasını epey ağrıtacağım. Bundan dolyı kusura bakmayın . Siz ve diğre hocalarımızdan Allah razı olsun .Elimde kaynak var lakin inanın form daha yaralı oluyor. Çünkü orada aradığımı bulamıyorum.
 
dEdE' Alıntı:
Merhaba,
Aynı satıra yazılan isimleri de bulmak mümkündür. Sorun oluşturmaz.
Mevcut durumu değiştirmeden yukarıdaki kodun işe yarayıp yaramadığını merak ettim.
Genişletmek için tıkla ...

Ayrıca hocam kodun çalışma şeklini de çözmeye çalışıyorum. En azından bir şeyler öğreniriz.
 
Sayın Dede hocamın yardımıyla problem çözüldü. Ancak benim acemiliğimden yaptıkça eksiklikler çıkıyor. Aynı şekilde kayıt yaparken U sütünundan başlayıp AD sütununa kadar olan satırlarıda tek tek birleştirmek istiyorum. Bu konuda bir yardım. İnşallah istediğimi tam olarak anlata bilmişimdir.
 

Ekli dosyalar

Merhaba,
Kodunuzun içinde ---Eklenen Kod---- olarak işaretlenmiş bölümü aşağıdaki kod ile değiştirip dener misiniz?
Kod: 
'-----------------------------------------Eklenen Kod---------------------------
If Cells(Satır, 2).Value = Cells(Satır - 1, 2).Value Then
    If Cells(Satır, 3).Value = Cells(Satır - 1, 3).Value Then
        If Cells(Satır, 4).Value = Cells(Satır - 1, 4).Value Then
            If Cells(Satır, 5).Value = Cells(Satır - 1, 5).Value Then
                If Cells(Satır, 6).Value = Cells(Satır - 1, 6).Value Then
                    Application.DisplayAlerts = False
                    With Range("A" & Satır - 1 & ":A" & Satır)
                        .Merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With
                    For i = 21 To 30
                    With Range(Cells(Satır - 1, i), Cells(Satır, i))
                        .Merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With
                    Next
                    Application.DisplayAlerts = True
                End If
            End If
        End If
    End If
End If
'------------------------------Eklenen Kod Sonu ----------------------------------
 
Teşekkür ederim Hocam İlginizden ve alakanızdan. Elinize ve Emeğinize Sağlık. Allah Razı Olsun. Hemen önceki kod ile yeni kodları karşılaştırmaya başladım. Mantığı çözmek için
 
sayın dede hocam vermiş olduğunuz kod üzerinde denemeler yaptım ancak tam oalrak başaramadım. Çalışma sayfamda bir kaç değişiklik yaptım. Bunları da birleştirmeye çalıştım Ancak tam olarak beceremedim. Değişken atadım ancak tam olarak istediğimi yapamadım.
Kaydın otomatik sayısını kırmızı renkli olan yere yaptıracağım hocam. Sarı renkli olan hücrelerinde birleştirilmesi konusunda tekrar yol gösterirseniz sevinirim.
 
Son düzenleme:
Sayın dede hocamon yardımıyla kayıt yaptırdım. Ancak benim acemiliğimden bir kaç sorunla karşılaştım.
1. Sorunum Aynı evrakta birden fazla personeli tek tek yazmam oldu. Buda zaman kaybına yol açtı.
Aynı anda alt alta olacak şekilde fazla personeli nasıl kayıt yapa bilirim. Aynı evrakta 2 personelden başlayıp bu sayıyı bazsen 20'yi bulmakta
ekte anlatmaya çalıştım.
 

Ekli dosyalar

Dede hocam kusura bakmayın, vermiş olduğunuz kodda çalıştım ama beceremedim. Sarı renkle belirttiğim sütünlarıda birleştirmek için verdiğiniz koda ne eklemek lazım
 

Ekli dosyalar

Merhaba,
Eklediğiniz dosyada sarı renkte isaretlediğniz alanı birleştirir.
Kod: 
Sub birlestir()
Application.DisplayAlerts = False
For i = 2 To 7
    With Range(Cells(2, i), Cells(11, i))
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
Next
Application.DisplayAlerts = False

For i = 11 To 16
    With Range(Cells(2, i), Cells(11, i))
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
Next

    With Range(Cells(2, 19), Cells(11, 19))
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    With Range(Cells(2, 21), Cells(11, 21))
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    
For i = 24 To 34
    With Range(Cells(2, i), Cells(11, i))
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
Next

Application.DisplayAlerts = True
End Sub
 
Hocam İlginize ve alakanıza teşekkür ederim. Size zahmet verdim. Hakkınız helal edin. Emeğiniz geçiyor. Bende akşamdan beri uğraşıyorum. Şöyle bir kod yazıp uyguladım . Birleştirmeleri becerdim ancak alt satıra geçip veriyi kaydedemedim.Aynı yere kayıt yapıyor.


If Cells(Satır, 2).Value = Cells(Satır - 1, 2).Value Then
If Cells(Satır, 3).Value = Cells(Satır - 1, 3).Value Then
If Cells(Satır, 4).Value = Cells(Satır - 1, 4).Value Then
If Cells(Satır, 5).Value = Cells(Satır - 1, 5).Value Then
If Cells(Satır, 6).Value = Cells(Satır - 1, 6).Value Then
Application.DisplayAlerts = False
With Range("A" & Satır - 1 & ":A" & Satır)
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
For i = 2 To 7
With Range(Cells(Satır - 1, i), Cells(Satır, i))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Next
Application.DisplayAlerts = True
For k = 11 To 16
With Range(Cells(Satır - 1, k), Cells(Satır, k))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Next
Application.DisplayAlerts = True
For j = 22 To 35
With Range(Cells(Satır - 1, j), Cells(Satır, j))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Next
Application.DisplayAlerts = True
End If
End If
End If
End If
End If
 
Hocam 9.Mesajınızda vermiş olduğunuz kodun ekle bölümüne mi ekleyeceğim yoksa farklı bir modülemi ekleyeceğim.
 
Sayın dede hocamın verdiği kodu çalışmama uyguladım. Sayfa1' personelle ilgili şikayet konularını yazıyorum. Bazen aynı evrak içerisinde tek personel bazen ikiden fazla personel bulunuyor.
T sütununa otomatik sayı verdirip gelen evrak sayısı diye not alıyorum evrağın üzerine Dede hocamın 9.mesajda vermiş olduğu kodu da bu çalışmaya uyguladım.

1. Sorunum 2 ile 7 sütunlar ile 11 - 16 sütunların da aynı şekilde fazla personelle alakalı kayıt yaptığımda birleştirmesini istiyorum. Bunu sadece fazla personel ile ilgili kayıt yaptığımda bu şekilde kayıt yapması tek personel girecek olursam normal kayıt yapması veya başka bir yol gösterirseniz de sevinirim.
 

Ekli dosyalar

çoklu personel kaydında yardım

Personelle ilgili şikayetleri bir defter yerine örnekte yaptığım şekilde form hazırladım.
Gelen evrakda şikayet edilen tek personel kaydında sorun yok.

Ancak bazı evraklarda şikayet edilen personel sayısı fazla oluyor.

Bunu Userform2 ile sayfa1 de mavi renkte belirttiği şekilde nasıl kayıt yapa bilirim.

Sadece çoklu personel kaydı veya tek personel kaydına ek personel eklediğimde bu şekilde olmasını istiyorum.
 

Ekli dosyalar

Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst