• FORUMU MOBİL UYGULAMADAN TAKİP EDİN

    Forumu isteyen üyelerimiz Tapatalk (Harici bir hizmet) üzerinden mobil uygulamadan takip edebilirler.
    iOS için : https://itunes.apple.com/app/id307880732?mt=8
    Android için : https://play.google.com/store/apps/details?id=com.quoord.tapatalkpro.activity
    adreslerinden indirebilirsiniz.

    Bir iki haftaya da foruma özel kendi uygulamamız yayında olacak.
ALTIN ÜYELİK Hakkında Bilgi
-----------------------

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

askm

Altın Üye
Altın Üye
Katılım
4 Haziran 2005
Mesajlar
2,332
Beğeniler
27
Excel Vers. ve Dili
2010-2016
#21
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.
 

askm

Altın Üye
Altın Üye
Katılım
4 Haziran 2005
Mesajlar
2,332
Beğeniler
27
Excel Vers. ve Dili
2010-2016
#23
Siz verdiğim kodları eklememişsiniz ki.
Kod:
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
 
Katılım
29 Haziran 2018
Mesajlar
155
Beğeniler
20
Excel Vers. ve Dili
2003 - 2016
#25
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.
 
Katılım
29 Haziran 2018
Mesajlar
155
Beğeniler
20
Excel Vers. ve Dili
2003 - 2016
#26
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

Destek Ekibi
Destek Ekibi
Katılım
18 Kasım 2009
Mesajlar
4,524
Beğeniler
287
Excel Vers. ve Dili
2013 64Bit
English
#27
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
 
Katılım
29 Haziran 2018
Mesajlar
155
Beğeniler
20
Excel Vers. ve Dili
2003 - 2016
#28
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

Destek Ekibi
Destek Ekibi
Katılım
18 Kasım 2009
Mesajlar
4,524
Beğeniler
287
Excel Vers. ve Dili
2013 64Bit
English
#29
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.
 
Katılım
29 Haziran 2018
Mesajlar
155
Beğeniler
20
Excel Vers. ve Dili
2003 - 2016
#30
Ü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

Destek Ekibi
Destek Ekibi
Katılım
18 Kasım 2009
Mesajlar
4,524
Beğeniler
287
Excel Vers. ve Dili
2013 64Bit
English
#31
Siz de sağolun.Hayırlı geceler.
 
Üst