Kapalı dosyadan açıklamaları alma....

Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
Selamün Aleyküm; Arkadaşlar siteden araştırdım bir kaç kod buldum ama kendime uyarlayamadım. Bana yardım ederseniz minnettar kalırım. Sorum şu
Kapalı Dosyamın LİSTE sayfasının S kolonundaki "EK ÜCRET" kısmındaki verilerde bulunan açıklamaları AÇIK dosyamın ekte belirttiğim en son dolu satırlara yeşil renkte almak istiyorum. Teşekkürler.
 

Ekli dosyalar

dEdE

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
Dener misiniz?
Kod:
Sub Veri_Al()
ZMN = Timer
Application.ScreenUpdating = False
Yol = ThisWorkbook.Path & "\" 'Dosya yolunu kendinize göre düzenlemelisiniz.
Dosya = "PERSONEL.xlsm"
ss2 = 7
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set K1 = Workbooks.Open(Yol & Dosya)
    ss1 = ActiveSheet.Cells(Rows.Count, "S").End(3).Row
    For i = 2 To ss1
        If Not ActiveWorkbook.Sheets("LİSTE").Cells(i, "S").Comment Is Nothing Then
        With Workbooks("AÇIK DOSYAM").Sheets("PUANTAJ")
            .Cells(ss2, "AX") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "B")
            .Cells(ss2, "AY") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "S").Comment.Text
            .Cells(ss2, "AX").Font.Color = vbGreen
            .Cells(ss2, "AY").Font.Color = vbGreen
        End With
            ss2 = ss2 + 1
        End If
    Next
    K1.Close False
    Application.ScreenUpdating = True
    MsgBox "İşlem " & Format(Timer - ZMN, "0.00") & " Saniyede Tamamlandı", vbInformation
End Sub
 
Son düzenleme:
Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
Sayın hocam teşekkür ederim deneme imkanım yok aksilik olursa bildiririm. İyi günler dua ile kalın
 
Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
Merhaba hocam; yenice uygulama imkanı buldum eline sağlık hocam, tamam güzel olmuş ama şurayı düzelte bilir misin?
Açıklamaları AX ve AY kolonlarının 7 satırından sonra getiriyor, benim isteğim bu kolonların AX ve AY kolonlarında veri varsa bunların üzerine yazmadan yazsın.
Yani: aşağıdaki kod en son satır galiba
ss1 = ActiveSheet.Cells(Rows.Count, "S").End(3).Row

Bunu bu seferde açık doysa için ss2 = 7 in en son satırı için nasıl bir değişlik yapılabilir. Teşekkürler.
 

dEdE

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
Merhaba,
Açıklamanızdan bunu anladım.
Kod:
Sub Veri_Al()
ZMN = Timer
Application.ScreenUpdating = False
Yol = ThisWorkbook.Path & "\" 'Dosya yolunu kendinize göre düzenlemelisiniz.
Dosya = "PERSONEL.xlsm"
ss2 = Workbooks("AÇIK DOSYAM").Sheets("PUANTAJ").Cells(Rows.Count, "AX").End(3).Row + 1
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set K1 = Workbooks.Open(Yol & Dosya)
    ss1 = ActiveSheet.Cells(Rows.Count, "S").End(3).Row
    For i = 2 To ss1
        If Not ActiveWorkbook.Sheets("LİSTE").Cells(i, "S").Comment Is Nothing Then
        With Workbooks("AÇIK DOSYAM").Sheets("PUANTAJ")
            .Cells(ss2, "AX") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "B")
            .Cells(ss2, "AY") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "S").Comment.Text
            .Cells(ss2, "AX").Font.Color = vbGreen
            .Cells(ss2, "AY").Font.Color = vbGreen
            .Cells(ss2, "AU") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "C")
            .Cells(ss2, "AV") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "D")
            .Cells(ss2, "AW") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "E")
        End With
            ss2 = ss2 + 1
        End If
    Next
    K1.Close False
    Application.ScreenUpdating = True
    MsgBox "İşlem " & Format(Timer - ZMN, "0.00") & " Saniyede Tamamlandı", vbInformation
End Sub
 
Son düzenleme:
Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
Sayın Hocam; kolay gelsin bu kod hiçbir şey getirmedi, siz örnek dosyada denemiş miydiniz? Bakma imkanın var mı acaba?
 

dEdE

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
#7 nolu mesajda küçük bir değişiklik yaptım. Dener misiniz?
 
Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
Tamam abim çok güzel oldu. Eline sağlık sayın abim şurada bir düzenleme olabilir mi? Bu kodu sadece "AÇIK DOSYAM" adlı bir dosyada çalışmayacağımda örneğin her ay için farklı kaydet mantığı ile her ayı ayrı yapacağım bu nedenle bu isimle değil de aktif çalışma dosyası şeklinde ola bilir mi?

