• DİKKAT

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

Aynı sayfadaki tablolar arası veri aktarma ve boş satırlar gösterilmesin

  • Konbuyu başlatan Konbuyu başlatan klop01
  • Başlangıç tarihi Başlangıç tarihi
klop01

klop01

Altın Üye
Katılım
19 Aralık 2016
Mesajlar
663
Excel Vers. ve Dili
2021 Türkçe 64 Bit
Arkadaşlar,
Bir sınav analizi ile ilgili yardıma ihtiyacım var.

1. Bir sayfadaki tabloda verilerim var.
2. Bu verileri, bu tablonun altında yer alan başka bir tabloya aktaracağım.
3. Üstteki tabloda belli aralıklarda veri yoksa aşağıdaki tabloda bu satırların diğer verileri silinsin, oluşan boşluklar kaldırılsın ve tablo öğrenci no. sıralı olsun.

Ekteki dosyada konuyu renklendirerek tam olarak anlattım.

Yardımcı olacak arkadaşlara peşinen teşekkürlerimi sunuyorum.

DOSYA TC: http://s3.dosya.tc/server10/35bvi1/EROL_2016_MAKRO.rar.html

Tüm istenilenlerin gerçekleştiği(asri sayesinde) dosyanın linki: https://upterabit.com/1Kvy/Tablo_Kopyala_DEĞİŞİK_HALİ.xlsm
 

Ekli dosyalar

Son düzenleme:
Sıra ve BAŞARI YÜZDESİ yazıları ve bulundukları sütun önemlidir.

Kontrol ediniz.

https://upterabit.com/1KqG/Tablo_Kopyala.xlsm

Kod: 
Dim ikincitablobasi, birincitablosonu As Long

Sub menu()
   Application.ScreenUpdating = False
   Call tablo_kopyala
   Call boslari_temizle
   Call sirala
   Call sirano
   Application.ScreenUpdating = True
   MsgBox ("Tablo Hazırlandı.")
End Sub

Sub sirano()
    Sheets("1. DÖN. 1. SINAV VERİ GİRİŞİ").Select
    sonsatir = Cells(Rows.Count, "B").End(3).Row - 1
    For i = ikincitablobasi + 3 To sonsatir - 1
       Cells(i, 2).Value = i - 102
    Next i
End Sub

Sub boslari_temizle()
    Sheets("1. DÖN. 1. SINAV VERİ GİRİŞİ").Select
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    For i = sonsatir To ikincitablobasi + 3 Step -1
        say = WorksheetFunction.CountA(Range("E" & i & ":AI" & i))
        If say = 0 Then
           Rows(i).Delete
        End If
    Next i
End Sub

Sub tablo_kopyala()
    Sheets("1. DÖN. 1. SINAV VERİ GİRİŞİ").Select
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    For i = 5 To sonsatir
      If Cells(i, 2) = "BAŞARI YÜZDESİ" Then birincitablosonu = i
      If Cells(i, 2) = "Sıra" Then
         ikincitablobasi = i - 2
         Exit For
      End If
    Next i

    Rows(ikincitablobasi & ":" & sonsatir).Select
    Selection.Clear
    Rows("2:4").Select
    Selection.Copy
    Rows(ikincitablobasi & ":" & ikincitablobasi).Select
    ActiveSheet.Paste
    Rows("5:" & birincitablosonu - 1).Select
    Selection.Copy
    Rows(ikincitablobasi + 3 & ":" & ikincitablobasi + 3).Select
    Selection.Insert Shift:=xlDown
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   
End Sub

Sub sirala()
    Sheets("1. DÖN. 1. SINAV VERİ GİRİŞİ").Select
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    Range("B" & ikincitablobasi + 3 & ":AO" & sonsatir).Select
    ActiveWorkbook.Worksheets("1. DÖN. 1. SINAV VERİ GİRİŞİ").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("1. DÖN. 1. SINAV VERİ GİRİŞİ").Sort.SortFields.Add _
        Key:=Range("C" & ikincitablobasi + 3 & ":C" & sonsatir), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("1. DÖN. 1. SINAV VERİ GİRİŞİ").Sort
        .SetRange Range("B" & ikincitablobasi + 3 & ":AO" & sonsatir)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Rows(birincitablosonu & ":" & birincitablosonu).Select
    Application.CutCopyMode = False
    Selection.Copy
    Rows(sonsatir + 1 & ":" & sonsatir + 1).Select
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False
    
    Range("D103").Select
