Soru Aynı Klasördeki başka bir dosyadan bir alanı seçip yapıştırma

[vurkan]

Arkadaşlar Merhaba Öğretmenlerin ihtiyaç duyduğu Kazanım Değerlendirme Ölçeği Programı yapmaya çalışıyorum. İşi oldukça kolay hale getirdim. e-okul programından ders notlarını excele aktarıyoruz. Aktardığımız bu dosyaya sınıfın adını veriyoruz. Örneğin 2A Sonra bu dosyayı açıp içindekileri seçip benim hazırladığım program dosyasının SINIF sayfasına C12 den itibaren yapıştırıyoruz. Gerekli yerleri doldurduktan sonra çıktı alıyoruz.

Ancak yardım istediğim konu;

Ekte sunduğum 2018 KAZANIM 2. SINIF dosyasının SINIF sayfasında F10 hücresine 2A yazınca Aynı klasör içindeki 2A adlı dosyayı açıp (veya açmadan) A3:Z aralığını B sütunundaki son satıra kadar kopyalayıp C12 den itibaren yapıştıracak bir kod istiyorum. F10 hücresi boşaltıldığında veya değiştirildiğinde F10 daki sınıf ismini dosya adının ardına ilave ederek (mesela 2018 KAZANIM 2A şeklinde) aynı klasöre farklı kaydedip C12 den itibaren eski bilgileri temizlemesini istiyorum. Böylece f10 hücresine yazılan sınıf adlarına göre işlem yapmalı.

http://www.dosya.tc/server14/rz1e56/2018_KAZANIM_OLCEKLERI.rar.html

 

[vurkan]

Arkadaşlar sorum mu anlaşılamadı acaba. İstediğim şey aktif çalışma kitabımın F10 hücresine yazdığım isimle aynı olan dosyanın açılarak açılan dosyanın A3:Z aralığını B sütunundaki son satıra kadar kopyalayıp aktif kitaptaki C12 hücresinden itibaren yapıştıracak bir kod.

 

[PLİNT]

Merhaba
Ek dosyayı deneyin.
"F10" hücresine sınıf adı yazdığınızda verileri alacak, silmek veya yeni sınıf adı girmek için tekrar "F10" hücresi seçildiğinde sayfadaki bilgiler farklı dosya olarak kaydedilecektir.
http://s3.dosya.tc/server16/4k0bsk/Klasor.zip.html

 

[vurkan]

Sayın plint cevabınızı cep telefonundan gördüm. Bir iki gün içinde deneme fırsatı bulurum inşallah. Teşekkür ederim.

 

[vurkan]

Sayın Plint Hazırladığınız çalışmayı henüz inceleyebildim. Tam düşündüğüm gibi olmuş. Ancak bir şey farkettim. Şöyle ki; sınıf adını 2a gibi yazdım. kodlar normal çalıştı ancak a harfini büyüteyim diye F10 tıklayınca normal olarak sınıfı farklı kaydetti. Şimdi:
Acaba kodları ikiye bölüp iki butona bağlasak birisiyle birinci bölümü çalıştırsak, ikincisiyle tabloyu temizlerken farklı kaydetsek nasıl olur acaba? Çok teşekkür ederim.

 

[vurkan]

Tekrar merhaba. 1., 2. ve 3. sınıfların gerçek dosyalarında sorunsuz çalışan kodlar 4. sınıfların dosyasına uyarladığımda bütün dolu sütunların en son satırın bir alt satırına #YOK yazıyor. Dolayısıyla diğer sayfalardaki dizi formüllerim çalışmıyor. 4. Sınıflarda rakamsal notlar var. Almak istediğim öğretmen ismi E sütununda. Kodlarda B sütunu son satırı E ile değiştirdim. Ama yine de düzelmedi. Bu sorunu nasıl aşabiliriz acaba?

http://s7.dosya.tc/server8/1siqam/4.siniflar.rar.html

