veri listesini yan sekmede başlıklar halinde açma

[gelibolu]

İyi akşamlar üstadlar.
Bir listem var personel adı soyadı ve nöbet yerlerinden oluşuyor.
Bunu yan sekmeye gruplar halinde yazabilen bir çalışma vardı bulamadım.
Bahçede tutanlar altında isimleri, sonra koridor nöbeti tutanlar altında isimleri gibi.
Yardımcı olur musunuz?

 

[alicimri]

Eğer listeniz Sayfa1de, İsim A sütununda, Nöbet yeri B sütununda ve 1. satırda başlıklar, veriler 2. satırdan başlıyor ise, Verileri gruplayarak Sayfa2ye aktaran kod aşağıda

Sub Makro1()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
say = s1.Cells(Rows.Count, 1).End(3).Row
For i = 2 To say
If i = 2 Then
sut = 1
Else
sut = s2.Cells(1, Columns.Count).End(1).Column + 1
End If
If InStr(nob, s1.Cells(i, 2)) = 0 Then
    s1.Range("A1:B" & say).AutoFilter Field:=2, Criteria1:=s1.Cells(i, 2)
    s1.Range("A2:A" & say).Copy s2.Cells(2, sut)
    s2.Cells(1, sut).Value = s1.Cells(i, 2)
      s1.Range("A1").AutoFilter
      nob = nob & s1.Cells(i, 2)
   End If
    Next
 Stn = s1.Range("h1").Value
Set tam = s2.Range("A1").CurrentRegion
tam.Borders.LineStyle = xlContinuous
sat = tam.Rows.Count
For e = Stn + 1 To (tam.Columns.Count) Step Stn
Range(s2.Cells(1, e), s2.Cells(sat, e + Stn - 1)).Copy s2.Range("A" & s2.Cells(Rows.Count, 1).End(3).Row + 4)
Next
tam.Offset(0, Stn).Resize(tam.Rows.Count, tam.Columns.Count - Stn).Delete
End Sub

 

[gelibolu]

Teşekkür ederim Ali Bey aradığım buydu. Çok faydalı olacak.
Yalnız ufak bir geliştirme yapabilir miyiz.
sütunlar sağa doğru uzuyor. bu da aynı sayfada bilgileri toplamayı zorlaştırıyor.

Sütun adedini ben belirlesem. Mesela 6 sütundan sonra 2-3 satır bırakıp aşağıda örneğin A17 hücresinden devam edebilir mi?
Nöbet grupları 1-15 arasında , yaklaşık 18 grup var mümkün mertebe 1 sayfada toplamak istiyorum.
Teşekkür ederim.

 

[alicimri]

#2deki kodları yeniledim.
Stn = s1.Range("h1").Value kodu ile sütun sayısını belirliyoruz
Sayfa1 h1 hücresine 6 yazın.

 

[gelibolu]

Sayın Ali Cimri 2. güncellemede liste oluşuyor ancak makro Debug veriyor.
Kaç sütun olacağını sormuyor.
Yeni isim eklediğim zaman eski listeyi temizlemediği için yanına ekliyor

 

[gelibolu]

Sayın Ali Cimri 2. güncellemede liste oluşuyor ancak makro Debug veriyor.
Kaç sütun olacağını sormuyor.
Yeni isim eklediğim zaman eski listeyi temizlemediği için yanına ekliyor

Affedersiniz h1 e değer girince oldu. Ancak 2 numaralı nöbeti 5 kişi yapınca grubu 5 li yapmadı 4 lü kaldı. Hikmet görünmüyor.

 

[alicimri]

Bu kodu bir düğmeye bağlayın, sütun sayısını Inputbıx dan alıyor.

Sub Makro1()
Application.ScreenUpdating = False
NSayısı = InputBox("Sütun Sayısı Girin", "NÖBET SAYISI", Default)
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Cells.Delete
say = s1.Cells(Rows.Count, 1).End(3).Row
bol = NSayısı
 e = 1
 sat = 1
For i = 2 To say
If InStr(nob, s1.Cells(i, 2)) = 0 Then
    s1.Range("A1:B" & say).AutoFilter Field:=2, Criteria1:=s1.Cells(i, 2)
    s1.Range("A2:A" & say).Copy s2.Cells(sat + 1, e)
    s2.Cells(sat, e).Value = s1.Cells(i, 2)
    s2.Cells(sat, e).CurrentRegion.Borders.LineStyle = xlContinuous
     s2.Rows(sat).Font.Bold = True
     s2.Rows(sat).HorizontalAlignment = xlCenter
      s1.Range("A1").AutoFilter
      nob = nob & s1.Cells(i, 2)
    e = e + 1
 If e = bol + 1 Then
 sat = sat + s2.Cells(sat, e).CurrentRegion.Rows.Count + 1
  e = 1
 End If
   End If
    Next
    s2.Range(s2.Cells(1, 1), s2.Cells(1, bol * 1)).EntireColumn.AutoFit
    s2.Activate
    Application.ScreenUpdating = True
End Sub

 

[alicimri]

#7 deki kodu tekrar biraz daha değiştirdim.

 

[gelibolu]

Evet böyle çok daha iyi olmuş. Elinize sağlık. Ancak yeni bir sorun çıktı;
Listede 40 kadar nöbet tutmayan yani ikinci satırı boş olan var. Gerçek listemde bu boş olanlarda kritere giriyor ve ilk sütun olarak karşıma çıkıyor.
boş hücreleri eşsiz kriterden çıkartmam gerekiyor.

 

[alicimri]

If InStr(nob, s1.Cells(i, 2)) = 0  Then

yukarıdaki satırı aşağıdaki kod ile değiştirin.

If InStr(nob, s1.Cells(i, 2)) = 0 And s1.Cells(i, 2) <> "" Then

 

[gelibolu]

Sayın Ali cimri çok uğraştırdım. Hakkınızı helal ediniz. Harika oldu elinize emeğinize sağlık.)) iyi geceler dilerim.
Sonucu buraya da yazayım belki merak eden olur.

Sub Makro1()
Application.ScreenUpdating = False
NSayısı = InputBox("Sütun Sayısı Girin", "NÖBET SAYISI", Default)
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Cells.Delete
say = s1.Cells(Rows.Count, 1).End(3).Row
bol = NSayısı
e = 1
sat = 1
For i = 2 To say
' değişen yer
If InStr(nob, s1.Cells(i, 2)) = 0 And s1.Cells(i, 2) <> "" Then
s1.Range("A1:B" & say).AutoFilter Field:=2, Criteria1:=s1.Cells(i, 2)
s1.Range("A2:A" & say).Copy s2.Cells(sat + 1, e)
s2.Cells(sat, e).Value = s1.Cells(i, 2)
s2.Cells(sat, e).CurrentRegion.Borders.LineStyle = xlContinuous
s2.Rows(sat).Font.Bold = True
s2.Rows(sat).HorizontalAlignment = xlCenter
s1.Range("A1").AutoFilter
nob = nob & s1.Cells(i, 2)
e = e + 1
If e = bol + 1 Then
sat = sat + s2.Cells(sat, e).CurrentRegion.Rows.Count + 1
e = 1
End If
End If
Next
s2.Range(s2.Cells(1, 1), s2.Cells(1, bol * 1)).EntireColumn.AutoFit
s2.Activate
Application.ScreenUpdating = True
End Sub

 

[gelibolu]

Kusura bakmayın ama verilerin yerini değiştirmek zorunda kaldım. a ve b yerine c ve e sütunlarına taşıdım. Ancak kodda ne yaptımsa olmadı.
Kodun doğru çalışması için değiştirmem gereken yerler nedir?