End Sub
 
asri Bey,
Emeğiniz için çok teşekkür ederim. Her şey tam istenilen gibi olmuş. En büyük analiz sorunu çözülmüş oldu.

"Sıra ve BAŞARI YÜZDESİ yazıları ve bulundukları sütun önemlidir." demişsiniz. Kastınız:
Sırada numaraların puanı olmayan öğrencinin silinmesinde eksilmesi yani 14'ten 16'ya geçilmesi,
BAŞARI YÜZDESİ'nde satırın aşağı yukarı duruma göre konum değiştirmesi ise bu iki durum önemli değil. Zira ben buradaki verileri asıl analiz sayfasına hatasız çekmiş olacağım sizin sayenizde.

İKİ KONU
1. Düğmenin üstündeki yazı ANALİZİ HAZIRLA şeklinde olabilir mi?
2. Bu düğmeye basınca "Tablo hazırlandı." yazısı ANALİZ HAZIRLANDI olabilir mi?

SORUN
Ben yazılabilecek bir kodu alıp diğer sayfalara yapıştırarak oralarda da aynı işlevi yaptırabilirim sanmıştım. Okuldan geldikten beri uğraştım işin içinden çıkamadım.
Öğrenciler 3 birinci dönem 3 ikinci dönem toplam 6 sınav oluyor.
Siz 1. dönem 1. sınav için yazdınız kodu.
Bu kodu diğer sayfalara geçerli kılmayı yapamıyorum.
Diğer sayfalar(devamındaki 5 sayfa) sizin çalışma yaptığınız sayfa ile her bakımdan(hücre konumları vb.) her şey aynı. Ben tabloları oluşturdum. Tek fark sayfa adları. Onlar da sayfaların üzerinde yazıyor.

DOSYAYI BİR ALTTAKİ MESAJDA EKLEDİM.


RİCA ETSEM BU KONUDA YARDIMCI OLABİLİR MİSİNİZ?
 
Son düzenleme:
klop01;878204.. Sırada numaraların puanı olmayan öğrencinin silinmesinde eksilmesi yani 14'ten 16'ya geçilmesi' Alıntı:
Sıra ve BAŞARI YÜZDESİ kelimelerini tabloların başlama ve bitiş yerilerini tespit etmek için kullanıyorum. Bu yüzden bu kelimelerde ve bulundukları sütunlarda değişiklik yapılmamalı.

DOsyanızı http://upterabit.com adresinden yükleyiniz.

Kodlardaki
Kod: 
Sheets("1. DÖN. 1. SINAV VERİ GİRİŞİ").Select
bu bölümü silip dener misiniz.
Genişletmek için tıkla ...
 
Son düzenleme:
Dosya yüklendiği sitede görünmüyor. Kayıt diyor, kaydoldum dosya yine görünmedi. Buradan yükleyebilir misiniz?
 
klop01' Alıntı:
Dosyayı unutmuşum, ekledim.
Genişletmek için tıkla ...

Sayın Klop01

Dosyanızı Altın üye olmayan kişiler indiremezler. O yüzdendir ki upload sitesine yüklemeniz daha yerinde olacaktır. Yardım olacak arkadaşlar dosyanızı indiremezler.Yada bu dosyadan faydalanacak kişiler mahrum kalmış olurlar.

https://upterabit.com ( bu site reklamsız ve sade upload sitesi buraya yükleyebilirsiniz.
 
klop01' Alıntı:
Dosya yüklendiği sitede görünmüyor. Kayıt diyor, kaydoldum dosya yine görünmedi. Buradan yükleyebilir misiniz?
Genişletmek için tıkla ...

O sitede kayıt olmanıza gerek yok, sayfa açıldığında 3-4 sn bekleyin upload butonu gelecektir.
 
klop01' Alıntı:
Dosya yüklendiği sitede görünmüyor. Kayıt diyor, kaydoldum dosya yine görünmedi. Buradan yükleyebilir misiniz?
Genişletmek için tıkla ...