İlgilenecek olanlara şimdiden çok çok teşekkür ediyorum.

 

[vurkan]

Merhaba arkadaşlar ilgilenenler için 6 nolu mesajımdaki 4. sınıflarla ilgili sorunu;

Range("C12:AB" & x + 9).Value = a.Worksheets(1).Range("A4:AB" & x).Value satırındaki +9 rakamını +8 ile değiştirerek çözdüm

Range("C12:AB" & x + 8).Value = a.Worksheets(1).Range("A4:AB" & x).Value.


5 nolu mesajımdaki buton isteği devam ediyor saygılarımla.

 

[PLİNT]

Şöyle ki; sınıf adını 2a gibi yazdım. kodlar normal çalıştı ancak a harfini büyüteyim diye F10 tıklayınca normal olarak sınıfı farklı kaydetti

Merhaba
3. mesajdaki dosyada; "F10" hücresindeki küçük harf yazma sorunu kodlara yapılacak ekleme ile çözülebilir.

5 nolu mesajımdaki buton isteği devam ediyor

Butonlu örnek dosya ektedir.

http://s7.dosya.tc/server8/zsbmto/4.siniflar_2.zip.html

 

[vurkan]

Sayın Plint teşekkür ederim. Yeni dosyaları hemen inceleyeceğim. Ancak; yeni bir sorunum daha gelişti. Şöyle ki ; İngilizce ve Din dersi gibi branş derslerinde F10 hücresine 2A gibi sınıf yerine DİN gibi branşın ismini yazdım. Birinci bölüm kodları çalıştı ancak tekrar F10 hücresine tıklayınca yedekleme yapmadı

 

[vurkan]

Arkadaşlar merhaba. 9 nolu mesajımdaki olumsuzluğu Sayın Plint'in 8 nolu mesajındaki yöntemle aştım. Böylece sorunum % 90 tamamlandı.

Eğer mümkünse aşağıdaki kodlara nasıl bir ilave yapalım ki aktif kitabın "LİSTE, SINIF, OKUL" isimli sayfalarının dışında kalan sayfaları yedeklesin.
Ve eğer mümkün ise sayfa şekilleri aynı kalmakla birlikte formülleri değilde değerleri kopyalasın.
Çünkü Yedek dosya açılırken bağlantıları güncellemekten bahsediyor. Güncelleştirme diyerek açtığımda formüller çalışmadığından (herhalde) tüm yazılar #DEĞER! şeklinde oluyor. Bu dosyayı elektronik ortamda okul idaresine verince problem yaşanabilir. Saygılar.


Sub kaydet_temizle()
Dim s1 As Worksheet, s As Long, kayıt As String, yol As String
Dim deg As String, ad As String
Dim f As Object
Set s1 = Sheets("BRANŞ")
s1.Range("F10").Value = UCase(Replace(Replace(s1.Range("F10").Value, "ı", "I"), "i", "İ"))
deg = s1.Range("F10").Value
If deg <> "" And s1.Cells(Rows.Count, "C").End(3).Row > 11 Then
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'On Error GoTo fr
Set f = CreateObject("scripting.filesystemobject")
yol = ThisWorkbook.Path & "\"
If f.FolderExists(yol & "Yedek Dosyalar") = False Then f.CreateFolder yol & "Yedek Dosyalar"
ad = f.GetBaseName(ThisWorkbook.Name) & " " & deg
kayıt = yol & "Yedek Dosyalar\" & ad & ".xls"

