• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

H

Hacı Bayram ÖZKAN

Katılım
24 Şubat 2009
Mesajlar
1,077
Excel Vers. ve Dili
2016
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

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:
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.
 
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:
Sayın Hocam; kolay gelsin bu kod hiçbir şey getirmedi, siz örnek dosyada denemiş miydiniz? Bakma imkanın var mı acaba?
 
#7 nolu mesajda küçük bir değişiklik yaptım. Dener misiniz?
 
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
Genişletmek için tıkla ...

Buralara ActiveWorkbook yazdım olmadı. Bunu yapabilir miyiz.
 
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
 
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.
 
Ekli dosyayı dener misiniz?
Personel isimli dosyanızla aynı klasörde olmalı.
 

Ekli dosyalar

Tamam sayın abim oldu, çok teşekkür ederim zahmet verdim ellerine sağlık tekrar kusura bakma seni üzdüm ise....
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst