salt okunur dosyaları yazdırma

B

badmad34

Katılım
28 Haziran 2007
Mesajlar
141
Excel Vers. ve Dili
microsoft office 2007 - ingilizce
Merhabalar,

Öncelikle, vba konusunda acemi olduğumu belirteyim. Her gün işyerinde ortak sunucu üstünde bir dizi excel çalışma kitabını açıp, içindeki linkleri güncelleyerek ardından kaydedip kapamam gerekiyor. Bu işi şu şekilde bi kodla halledebildim:

Kod: 
Private Sub File_Update()

Workbooks.Open ("D:\a.xlsx"), UpdateLinks:=xlUpdateLinksAlways
ActiveWorkbook.Close SaveChanges:=True
Workbooks.Open ("D:\b.xlsx"), UpdateLinks:=xlUpdateLinksAlways
ActiveWorkbook.Close SaveChanges:=True
'... Bu şekilde çokça çalışma kitabı var.

End Sub
Yalnız bu kodla şöyle bir sıkıntı oluyor. Eğer açılan dosyalardan herhangi biri başka bir kullanıcı tarafından açılmışsa dosya salt okunur (read-only) açıldığından güncellenemiyor ve kaydedilemiyor. Ben bu şekilde açılamayan dosya olunca bana bir hata mesajı versin, dosya üstünde bir değişiklik yapmaya çalışmasın ve masaüstünde hangi dosyanın açılamadığını bir text dosyası oluşturup yazmasını istiyorum. Nasıl halledebilirim bu işi? Gerçekten benim için büyük bir zaman kazancı olacak. Şimdiden teşekkürler.
 
mancubus

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
amma çok şey istemişsiniz. :)
google'da oldukça zaman harcadım. tabii şikayet değil. bu soruyu bir öğrenme fırsatı olarak değerlendirdim. kendim için de çalıştım yani. :)

boş bir excel dosyasına aşağıdaki kodu kopyalayarak deneyin.
oluşacak hataları üstadların yardımı ile veya deneme yanılma metodu ile çözeriz zannediyorum.

tek tek dosyaları açmadan halletme amacını güttüm.
denemeden önce bir kaç dosyanın diğer kullanıcılar tarafından açılmasını sağlayın ki, çalışıp çalışmadığını ilk elden anlayalım.

kodların içindeki linkler kodların kaynaklarıdır. emeğe saygı açısından silmeden muhafaza eder, hatta bu konunun linkini de eklerseniz iyi olur.

kodları kopyalayacağınız dosyanızda (Türkçe Excel) Sayfa1 isimli bir sheet'in bulunduğunu var saydım. değilse kodun içindeki bu bölümü değiştirmeniz gerekir.



Kod: 
Sub RunCodeOnAllXLSFiles()
'http://www.ozgrid.com/VBA/loop-through.htm

Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

On Error Resume Next
    Set wbCodeBook = ThisWorkbook
        With Application.FileSearch
            .NewSearch
            'yolu kendi dosyalarınıza göre uyarlayın
            .LookIn = "C:\MyDocuments\TestResults"
            .FileType = msoFileTypeExcelWorkbooks
            'dosyalar için opsiyonel filtre
            '.Filename = "Book*.xls"
                If .Execute > 0 Then
                    For lCount = 1 To .FoundFiles.Count
                        If GetAttr(.FoundFiles(lCount)) Mod 2 Then
                            MsgBox "Dosya başka kulllanıcı tarafından açılmış!"
                            Dim dDosya As String
                            dDosya = Application.GetOpenFilename
                            Sheets("Sayfa1").Range("A65536").End(3).Offset(1, 0) = dDosya
                        Else
                            Set wbResults = Workbooks.Open(FileName:=.FoundFiles(lCount), UpdateLinks:=xlUpdateLinksAlways)
                            wbResults.Close SaveChanges:=True
                        End If
                    Next lCount
                End If
        End With
On Error GoTo 0

Dim masaustu As String
    masaustu = Environ$("UserProfile") & "\Desktop\"

ExportToTextFile FName:=masaustu & "read-only dosyalar.txt", Sep:=";", SelectionOnly:=False, AppendData:=True

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub

Public Sub ExportToTextFile(FName As String, _
    Sep As String, SelectionOnly As Boolean, _
    AppendData As Boolean)
'http://www.cpearson.com/excel/ImpText.aspx

Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String

Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile

If SelectionOnly = True Then
    With Selection
        StartRow = .Cells(1).Row
        StartCol = .Cells(1).Column
        EndRow = .Cells(.Cells.Count).Row
        EndCol = .Cells(.Cells.Count).Column
    End With
Else
    With ActiveSheet.UsedRange
        StartRow = .Cells(1).Row
        StartCol = .Cells(1).Column
        EndRow = .Cells(.Cells.Count).Row
        EndCol = .Cells(.Cells.Count).Column
    End With
End If

If AppendData = True Then
    Open FName For Append Access Write As #FNum
Else
    Open FName For Output Access Write As #FNum
End If

For RowNdx = StartRow To EndRow
    WholeLine = ""
    For ColNdx = StartCol To EndCol
        If Cells(RowNdx, ColNdx).Value = "" Then
            CellValue = Chr(34) & Chr(34)
        Else
           CellValue = Cells(RowNdx, ColNdx).Value
        End If
        WholeLine = WholeLine & CellValue & Sep
    Next ColNdx
    WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
    Print #FNum, WholeLine
Next RowNdx

EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum

End Sub
 
Son düzenleme:
mancubus

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
merhaba.

kodda hata var. şimdilik denemeyelim.
 
Zeki Gürsoy

Zeki Gürsoy

Uzman
Uzman
Katılım
31 Aralık 2005
Mesajlar
4,390
Excel Vers. ve Dili
Office 365 (64 bit) - Türkçe
Merhaba,

Bu durumda dosyayı açtıktan sonra Readonly durumunu kontrol etmek gerek.
Aşağıda, saltokunur ise olduğu gibi kapatmasını istedik.

Kod: 
Set wbResults = Workbooks.Open(FileName:=.FoundFiles(lCount))
if  [B]wbResults.readonly[/B] then wbResults.Close SaveChanges:=[B]False[/B]
End If
 
mancubus

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
Merhaba.
Farklı bir çalışmada kullandığım kodları aşağıdaki gibi uyarladım.
işinize yaraması lazım.

bir önceki kodlu mesajımı dikkate almayın.
(o daha farklı bir çalışma için kullandığım kod. kodda benim yönümden bir hata yok ta kopyala yapıştırda tüm satırlara bakmayınca size yaramayacak bir kod olmuş.)

Kod: 
Sub DosyaAcUpdateKapa()
'http://www.eggheadcafe.com/software/aspnet/33007769/run-macro-on-multiple-files.aspx

Dim f As String
Dim roww As Long
roww = 1
Dim FileLocSpec As String
FileLocSpec = "C:\Dosyalar\*.xls*"
f = Dir(FileLocSpec)

Dim wb As Workbook
Set wb = ThisWorkbook

wb.Sheets("Sheet1").Range("A1") = "Klasördeki Dosyalar"
wb.Sheets("Sheet1").Range("B1") = "Klasördeki Read-Only Dosyalar"

Do Until f = ""
    roww = roww + 1
    Cells(roww, 1).Value = f
    f = Dir
Loop

Set r = Range("A2")
While r.Value <> ""
    Workbooks.Open Filename:="C:\Dosyalar\" & r.Value
        If ActiveWorkbook.ReadOnly Then
            MsgBox "Read_Only Dosya!"
            Dim dDosya As String
            dDosya = ActiveWorkbook.Name
            wb.Sheets("Sheets1").Range("B65536").End(3).Offset(1, 0) = dDosya
            ActiveWorkbook.Close Savechanges:=False
        Else
            Dim lnk As Variant
            On Error Resume Next
            For Each lnk In ActiveWorkbook.LinkSources
                ActiveWorkbook.UpdateLink Name:=lnk, Type:=xlExcelLinks
            Next lnk
            ActiveWorkbook.Close Savechanges:=True
        End If
    Set r = r.Offset(1, 0)
Wend

Dim masaustu As String
Dim ro_dosya As Long
ro_dosya = Application.CountA(Range("B2:B65536"))
masaustu = Environ$("UserProfile") & "\Desktop\"

If ro_dosya > 0 Then
    ExportToTextFile FName:=masaustu & "read-only dosyalar.txt", Sep:=";", _
        SelectionOnly:=False, AppendData:=True
Else
    MsgBox "Read_Only Dosya Yok"
End If


End Sub



Public Sub ExportToTextFile(FName As String, _
    Sep As String, SelectionOnly As Boolean, _
    AppendData As Boolean)
'http://www.cpearson.com/excel/ImpText.aspx

Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String

Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile

If SelectionOnly = True Then
    With Selection
        StartRow = .Cells(1).Row
        StartCol = .Cells(1).Column
        EndRow = .Cells(.Cells.Count).Row
        EndCol = .Cells(.Cells.Count).Column
    End With
Else
    With ActiveSheet.UsedRange
        StartRow = .Cells(1).Row
        StartCol = .Cells(1).Column
        EndRow = .Cells(.Cells.Count).Row
        EndCol = .Cells(.Cells.Count).Column
    End With
End If

If AppendData = True Then
    Open FName For Append Access Write As #FNum
Else
    Open FName For Output Access Write As #FNum
End If

For RowNdx = StartRow To EndRow
    WholeLine = ""
    For ColNdx = StartCol To EndCol
        If Cells(RowNdx, ColNdx).Value = "" Then
            CellValue = Chr(34) & Chr(34)
        Else
           CellValue = Cells(RowNdx, ColNdx).Value
        End If
        WholeLine = WholeLine & CellValue & Sep
    Next ColNdx
    WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
    Print #FNum, WholeLine
Next RowNdx

EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum

End Sub
 
B

badmad34

Katılım
28 Haziran 2007
Mesajlar
141
Excel Vers. ve Dili
microsoft office 2007 - ingilizce
çabanız için teşekkür ederim. kendi kodumu yazayım, belki faydası olur modifiye etme açısından.

Kod: 
Sub Update()
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGB #1 ESN 695267\ESN 695267 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGB #1 ESN 695267\ESN 695267 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGB #1 ESN 695267\ESN 695267 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGB #1 ESN 695267\ESN 695267 PCNLI.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGB #2 ESN 695203\ESN 695203 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGB #2 ESN 695203\ESN 695203 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGB #2 ESN 695203\ESN 695203 PCNLI.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGC #1 ESN 695358\ESN 695358 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGC #1 ESN 695358\ESN 695358 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGC #1 ESN 695358\ESN 695358 PCNLI.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGC #2 ESN 695407\ESN 695407 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGC #2 ESN 695407\ESN 695407 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGC #2 ESN 695407\ESN 695407 PCNLI.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGH #1 ESN 875183\ESN 875183 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGH #1 ESN 875183\ESN 875183 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGH #1 ESN 875183\ESN 875183 Task Cards.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGH #2 ESN 874179\ESN 874179 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGH #2 ESN 874179\ESN 874179 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGH #2 ESN 874179\ESN 874179 Task Cards.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGI #1 ESN 874196\ESN 874196 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGI #1 ESN 874196\ESN 874196 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGI #1 ESN 874196\ESN 874196 Task Cards.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGI #2 ESN 874132\ESN 874132 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGI #2 ESN 874132\ESN 874132 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGI #2 ESN 874132\ESN 874132 Task Cards.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGJ #1 ESN 41013\ESN 41013 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGJ #1 ESN 41013\ESN 41013 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGJ #1 ESN 41013\ESN 41013 Task Cards.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGJ #2 ESN 41384\ESN 41384 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGJ #2 ESN 41384\ESN 41384 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGJ #2 ESN 41384\ESN 41384 PCNLI.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGK #1 ESN 876220\ESN 876220 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGK #1 ESN 876220\ESN 876220 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGK #2 ESN 876226\ESN 876226 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGK #2 ESN 876226\ESN 876226 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGL #1 ESN 877244\ESN 877244 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGL #1 ESN 877244\ESN 877244 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGL #2 ESN 876252\ESN 876252 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGL #2 ESN 876252\ESN 876252 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
For Each w In Workbooks
    If w.Name <> ThisWorkbook.Name Then
        w.Close savechanges:=True
    End If
Next w
Range("D1:E1") = Now
End Sub
 
Son düzenleme:
B

badmad34

Katılım
28 Haziran 2007
Mesajlar
141
Excel Vers. ve Dili
microsoft office 2007 - ingilizce
sayfayı güncellemediğim aradaki mesajları yazdıklarınızı görmemişim. çok sağolun cevaplarınız için.

yalnız şöyle bir sorun var: benim kodumun yukardaki gibi bir yapısı olduğundan yazdığınız kodları nasıl eklemem gerektiğini çözemedim. en baştan kodumu yazmamam buna yol açtı ama yardımcı olabilirseniz çok makbule geçecek.
 