Workbooks.Add 1
For s = 1 To ThisWorkbook.Sheets.Count
If ThisWorkbook.Sheets.Count <> ActiveWorkbook.Sheets.Count Then ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ThisWorkbook.Sheets(s).Cells.Copy
ActiveWorkbook.Sheets(s).PasteSpecial
Application.CutCopyMode = False
ActiveWorkbook.Sheets(s).Name = ThisWorkbook.Sheets(s).Name
Next
Application.DisplayAlerts = False
ChDir yol & "Yedek Dosyalar\"
ActiveWorkbook.Sheets(1).Activate
ActiveWorkbook.SaveAs Filename:=kayıt, FileFormat:=56
ActiveWorkbook.Close savechanges:=False
MsgBox ad & " dosyası " & vbCrLf & yol & "Yedek Dosyalar Klasörüne kaydedildi"
Application.DisplayAlerts = True
End If
fr:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error Resume Next
s1.Range("C12:AE1000").SpecialCells(xlCellTypeConstants, 23).ClearContents
s1.Range("F10") = ""
End Sub

 

[askm]

Yanlış anlamamışsam aşağıdaki şekilde olması gerek.

Sub kaydet_temizle()
Dim s1 As Worksheet, s As Long, kayıt As String, yol As String
Dim deg As String, ad As String
Dim f As Object
Set s1 = Sheets("SINIF")
's1.Range("F10").Value = UCase(Replace(Replace(s1.Range("F10").Value, "ı", "I"), "i", "İ"))
deg = s1.Range("F10").Value
If deg <> "" And s1.Cells(Rows.Count, "C").End(3).Row > 11 Then
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'On Error GoTo fr
Set f = CreateObject("scripting.filesystemobject")
yol = ThisWorkbook.Path & "\"
If f.FolderExists(yol & "Yedek Dosyalar") = False Then f.CreateFolder yol & "Yedek Dosyalar"
 ad = f.GetBaseName(ThisWorkbook.Name) & " " & deg
kayıt = yol & "Yedek Dosyalar\" & ad & ".xls"

Workbooks.Add 1
For s = 1 To ThisWorkbook.Sheets.Count
SayfaAdi = ThisWorkbook.Sheets(s).Name
If SayfaAdi <> "LİSTE" And SayfaAdi <> "SINIF" And SayfaAdi <> "OKUL" Then
If ThisWorkbook.Sheets.Count <> ActiveWorkbook.Sheets.Count Then ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ThisWorkbook.Sheets(s).Cells.Copy
ActiveWorkbook.Sheets(s).PasteSpecial
Application.CutCopyMode = False
ActiveWorkbook.Sheets(s).Name = ThisWorkbook.Sheets(s).Name
End If
Next
Application.DisplayAlerts = False
    ChDir yol & "Yedek Dosyalar\"
    ActiveWorkbook.Sheets(1).Activate
    ActiveWorkbook.SaveAs Filename:=kayıt, FileFormat:=56
    ActiveWorkbook.Close savechanges:=False
MsgBox ad & " dosyası " & vbCrLf & yol & "Yedek Dosyalar Klasörüne kaydedildi"
    Application.DisplayAlerts = True

End If
fr:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error Resume Next
    s1.Range("C12:AE1000").SpecialCells(xlCellTypeConstants, 23).ClearContents
    s1.Range("F10") = ""
End Sub

 

[vurkan]

Sayın Askm ilgin için teşekkür ederim. Kodları çalıştırınca

ActiveWorkbook.Sheets(s).PasteSpecial

satırında hata mesajı verdi.

 

[askm]

Sizin 10. mesajda eklediğiniz kodda belirtilen sayfa mevcut değil. F10 hücresi dolu olarak örnek dosyanızı eklerseniz dosyanızı çalışır vaziyette tekrar atmaya çalışırım.

 

[vurkan]

Merhaba dosyaları ekledim. 2019 KAZANIM DİN1 dosyasının BRANŞ sayfasının F10 hücresine DİN yazarak DİN dosyasındaki bilgileri alıyoruz.


http://www.dosya.tc/server14/0ziahw/TAMAMLANAN.rar.html

 

[askm]

Dosyanız ektedir.

Sub kaydet_temizle()
Dim s1 As Worksheet, s As Long, kayıt As String, yol As String
Dim deg As String, ad As String
Dim f As Object
Set s1 = Sheets("SINIF")
's1.Range("F10").Value = UCase(Replace(Replace(s1.Range("F10").Value, "ı", "I"), "i", "İ"))
deg = s1.Range("F10").Value
If deg <> "" And s1.Cells(Rows.Count, "C").End(3).Row > 11 Then
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'On Error GoTo fr
Set f = CreateObject("scripting.filesystemobject")
yol = ThisWorkbook.Path & "\"
If f.FolderExists(yol & "Yedek Dosyalar") = False Then f.CreateFolder yol & "Yedek Dosyalar"
 ad = f.GetBaseName(ThisWorkbook.Name) & " " & deg
kayıt = yol & "Yedek Dosyalar\" & ad & ".xls"
a = 1
Workbooks.Add 1
For s = 1 To ThisWorkbook.Sheets.Count
SayfaAdi = ThisWorkbook.Sheets(s).Name
If SayfaAdi <> "LİSTE" And SayfaAdi <> "SINIF" And SayfaAdi <> "OKUL" Then
a = a + 1
If ThisWorkbook.Sheets.Count <> ActiveWorkbook.Sheets.Count Then ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ThisWorkbook.Sheets(s).Cells.Copy
ActiveWorkbook.Sheets(a).PasteSpecial
Application.CutCopyMode = False
ActiveWorkbook.Sheets(a).Name = ThisWorkbook.Sheets(s).Name
End If
Next
Application.DisplayAlerts = False
    ChDir yol & "Yedek Dosyalar\"
    ActiveWorkbook.Sheets(1).Activate
    ActiveWorkbook.SaveAs Filename:=kayıt, FileFormat:=56
    ActiveWorkbook.Close savechanges:=False
MsgBox ad & " dosyası " & vbCrLf & yol & "Yedek Dosyalar Klasörüne kaydedildi"
    Application.DisplayAlerts = True

End If
fr:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error Resume Next
    s1.Range("C12:AE1000").SpecialCells(xlCellTypeConstants, 23).ClearContents
    s1.Range("F10") = ""
End Sub

 

[vurkan]

Sayın Askm altın üye olmadığım için ekli dosyayı alamadım. Ancak kodları kopyalayıp denediğimde;

ActiveWorkbook.SaveAs Filename:=kayıt, FileFormat:=56

Satırında hata verdi.

 

[askm]

Sorununuz deg değişkeninde. Yani Sınıf sayfası F10 hücresinden aldığı değerde. Burada '/' işareti kullandığınız için belge isminde bu işareti kabul etmez. Oradaki değeri 1. Sınıf / B Şubesi yerine 1. Sınıf - B Şubesi olarak yazın sonuç alırsınız.

 

[vurkan]

Sayın Aksm eklediğim desyada SINIF sayfasında F10 hücresin in benim için bir önemi yok. Asıl önemli olan BRANŞ sayfasındaki F10 hücresi. Diğer dosyalarda kurgu SINIF sayfasındayken bu dosyada sınıf sayfası başka amaç için kullanılıyor. Yani diğer dosyalardaki SINIF adlı sayfanın yerine BRANŞ adlı sayfayı koydum. İşlem ona göre olmalı.
Koddaki SINIF yazısını BRANŞ olarak değiştirince;

ActiveWorkbook.Sheets(s).PasteSpecial
satırında hata verdi saygılar.

 

[askm]

Ben kodlarınızı sıfırdan yazmadım. Sadece belirttiğiniz soruya göre kodlara ilave yaptım.
Set s1 = Sheets("SINIF")
kısmını BRANŞ olarak değiştirip deneyin. Buradaki F10 değeri dolu olarak örnek dosyayı o yüzden istemiştim.

 

[vurkan]

Set s1 = Sheets("BRANŞ")

yaptım ve
ActiveWorkbook.Sheets(s).PasteSpecial
satırında hata verdi saygılar.