Üyelik gerektirmeyen bir sitedir. Dosya yüklendiği zaman size kopyalanacak linkler çıkar. Linki kopyala diyerek buraya yapıştırabilirsiniz
 
Arkadaşlar,
Özür diliyorum. Kafam karma karışık oldu. Ben de gönderilen linkte dosya var diye indirmeye çalışıyorum.
Dosyayı siteye ekledim.
LİNK: https://upterabit.com/1Kss/Tablo_Kopyala_2222.xlsm
 
Şimdi inecek bir dosya olmuş. Köprüsüz olmuş.Lakin yinede başarmışsınız :)
 
asri Bey,

Dün dediğiniz Sheets ("1. DÖN. 1. SINAV VERİ GİRİŞİ").Select bölümünü sildim.
Kod diğer sayfalarda da sorunsuz çalıştı.

Ama kodun sıralama bölümündeki bir yer sıralama işlemini 1. DÖN. 1. SINAV VERİ GİRİŞİ sayfası dışındaki sayfalarda yaptırmıyor. İlgili yerde kodun çalıştığı sayfa adı yazılmış. Sanırsam buralarda düzenleme yapılmalı.

KOD yazımı konusunda bilgim yok. Son olarak buraya bir bakabilir misiniz?

Dosyanın düzenlenmiş hâli: https://upterabit.com/Utx/Tablo_Kopyala_DEĞİŞİK_HALİ.xlsm


Bahsettiğim yer:

Sub sirala()
sonsatir = Cells(Rows.Count, "B").End(3).Row
Range("B" & ikincitablobasi + 3 & ":AO" & sonsatir).Select
ActiveWorkbook.Worksheets("1. DÖN. 1. SINAV VERİ GİRİŞİ").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("1. DÖN. 1. SINAV VERİ GİRİŞİ").Sort.SortFields.Add _
Key:=Range("C" & ikincitablobasi + 3 & ":C" & sonsatir), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("1. DÖN. 1. SINAV VERİ GİRİŞİ").Sort
.SetRange Range("B" & ikincitablobasi + 3 & ":AO" & sonsatir)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Rows(birincitablosonu & ":" & birincitablosonu).Select
Application.CutCopyMode = False
Selection.Copy
Rows(sonsatir + 1 & ":" & sonsatir + 1).Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False

Range("D103").Select
End Sub
 
klop01' Alıntı:
..
Ama kodun sıralama bölümündeki bir yer sıralama işlemini 1. DÖN. 1. SINAV VERİ GİRİŞİ sayfası dışındaki sayfalarda yaptırmıyor. İlgili yerde kodun çalıştığı sayfa adı yazılmış. Sanırsam buralarda düzenleme yapılmalı.

KOD yazımı konusunda bilgim yok. Son olarak buraya bir bakabilir misiniz?
Genişletmek için tıkla ...

Sırala kodunu aşağıdaki şekilde değiştiriniz.

Kod: 
Sub sirala()
    sonsatir = Cells(Rows.Count, "B").End(3).Row
    Range("B" & ikincitablobasi + 3 & ":AO" & sonsatir).Select
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add _
        Key:=Range("C" & ikincitablobasi + 3 & ":C" & sonsatir), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("B" & ikincitablobasi + 3 & ":AO" & sonsatir)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Rows(birincitablosonu & ":" & birincitablosonu).Select
    Application.CutCopyMode = False
    Selection.Copy
    Rows(sonsatir + 1 & ":" & sonsatir + 1).Select
    Selection.Insert Shift:=xlDown
    Application.CutCopyMode = False
    
    Range("D103").Select
End Sub
 
Tekrar çok teşekkürler. Eksiksiz olarak her şey gerçekleşti.
Gelişmiş bir SINAV ANALİZİ planlıyorum. Hazırladığımda forumda paylaşacağım. Sizi haberdar ederim, emeğiniz var çünkü bu kodla birçok sorun çözülmüş oldu.

Tüm değişikliklerin uygulandığı dosyayı ihtiyacı olanlar için paylaşıyorum:
https://upterabit.com/1Kvy/Tablo_Kopyala_DEĞİŞİK_HALİ.xlsm
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst