Hastane Nöbet Listesi Puantajı Veri Aktarımı

[BİTANEM]

Merhabalar,
Benim yapmak istediğim şey, 1.2.3.4.5 den başlayarak 60'a kadar devam eden sayfalarım var. Bunların herbirinin A7:F31 aralığında bulunan dolu satırlardaki verileri filtre sayfasına aktarma istiyorum.

Burada sadece fazla yer kaplamasın diye sadece sayfalardan iki tanesini belirttim. Burada olması gereken 60 tane sayfam var.

Şimdiden herkese teşekkür ederim.

 

[Orion1]

Dosyanız ektedir.

Sub liste59()
Dim sh As Worksheet, sat As Long, sat2 As Long, i As Long
Sheets("Filtre").Select
Range("A2:D" & Rows.Count).ClearContents
Application.ScreenUpdating = False
sat2 = 2
For Each sh In Worksheets
    If sh.Name <> "Filtre" Then
        sat = sh.Cells(32, "A").End(xlUp).Row
        For i = 7 To sat
            Cells(sat2, "A").Value = sh.Cells(i, "F").Value
            Cells(sat2, "B").Value = sh.Cells(i, "B").Value
            Cells(sat2, "C").Value = sh.Cells(i, "C").Value
            Cells(sat2, "D").Value = sh.Cells(i, "A").Value
            sat2 = sat2 + 1
        Next i
    End If
Next sh
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır." & vbLf & "evrengizlen@hotmail.com", _
    vbOKOnly + vbInformation, Application.UserName
End Sub

 

[BİTANEM]

Merhabalar
Hocam kod çalışıyor, fakat sayfada formüllü veri olduğu için filtre sayfasına formül sonucu sıfır olan değerleride atıyor. Mümkünse tekrar incelermisniz. Benim istediğim boş satırların gelmemesi. Dosya ekte sunulmuştur. Ayrıca bir makrom daha var, allta sunulmuştur. Bu listeleme makrosu ile o7:q31 arasındaki isimleri seçip B7:B31 arasına aktarıyorum. Fakat isimleri karışık atıyor, mümkünse içerisine alfabetik sıralama makrosunu da eklermisiniz.
Teşekkürler.

Sub S2()
Dim alan
Dim isim
Dim i

Worksheets("2").Range("B7:B31").ClearContents

Set alan = Worksheets("2").Range("O7:S37")

For Each isim In alan
If WorksheetFunction.CountIf(Worksheets("2").Range("B7:B31"), isim) < 1 Then
i = WorksheetFunction.CountA(Worksheets("2").Range("B7:B31")) + 7
Worksheets("2").Range("B" & i) = isim
End If
Next

MsgBox "Bitti", vbInformation, "Yapımcı.Erol AZAKLI"

End Sub

 

[Orion1]

dosyanız ektedir.
2nci soruyu anlamadım.

 

[BİTANEM]

Hocam teşekkürler aktarma sorununu çözdüm.


İkinci sorumun açıklaması :

Sub a() adlı Sıralama makrosunu, 2-Sub S2() makrosunun içerisine ekleyebilirmisiniz. Burada amacım belirten aralıkta bulunan verileri adı soyadı sütununa alfabetik sırada gelmesi. (a,b,c,d ... v.y.z gibi) Normalde isimler karışık olarak gelmektedir. Listeleme makrosunu çalıştırırsanız demek istediğimi görmüş olursunuz.



1-Sıralama Makrosu
Sub a()

Range("B7:B31").Select
Selection.Sort Key1:=Range("b7")
End Sub

2-Sub S2() Listeleme Makrosu
Dim alan
Dim isim
Dim i

Worksheets("2").Range("B7:B31").ClearContents

Set alan = Worksheets("2").Range("O7:S37")

For Each isim In alan
If WorksheetFunction.CountIf(Worksheets("2").Range("B7:B31"), isim) < 1 Then
i = WorksheetFunction.CountA(Worksheets("2").Range("B7:B31")) + 7
Worksheets("2").Range("B" & i) = isim
End If
Next

MsgBox "Bitti", vbInformation, "Yapımcı.Erol AZAKLI"

End Sub

 

[Orion1]

End If
Next
[B][COLOR="Red"]call a[/COLOR][/B]
MsgBox "Bitti", vbInformation, "Yapımcı.Erol AZAKLI"

Yukarıdaki gibi kırmızı satırı ekleyin.

 

[BİTANEM]

Hocam kodu dediğiniz gibi yaptım çalışmadı. Mümkünse kodu tekrar gözden geçirirmisiniz. Yaptığım düzeltme alta sunulmuştur.
Teşekkürler

Sub S2()
Dim alan
Dim isim
Dim i

Worksheets("2").Range("B7:B31").ClearContents

Set alan = Worksheets("2").Range("O7:S37")

For Each isim In alan
If WorksheetFunction.CountIf(Worksheets("2").Range("B 7:B31"), isim) < 1 Then
i = WorksheetFunction.CountA(Worksheets("2").Range("B7 :B31")) + 7
Worksheets("2").Range("B" & i) = isim
End If
Next
call a
MsgBox "Bitti", vbInformation, "Yapımcı.Erol AZAKLI"
End Sub

 

[Orion1]

S2 makronuza bakın .Onda önce 2 numaralı sayfada B7:B37 nolu alanı siliyorsunuz.
Sonrada oraya bakarak q ve s kolonlarında(2 nolu sayfada) bulunan isim adlı değişkeni sorguluyorsunuz B7:B37 aralığnda.Silinmiş oldıuğu için doğal olarak bir şey bulamıyor.S2 adlı makronuzda mantık hatası var gibi geliyor bana.
Syntax hatası olsa onu bulursunuzda böyle mantık hatalarına düşmemek lazım.Çok zor bulunuyorlar.
Kolay gelsin.

 

[BİTANEM]

Hocam çok teşekkür ederim. Ellerinize sağlık.