Sub Veri_Al()
ZMN = Timer
Application.ScreenUpdating = False
Yol = "D:\Belgelerim\Personel\"
Dosya = "PERSONEL LİSTESİ.xlsm"
ss2 = Workbooks("06 HAZİRAN 2022").Sheets("PUANTAJ").Cells(Rows.Count, "AX").End(3).Row + 1
Set FSO = CreateObject("Scripting.FileSystemObject")
Set K1 = Workbooks.Open(Yol & Dosya)
ss1 = ActiveSheet.Cells(Rows.Count, "S").End(3).Row
For i = 2 To ss1
If Not ActiveWorkbook.Sheets("LİSTE").Cells(i, "S").Comment Is Nothing Then
With Workbooks("06 HAZİRAN 2022").Sheets("PUANTAJ")
.Cells(ss2, "AX") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "B")
.Cells(ss2, "AY") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "S").Comment.Text
.Cells(ss2, "AX").Font.Color = vbGreen
.Cells(ss2, "AY").Font.Color = vbGreen
.Cells(ss2, "AU") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "C")
.Cells(ss2, "AV") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "D")
.Cells(ss2, "AW") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "E")
End With
ss2 = ss2 + 1
End If
Next
K1.Close False
Application.ScreenUpdating = True
MsgBox "İşlem " & Format(Timer - ZMN, "0.00") & " Saniyede Tamamlandı", vbInformation
Buralara ActiveWorkbook yazdım olmadı. Bunu yapabilir miyiz.
 

dEdE

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
Merhaba,
"06 HAZİRAN 2022" şeklinde yazarsanız çalışır. Başka bir yerde hata yapıyor olmalısınız.
Kodlarda değişiklik yapmadan(Dosya adını değiştirmeden) çalışacak kod;
Kod:
Sub Veri_Al()
ZMN = Timer
Application.ScreenUpdating = False
Yol = ThisWorkbook.Path & "\"
Dosya = "PERSONEL.xlsm"
Dosya1 = Mid(Application.Caption, 1, InStrRev(Application.Caption, "-") - 2)
ss2 = Workbooks(Dosya1).Sheets("PUANTAJ").Cells(Rows.Count, "AX").End(3).Row + 1
ss2 = Workbooks(Dosya1).Sheets("PUANTAJ").Cells(Rows.Count, "AX").End(3).Row + 1

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set K1 = Workbooks.Open(Yol & Dosya)
    ss1 = ActiveSheet.Cells(Rows.Count, "S").End(3).Row
    For i = 2 To ss1
        If Not ActiveWorkbook.Sheets("LİSTE").Cells(i, "S").Comment Is Nothing Then
        With Workbooks(Dosya1).Sheets("PUANTAJ")
            .Cells(ss2, "AX") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "B")
            .Cells(ss2, "AY") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "S").Comment.Text
            .Cells(ss2, "AX").Font.Color = vbGreen
            .Cells(ss2, "AY").Font.Color = vbGreen
            .Cells(ss2, "AU") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "C")
            .Cells(ss2, "AV") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "D")
            .Cells(ss2, "AW") = ActiveWorkbook.Sheets("LİSTE").Cells(i, "E")
        End With
            ss2 = ss2 + 1
        End If
    Next
    K1.Close False
    ss2 = ""
    Application.ScreenUpdating = True
    MsgBox "İşlem " & Format(Timer - ZMN, "0.00") & " Saniyede Tamamlandı", vbInformation
End Sub
 
Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
Sayın abim günaydın; senide rahatsız ediyorum ama kusuruma bakma lütfen, bu kodu denedim ancak
ss2 = Workbooks(Dosya1).Sheets("PUANTAJ").Cells(Rows.Count, "AX").End(3).Row + 1
burda hata verdi sarı yandı. Mükerrer yazmışsın acaba bundan mı dedim birini sildim yine çalışmadı burada takıldı. Hakkını helal et.
 

dEdE

Destek Ekibi
Destek Ekibi
Katılım
1 Temmuz 2005
Mesajlar
2,605
Excel Vers. ve Dili
Ofis 2013 TR 64 Bit
Ekli dosyayı dener misiniz?
Personel isimli dosyanızla aynı klasörde olmalı.
 

Ekli dosyalar

Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
01-03-2023
Tamam sayın abim oldu, çok teşekkür ederim zahmet verdim ellerine sağlık tekrar kusura bakma seni üzdüm ise....
 
Üst