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

[Hacı Bayram ÖZKAN]

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.

 

[Hacı Bayram ÖZKAN]

..

 

[Hacı Bayram ÖZKAN]

Selamüm Aleyküm arkadaşlar bu konuya baka bilir misiniz.

 

[dEdE]

Dener misiniz?

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

 

[Hacı Bayram ÖZKAN]

Sayın hocam teşekkür ederim deneme imkanım yok aksilik olursa bildiririm. İyi günler dua ile kalın

 

[Hacı Bayram ÖZKAN]

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]

Merhaba,
Açıklamanızdan bunu anladım.

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

 

[Hacı Bayram ÖZKAN]

Sayın Hocam; kolay gelsin bu kod hiçbir şey getirmedi, siz örnek dosyada denemiş miydiniz? Bakma imkanın var mı acaba?

 

[dEdE]

#7 nolu mesajda küçük bir değişiklik yaptım. Dener misiniz?

 

[Hacı Bayram ÖZKAN]

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]

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;

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

 

[Hacı Bayram ÖZKAN]

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]

Ekli dosyayı dener misiniz?
Personel isimli dosyanızla aynı klasörde olmalı.

 

[Hacı Bayram ÖZKAN]

Tamam sayın abim oldu, çok teşekkür ederim zahmet verdim ellerine sağlık tekrar kusura bakma seni üzdüm ise....