2 tabı birleştirip A-Z sıralaması yaptırmak.

[chakmakci]

Arkadaşlar elimde iki ayrı isim listesi var. Bu listeleri ayrı ayrı tutmam gerekiyor. Bunları excelde tab olarak A listesi ve B listesi olarak kaydettim. Ancak kolaylık olsun diye bunların hepsini ayrı bir tabda ve alfabetik sırada olacak şekilde birleşmesini istiyorum. Ayrıca hepsine baktıgımda ve ismi sildiğimde o ilgili bulunan tabdan da silinmesini istiyorum. Mesela A tabında bulunan Ahmet ismini Hepsini içeren tabda sildiğimde oradanda silinmesi gerek.

Örnek dosya ektedir.

 

[Necdet]

Merhaba,

Aşağıdaki kodu bir modüle kopyalayınız.

Sub Birlestir()
Dim i    As Long
Dim j    As Long
Dim s    As Integer
Dim sh   As Worksheet
Set sh = Sheets("Hepsi")
sh.Select
Application.ScreenUpdating = False
Range("A:B").ClearContents
[A1] = "Sayfa"
[B1] = "Değer"
For s = 1 To Sheets.Count
   If Sheets(s).Name <> "Hepsi" Then
      i = [B65536].End(3).Row + 1
      j = Sheets(s).[A65536].End(3).Row
      Sheets(s).Range("A1:A" & j).Copy Range("B" & i)
      Range("A" & [A65536].End(3).Row + 1 & ":A" & [B65536].End(3).Row) = Sheets(s).Name
      
   End If
   
Next s
Range("A2:B" & [B65536].End(3).Row).Sort Key1:=[B1]
Application.ScreenUpdating = True
End Sub