mancubus

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
1-2 yerde hata yapmışım. öğleye kadar zamanımı aldı. ancak benim de kullanacağım bir çalışma oldu. ileride zaman tasarrufu sağlayacak. kendimden memnun kaldım. :biggrin:

bizim iş yerinde desktop'a kaydetme imkanı olmadığı için başkasının açtığı bir dosya olmadan test ettim. problem olmadı. siz denersiniz. problem çıkarsa çözmeye gayret ederiz.



ihtiyaç duyabilecekler için her iki versiyonu da ekliyorum.

UYARLAMA
Sub TestListFilesInFolder() isimli prosedürde ListFilesInFolder "T:\ENGINEERING\", True satırı ihtiyaca göre değiştirilmeli. True = alt klasörlerdeki dosyaları da dahil et demektir. False seçilirse sadece yazılmış klasörlerdeki dosyallar üzerinde çalışır.


Not: VBE - Tools - References - Microsoft Scripting Runtime seçili olmalı.
 

Ekli dosyalar

B

badmad34

Katılım
28 Haziran 2007
Mesajlar
141
Excel Vers. ve Dili
microsoft office 2007 - ingilizce
çokı teşekkür ederim, elleriniz dert görmesin:)
 
B

badmad34

Katılım
28 Haziran 2007
Mesajlar
141
Excel Vers. ve Dili
microsoft office 2007 - ingilizce
bu arada read-only dosyayı kullanan kişi varsa bunu msgbox ile yazdırmak için bi kod ekledim. çıkan mesajda, dosyayı kullanan kişinin de adı gözüksün istiyorum. nasıl becerebilirim bunu? sadece kullanıcı adını çıkartan kodu söylemeniz yeterli. istediğim sadece şu tarz bir şey:

Kod: 
Sub Update()

Range("D1:E1").Value = Now

Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGB #1 ESN 695267\ESN 695267 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGB #1 ESN 695267\ESN 695267 LLP.xls", UpdateLinks:=xlUpdateLinksAlways
'...

For Each w In Workbooks
    If w.Name <> ThisWorkbook.Name Then
        If w.ReadOnly Then
        MsgBox w.Name & " dosyası, " & [COLOR="Red"]???Kullanıcı Adı???[/COLOR] & "tarafından kullanıldığından kaydedilmeden kapatılmıştır.", vbCritical, "UYARI!"
        w.Close savechanges:=False
        Else
        w.Close savechanges:=True
        End If
    End If
Next w
    
End Sub
 
mancubus

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
kendi durumunuza uyarlayın.

Kod: 
ActiveWorkbook.WriteReservedBy
 
B

badmad34

Katılım
28 Haziran 2007
Mesajlar
141
Excel Vers. ve Dili
microsoft office 2007 - ingilizce
öncelikle teşekkür ederim. kod çalışmasına rağmen, dosyayı kullanan kişinin adını değil de benim bilgisayarın adını yazdırıyor. sebebi ne olabilir?
 
Son düzenleme:
mancubus

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
evet. ilgin. araştıralım...
 
Son düzenleme:
B

badmad34

Katılım
28 Haziran 2007
Mesajlar
141
Excel Vers. ve Dili
microsoft office 2007 - ingilizce
hayır, özellikle makroyu çalıştırmadan önce dosyayı arkadaşıma açtırdım. acaba bir yerde yanlışlık mı yapıyorum? kodum şu şekilde:

Sub Update()

Range("D1:E1").Value = Now

Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGB #1 ESN 695267\ESN 695267 AD.xls", UpdateLinks:=xlUpdateLinksAlways
Workbooks.Open "T:\ENGINEERING\ENGINES & APUs\ENGINES\TC-SGB #1 ESN 695267\ESN 695267 LLP.xls", UpdateLinks:=xlUpdateLinksAlways


For Each w In Workbooks
If w.Name <> ThisWorkbook.Name Then
If w.ReadOnly Then
MsgBox w.Name & " dosyası, " & ActiveWorkbook.WriteReservedBy & " tarafından kullanıldığından kaydedilmeden kapatılmıştır.", vbCritical, "UYARI!"
w.Close savechanges:=False
Else
w.Close savechanges:=True
End If
End If
Next w

End Sub
Genişletmek için tıkla ...
 
mancubus

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
ben mesajımı düzenlemiştim. deneyince kendi ismimi verdiğini ben de gördüm.

araştırdığım bütün kaynaklarda dosyanın kimin tarafından açıldığını öğrenmek için bu özellik öneriliyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst