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

[askm]

Dolu örneğinizi ekleyebilir misiniz.BRANŞ sayfasındaki C12 ye ne değer yazıyorsunuz. Attığınız örnekte s1.Cells(Rows.Count, "C").End(3).Row > 11 olmadığı için direkt işlem sonlanıyor.

 

[vurkan]

Buyurun:

http://s7.dosya.tc/server8/3li48i/2019_KAZANIM_DIN1.xls.html

(BRANŞ sayfası F10 dikkat )

Bu sayfaya bilgileri adını yazdığımız DİN dosyasından alıyor. Bu dosya e okuldan aktarılan notlar fomatında.

http://s7.dosya.tc/server8/3li48i/2019_KAZANIM_DIN1.xls.html

 

[askm]

Siz verdiğim kodları eklememişsiniz ki.

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"
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

 

[askm]

http://s7.dosya.tc/server8/cbgif5/2019_KAZANIM_DIN1.xls.html
Modüle3 de kodlarınız.

 

[vurkan]

Sayın Askm. Eklediğiniz dosyayı indirip denedim. Tam istediğim gibi olmuş. Sizlere çok zahmet verdim. Bu çalışmada Yardımlarını, bilgilerini ve emeklerini esirgemeyen Sayın Plint ve Sayın Askm ye sonsuz teşekkürler ediyorum.

 

[vurkan]

Arkadaşlar Merhaba. Bu başlık altında sorduğum sorular cevaplanmış dosya tamamlanmıştı. Ancak dosya üzerinde (onlara ihtiyacım kalmayacak çözümler bulup) bazı sayfaları silince kaydet ve temizle kodları;

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"
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

satırında hata verdi. Sildiğim sayfaların adları; LİSTE, SINIF ve OKUL. Kodların düzgün çalışması için ne yapmalıyım. Teşekkürler.

http://s3.dosya.tc/server17/z43ky5/2019_KAZANIM_DIN_V2.xls.html

 

[turist]

Araya ekleyip deneyin.

ad = f.GetBaseName(ThisWorkbook.Name) & " " & deg
kayıt = yol & "Yedek Dosyalar\" & ad & ".xls"

On Error Resume Next

a = 1
Workbooks.Add 1
For s = 1 To ThisWorkbook.Sheets.Count
S

 

[vurkan]

Sayın Turist üstadım.
Önerdiğiniz çözüm hatayı giderdi. Ancak kodlar daha önce yedeklenen dosyada Bu Dosya Başka Bir Çalışma Kitabına Aktif bağlantılar içeriyor uyarısını pasif hale getirmiştik. Şimdi bu durum yine aktif oldu. Bir de yedeklenen sayfaların başına Sayfa 1 isimli boş bir sayfa ekliyor. Bunu nasıl kaldırırız. Teşekkürler.

 

[turist]

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"
a = 0
Workbooks.Add 1
For s = 1 To ThisWorkbook.Sheets.Count
SayfaAdi = ThisWorkbook.Sheets(s).Name

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

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

Bu şekilde bir deneme yapın.

 

[vurkan]

Üstadım eline sağlık. Gecenin bu vaktinde yine yardımlarınızı esirgemediniz. Çok teşekkür ediyorum. Kodlar çalıştı. Sağolun.

 

[turist]

Siz de sağolun.Hayırlı geceler.