Aşağıdaki kodları ise "Hepsi" sayfasının kod bölümüne kopyalayınız.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 
   Dim c       As Range
   Dim Addr    As String
   Dim Aranan  As String
   Dim Syf     As String
   Dim Evet    As String
   Application.ScreenUpdating = False
   If Range("A" & Target.Row) = "" Then Exit Sub
   Aranan = Range("B" & Target.Row)
   Syf = Range("A" & Target.Row)
   Evet = MsgBox(Aranan & " Silinecektir, Emin misiniz?", vbYesNo, "[URL="http://www.excel.web.tr"]www.excel.web.tr[/URL] ---- Satır Silme")
   If Evet = vbYes Then
      Set c = Sheets(Syf).Range("A:A").Find(Aranan, LookIn:=xlValues, LookAt:=xlWhole)
      If Not c Is Nothing Then
         Sheets(Syf).Rows(c.Row).Delete
         Rows(Target.Row).Delete
      End If
   End If
   SendKeys "{ENTER}", True
   Application.ScreenUpdating = True
End Sub

Hepsi sayfasında bilgileri birleştirdikten sonra herhangi bir satırda herhangi bir hücreye Çift Tıklayarak ilgili satırı silebilirsiniz.

Not Türkçemiz Adına : Güzel Türkçemizde Ch harfinin olmadığını anımsatayım.

 

[Ergün Güler]

Sayın Necdet Yeşertener,
Hocam çok güzel bir çözüm olmuş. yazdığınız kodların yanlarına kısaca izahlarını yapabilmeniz mümkün müdür?
iyi çalışmalar.

 

[chakmakci]

Sayın Necdet Yeşertener, çok teşekkür ederim gerçekten çok güzel olmuş. Bu kadar kısa sürede cevap geleceğinide ummuyordum, buyüzden teşekkürüm biraz geç oldu.

Ancak bir iki değişiklik yapma şansımız varmı.

1- Sayfaları birleştir butonuna gerek duymadan otomatik olarak birleştirebilirmi.

2- A ve B haricinde C D gibi yeni tablar eklemek istediğimde kodlara ne gibi ekleme yapmam lazım
3- Değer ve Sayfa sütünlarının yerini değiştirmem için kodlarda ne gibi bir değişiklik yapmam lazım. Yani isimlerin birinci sütünda hangi taba ait olduklarının ikinci sütünda olmasını istiyorum.

Yardımlarınız iiçin şimdiden teşekürler.

Nick seçimi ile ilgili uyarınızı dikkate aldım, ancak kayıt olurken rast gele alalade bir seçim di bemin için bu yönürü hiç düşünmedim.

 

[Necdet]

Merhaba,

1. Sorunuz olabilir ama sanki xl yi zorlar gibi geliyor, neden istediğinizi söylerseniz üzerinde çalışılabilinir.
2. Sorunuz için herhangi birşey yapmanıza gerek yok, kodlarda zaten o mantığı kullandım, xl nin açabileceği kadar Sayfa (tab değil) açabilirsiniz, Tabi o sayfalardaki verilerin boyutu önemli birleştirme yapıldığında.
3. sorunuz için kodları aşağıdaki şekilde değiştirmek gerek.

Sub Birlestir()
Dim i    As Long
Dim j    As Long
Dim s    As Integer
Dim sh   As Worksheet
Set sh = Sheets("Hepsi")
sh.Select
Application.ScreenUpdating = False
Range("A:B").ClearContents
[A1] = "Değer"
[B1] = "Sayfa"
For s = 1 To Sheets.Count
   If Sheets(s).Name <> "Hepsi" Then
      i = [A65536].End(3).Row + 1
      j = Sheets(s).[A65536].End(3).Row
      Sheets(s).Range("A1:A" & j).Copy Range("A" & i)
      Range("B" & [B65536].End(3).Row + 1 & ":B" & [A65536].End(3).Row) = Sheets(s).Name
 
   End If
 
Next s
Range("A2:B" & [B65536].End(3).Row).Sort Key1:=[A1]
Application.ScreenUpdating = True
End Sub

 

[chakmakci]

1. sini istememin sebebi şu; bu dosya herkesin ulaşabileceği ortak bir yerde bulunuyor ve bir çok kişi tarafından görüntüleniyor. Zaten sayfaları tek sayfada birleştirmeyi istememin sebebi de buydu, tek tek bütün sayfalara girmeye gerek kalmadan tek sayfada ctrl+f ile bakıldıgında ismi bir seferde arayabilmeleri ve bulduklarında ise hangi sayfada oldugunu görebilmeleriydi. Fakat herkesin excel bilgisi aynı olmuyor. Oradaki butonun farkında bile olmayacak, tıklamayı her dosyayı açtıgında unutacak, yada ne işe yaradığını bilmeyecek kadar bilgisi az olan çalışma arkadaşlarım var. Eğer bunu butonsuz yaparsak hem ben onların olası sorularına maruz kalmam ve A-B-C sayfalarına girdiğim isimler buton gerektirmeden onlar her dosyayı açtıgından otomatik güncellenir, hemde arkadaşlarım aradığı ismi bulamayınca soluğu benim yanımda almazlar. Ekleme: Veri miktarı en fazla 1000 satır olacak toplamda umarın fazla değildir.

Çift tıklayınca silme uyarısında Değer yerine Sayfa çıkıyor bunun Değer olması için ne yapmam lazım.
Düzeltme: Bunu yaptım sanırım; Aşadıdaki satırda koyu olan yerdeki A ları B, B leri A yaptım. Umarım doğrudur. Denedim çalışıyor ama öngöremediğim bir sorun yaratırmı bilemiyorum.
If Range("A" & Target.Row) = "" Then Exit Sub
Aranan = Range("B" & Target.Row)
Syf = Range("A" & Target.Row)



Son bir sorum daha olacak, diğer kullanıcıların değişiklik yapmaması için yazmaya karşı koruma nasıl yapabilirim. XL 2003 için yaptım ama ilk açılışta parola istiyor yada salt okunur açın diyor. Bunu yaptım daha önce sayfa açılmıyor diye gelenler oldu Daha farklı bir yolu varmıdır acaba.

Gerçekten beklentimin ötesinde olduğunu söylemeliyim, tekrar teşekkür ederim.