Soru Açık Dosya Varmı

bulentkars · 22 Mart 2022

Arkadaşlar Merhaba

O:\TALIMATLAR\ Klasörü altında birden fazla yaklaşık 15 adet çalışma kitabı var. uzantısı xlsm burada yapmak istediğim makro çalıştığımda ilgili klasör altında olan xlsm sayfalarında açık dosya varsa uyarı şeklinde vermesi. Örneğin 1.xlsm - 5.xlsm - 15.xlsm çalışma kitaplarışu anda açıktır. Uyarısı verecek eğer klasörün altındaki çalışma kitapları kapalı ise kapalı uyarısı verecek. Yardımcı olabilecek arkadaşlara şimdiden teşekkür ediyorum.

kulomer46 · 23 Mart 2022

Değerli Arkadaşım Merhaba

Çalışmanız Hazır.

Selamlar...

https://dosyam.org/Axa/Klasör_Yolunda_Belirtilen_Klasördeki_Açık_Kapalı_Dosyaları_Listele__23.03.2022.xlsm

Ekran Resmi

bulentkars · 23 Mart 2022

Merhaba
Üyelik işlemini 1 haftadır maalesef hata alıyordum. Nihayet az önce üyeliğimi başlattım. Dosyayı indiremiyorum. Kodu veya mailime iletmeniz mümkün olur mu acaba
Teşekkürler

bulentkars · 23 Mart 2022

Merhaba
Dosyayı indiremiyorum. Kodu paylaşma şansınız var mı acaba

kulomer46 · 23 Mart 2022

Değerli Arkadaşım Tekrar Merhaba

Dosyanın daha gelişmiş halini ekliyorum.

İyi çalışmalar...

Ekran Resmi

Kod:

Sub Klasör_Secimi()
'23.03.2022  11:56

With Application.FileDialog(msoFileDialogFolderPicker)

    If .Show = -1 Then
  
       Cells(3, 4) = .SelectedItems(1)
       Call Aktar
  
    End If
  
End With
  
End Sub

Sub Aktar()
'23.03.2022  09:06

Dim anadosya, ddosya, sayy, f, i5, i, j, atla44, uzanti, iiii, Kaynak_Dosya, dizi(599)
Dim sV As Worksheet, bul As Object

Rows("14:1999").Delete Shift:=xlUp

klasöryolu = Cells(3, 4) '"D:\Desktop\Deneme 1"

ReDim dizisayya(9999)
ReDim dizisayyk(9999)

sayya = 0
sayyk = 0

DoEvents

Cells(1, 1) = Cells(1, 1)

timer1 = Timer
Do While Timer - timer1 < 0.3
Loop


On Error GoTo hata

For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(klasöryolu).Files

    ddosya = dosya
  
    For i5 = Len(ddosya) To 1 Step -1
        If Mid(ddosya, i5, 1) = "\" Then
      
            ddosya = Mid(ddosya, i5 + 1, Len(ddosya) - i5 + 1)
            GoTo atla77
          
        End If
    Next
  
atla77:

If Left(ddosya, 1) = Chr(126) Then GoTo uç7
  
    For iiii = 1 To Workbooks.Count
      
        If ddosya = Workbooks(iiii).Name Then
          
            metina = metina & Chr(10) & Workbooks(iiii).Name
            sayya = sayya + 1
            dizisayya(sayya) = Workbooks(iiii).Name
            GoTo uç7
      
        End If
  
  
    Next
  
    metink = metink & Chr(10) & ddosya
    sayyk = sayyk + 1
    dizisayyk(sayyk) = ddosya

uç7:

Next

Cells(15, 3) = klasöryolu & "  klasöründe"
Cells(15, 3).Font.Bold = True

Cells(17, 3) = "   Açık Dosya  (" & sayya & "  Adet)"
Cells(17, 3).Font.Bold = True

For i = 1 To sayya
  
    Cells(17 + i, 3) = dizisayya(i)

Next

Cells(18 + sayya + 2, 3) = "   Kapalı Dosya  (" & sayyk & "  Adet)"
Cells(18 + sayya + 2, 3).Font.Bold = True

For i = 1 To sayyk
  
    Cells(18 + sayya + 2 + i, 3) = dizisayyk(i)

Next



MsgBox klasöryolu & "  klasöründe" & Chr(10) & Chr(10) & "Açık Dosya  (" & sayya & "  Adet)" & _
Chr(10) & metina & Chr(10) & Chr(10) & Chr(10) & "Kapalı Dosya  (" & sayyk & "  Adet)" & Chr(10) & metink, , " Açık Kapalı Dosyalar "

Exit Sub

hata:

Application.ScreenUpdating = False

Cells(15, 3) = "Bilgisayarınızda"

Cells(17, 3) = "   " & klasöryolu
Cells(17, 3).Font.Bold = True

Cells(19, 3) = "Klasörü bulunmuyor"

    With Columns("C:C")
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
  
Application.ScreenUpdating = True

MsgBox "Bilgisayarınızda" & Chr(10) & Chr(10) & "  " & klasöryolu & Chr(10) & Chr(10) & "  Klasörü bulunmuyor", , "Klasör"

End Sub

https://dosyam.org/Axd/Klasör_Yolu_Klasöründeki_Açık_Kapalı_Dosyaları_Listele_(Vers.1).xlsm

bulentkars · 23 Mart 2022

Merhaba,

Sonucu sadece msgbox'ta göstermesi yeterli olur benim için, sayfalara kopyalama yapma işlemini kaldırabilirseniz sevinirim. iyi çalışmalar

kulomer46 · 23 Mart 2022

bulentkars' Alıntı:
Merhaba,

Sonucu sadece msgbox'ta göstermesi yeterli olur benim için, sayfalara kopyalama yapma işlemini kaldırabilirseniz sevinirim. iyi çalışmalar

Merhaba

Son talebinizi içeren dosya Ek 'tedir.

bulentkars · 23 Mart 2022

Dosyayı indiremiyorum. Kodu paylaşabilirsiniz sevinirim. Teşekkürler

kulomer46 · 23 Mart 2022

Merhaba

Kodlar aşağıdadır.

Kod:

Sub Klasör_Secimi()
'23.03.2022  11:56

With Application.FileDialog(msoFileDialogFolderPicker)

    If .Show = -1 Then
   
       Cells(3, 4) = .SelectedItems(1)
       Call Aktar
   
    End If
   
End With
   
End Sub

Sub Aktar()
'23.03.2022  09:06

Dim anadosya, ddosya, sayy, f, i5, i, j, atla44, uzanti, iiii, Kaynak_Dosya, dizi(599)
Dim sV As Worksheet, bul As Object

'Rows("14:1999").Delete Shift:=xlUp

klasöryolu = Cells(3, 4) '"D:\Desktop\Deneme 1"

ReDim dizisayya(9999)
ReDim dizisayyk(9999)

sayya = 0
sayyk = 0

' DoEvents

' Cells(1, 1) = Cells(1, 1)

' timer1 = Timer
' Do While Timer - timer1 < 0.3
' Loop


On Error GoTo hata

For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(klasöryolu).Files

    ddosya = dosya
   
    For i5 = Len(ddosya) To 1 Step -1
        If Mid(ddosya, i5, 1) = "\" Then
       
            ddosya = Mid(ddosya, i5 + 1, Len(ddosya) - i5 + 1)
            GoTo atla77
           
        End If
    Next
   
atla77:

If Left(ddosya, 1) = Chr(126) Then GoTo uç7
   
    For iiii = 1 To Workbooks.Count
       
        If ddosya = Workbooks(iiii).Name Then
           
            metina = metina & Chr(10) & Workbooks(iiii).Name
            sayya = sayya + 1
            dizisayya(sayya) = Workbooks(iiii).Name
            GoTo uç7
       
        End If
   
   
    Next
   
    metink = metink & Chr(10) & ddosya
    sayyk = sayyk + 1
    dizisayyk(sayyk) = ddosya

uç7:

Next

'Cells(15, 3) = klasöryolu & "  klasöründe"
'Cells(15, 3).Font.Bold = True
'
'Cells(17, 3) = "   Açık Dosya  (" & sayya & "  Adet)"
'Cells(17, 3).Font.Bold = True
'
'For i = 1 To sayya
'
'    Cells(17 + i, 3) = dizisayya(i)
'
'Next
'
'Cells(18 + sayya + 2, 3) = "   Kapalı Dosya  (" & sayyk & "  Adet)"
'Cells(18 + sayya + 2, 3).Font.Bold = True
'
'For i = 1 To sayyk
'
'    Cells(18 + sayya + 2 + i, 3) = dizisayyk(i)
'
'Next



MsgBox klasöryolu & "  klasöründe" & Chr(10) & Chr(10) & "Açık Dosya  (" & sayya & "  Adet)" & _
Chr(10) & metina & Chr(10) & Chr(10) & "Kapalı Dosya  (" & sayyk & "  Adet)" & Chr(10) & metink, , " Açık Kapalı Dosyalar "

Exit Sub

hata:

Application.ScreenUpdating = False

'Cells(15, 3) = "Bilgisayarınızda"
'
'Cells(17, 3) = "   " & klasöryolu
'Cells(17, 3).Font.Bold = True
'
'Cells(19, 3) = "Klasörü bulunmuyor"

    With Columns("C:C")
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
   
Application.ScreenUpdating = True

MsgBox "Bilgisayarınızda" & Chr(10) & Chr(10) & "  " & klasöryolu & Chr(10) & Chr(10) & "  Klasörü bulunmuyor", , "Klasör"


End Sub

bulentkars · 23 Mart 2022

Çok teşekkür ederim. Tam istediğim gibi olmuş.

kulomer46 · 23 Mart 2022

bulentkars' Alıntı:
Çok teşekkür ederim. Tam istediğim gibi olmuş.

Selamlar...

bulentkars · 26 Mart 2022

Tekrar Merhaba
Klasör altındaki dosya kullanıcıları için fonksiyon kullanıyorum. Bu fonksiyonu sizin makroya ilete edebilir miyiz. Acaba. Örneğin şu anda açık olan dosya isimlerini msgboxta veriyor. Aynı şeklinde her dosyanın yanına fonksiyondaki kullanıcı ismlerini göstere bilir miyiz. Mesela 2.xlsm dosyası Bayram Kara ismini de görüntülemek istiyorum. Şimdiden teşekkürler

Kod:

Function kullanıcı(a As Range)
Select Case a.Value
    Case "1.xlsm"
    kullanıcı = "admin"
    Case "2.xlsm"
    kullanıcı = "Bayram Kara"
    Case "3.xlsm"
    kullanıcı = "Berzan Güzel"
    Case Else
    kullanıcı = "Başkası"
End Select
End Function

kulomer46 · 27 Mart 2022

bulentkars' Alıntı:
Tekrar Merhaba
Klasör altındaki dosya kullanıcıları için fonksiyon kullanıyorum. Bu fonksiyonu sizin makroya ilete edebilir miyiz. Acaba. Örneğin şu anda açık olan dosya isimlerini msgboxta veriyor. Aynı şeklinde her dosyanın yanına fonksiyondaki kullanıcı ismlerini göstere bilir miyiz. Mesela 2.xlsm dosyası Bayram Kara ismini de görüntülemek istiyorum. Şimdiden teşekkürler

Kod:

Function kullanıcı(a As Range) Select Case a.Value Case "1.xlsm" kullanıcı = "admin" Case "2.xlsm" kullanıcı = "Bayram Kara" Case "3.xlsm" kullanıcı = "Berzan Güzel" Case Else kullanıcı = "Başkası" End Select End Function

Değerli Arkadaşım Tekrar Merhaba

Son talebinizi karşılayan makro kodu aşağıdadır.

Selamlar...

Kod:

Sub Klasör_Secimi()
 '23.03.2022  11:56
 
With Application.FileDialog(msoFileDialogFolderPicker)

    If .Show = -1 Then
    
       Cells(3, 4) = .SelectedItems(1)
       Call Aktar
    
    End If
    
End With
    
End Sub

Sub Aktar()
'23.03.2022  09:06
'27.03.2022  12:25


Dim anadosya, ddosya, sayy, f, i5, i, j, atla44, uzanti, iiii, Kaynak_Dosya, dizi(599)
Dim sV As Worksheet, bul As Object

'Rows("14:1999").Delete Shift:=xlUp

klasöryolu = Cells(3, 4) '"D:\Desktop\Deneme 1"

ReDim dizisayya(9999)
ReDim dizisayyk(9999)

sayya = 0
sayyk = 0

' DoEvents
 
' Cells(1, 1) = Cells(1, 1)

' timer1 = Timer
' Do While Timer - timer1 < 0.3
' Loop
 

On Error GoTo hata

For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(klasöryolu).Files

    ddosya = dosya
    
    For i5 = Len(ddosya) To 1 Step -1
        If Mid(ddosya, i5, 1) = "\" Then
        
            ddosya = Mid(ddosya, i5 + 1, Len(ddosya) - i5 + 1)
            GoTo atla77
            
        End If
    Next
    
atla77:

If Left(ddosya, 1) = Chr(126) Then GoTo uç7
    
    For iiii = 1 To Workbooks.Count
        
        If ddosya = Workbooks(iiii).Name Then
            
            metina = metina & Chr(10) & Workbooks(iiii).Name
            
            metinek = ""
            
            '/////////////////////////////////////////////////////
            
'                Function kullanıcı(a As Range)
                Select Case Workbooks(iiii).Name
                    Case "1.xlsm"
                    metina = metina & "  Kullanıcı Admin"
                    metinek = "  Kullanıcı Admin"
                    Case "2.xlsm"
                    metina = metina & "  Kullanıcı Bayram Kara"
                    metinek = "  Kullanıcı Bayram Kara"
                    Case "3.xlsm"
                    metina = metina & "  Kullanıcı Berzan Güzel"
                    metinek = "  Kullanıcı Berzan Güzel"
                    Case Else
                    metina = metina & "  Kullanıcı Başkası"
                    metinek = "  Kullanıcı Başkası"
                    
                End Select
'                End Function
            
            
            '////////////////////////////////////////////////////
            
            
            sayya = sayya + 1
            dizisayya(sayya) = Workbooks(iiii).Name & metinek
            metinek = ""
            GoTo uç7
        
        End If
    
    
    Next
    
    metink = metink & Chr(10) & ddosya
    sayyk = sayyk + 1
    dizisayyk(sayyk) = ddosya

uç7:

Next

'Cells(15, 3) = klasöryolu & "  klasöründe"
'Cells(15, 3).Font.Bold = True
'
'Cells(17, 3) = "   Açık Dosya  (" & sayya & "  Adet)"
'Cells(17, 3).Font.Bold = True
'
'For i = 1 To sayya
'
'    Cells(17 + i, 3) = dizisayya(i)
'
'Next
'
'Cells(18 + sayya + 2, 3) = "   Kapalı Dosya  (" & sayyk & "  Adet)"
'Cells(18 + sayya + 2, 3).Font.Bold = True
'
'For i = 1 To sayyk
'
'    Cells(18 + sayya + 2 + i, 3) = dizisayyk(i)
'
'Next



MsgBox klasöryolu & "  klasöründe" & Chr(10) & Chr(10) & "Açık Dosya  (" & sayya & "  Adet)" & _
 Chr(10) & metina & Chr(10) & Chr(10) & "Kapalı Dosya  (" & sayyk & "  Adet)" & Chr(10) & metink, , " Açık Kapalı Dosyalar "

Exit Function

hata:

Application.ScreenUpdating = False

'Cells(15, 3) = "Bilgisayarınızda"
'
'Cells(17, 3) = "   " & klasöryolu
'Cells(17, 3).Font.Bold = True
'
'Cells(19, 3) = "Klasörü bulunmuyor"

    With Columns("C:C")
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
Application.ScreenUpdating = True

MsgBox "Bilgisayarınızda" & Chr(10) & Chr(10) & "  " & klasöryolu & Chr(10) & Chr(10) & "  Klasörü bulunmuyor", , "Klasör"


End Function

bulentkars · 27 Mart 2022

Merhaba

çok teşekkürler tam istediğim gibi olmuş. Emeğinize sağlık.
sadece msgbox tamam dedikten sonra
En sondaki msgbox açılıyor. Bilgisayarınızda C:/ deneme bulunmadı uyarısı geliyor. Sondaki uyarıyı pasif ettiğimde sorun kalmıyor. Ama klasör gerçekten olmadığında da bu uyarıyı alamayacağım.

kulomer46 · 27 Mart 2022

Merhaba

Aşağıdaki şekilde kullanınız.

Selamlar...

Kod:

Sub Klasör_Secimi()
 '23.03.2022  11:56
 
With Application.FileDialog(msoFileDialogFolderPicker)

    If .Show = -1 Then
    
       Cells(3, 4) = .SelectedItems(1)
       Call Aktar
    
    End If
    
End With
    
End Sub

Sub Aktar()
'23.03.2022  09:06
'27.03.2022  12:25


Dim anadosya, ddosya, sayy, f, i5, i, j, atla44, uzanti, iiii, Kaynak_Dosya, dizi(599)
Dim sV As Worksheet, bul As Object

'Rows("14:1999").Delete Shift:=xlUp

klasöryolu = Cells(3, 4) '"D:\Desktop\Deneme 1"

ReDim dizisayya(9999)
ReDim dizisayyk(9999)

sayya = 0
sayyk = 0

' DoEvents
 
' Cells(1, 1) = Cells(1, 1)

' timer1 = Timer
' Do While Timer - timer1 < 0.3
' Loop
 

On Error GoTo hata

For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(klasöryolu).Files

    ddosya = dosya
    
    For i5 = Len(ddosya) To 1 Step -1
        If Mid(ddosya, i5, 1) = "\" Then
        
            ddosya = Mid(ddosya, i5 + 1, Len(ddosya) - i5 + 1)
            GoTo atla77
            
        End If
    Next
    
atla77:

If Left(ddosya, 1) = Chr(126) Then GoTo uç7
    
    For iiii = 1 To Workbooks.Count
        
        If ddosya = Workbooks(iiii).Name Then
            
            metina = metina & Chr(10) & Workbooks(iiii).Name
            
            metinek = ""
            
            '/////////////////////////////////////////////////////
            
'                Function kullanıcı(a As Range)
                Select Case Workbooks(iiii).Name
                    Case "1.xlsm"
                    metina = metina & "  Kullanıcı Admin"
                    metinek = "  Kullanıcı Admin"
                    Case "2.xlsm"
                    metina = metina & "  Kullanıcı Bayram Kara"
                    metinek = "  Kullanıcı Bayram Kara"
                    Case "3.xlsm"
                    metina = metina & "  Kullanıcı Berzan Güzel"
                    metinek = "  Kullanıcı Berzan Güzel"
                    Case Else
                    metina = metina & "  Kullanıcı Başkası"
                    metinek = "  Kullanıcı Başkası"
                    
                End Select
'                End Function
            
            
            '////////////////////////////////////////////////////
            
            
            sayya = sayya + 1
            dizisayya(sayya) = Workbooks(iiii).Name & metinek
            metinek = ""
            GoTo uç7
        
        End If
    
    
    Next
    
    metink = metink & Chr(10) & ddosya
    sayyk = sayyk + 1
    dizisayyk(sayyk) = ddosya

uç7:

Next

'Cells(15, 3) = klasöryolu & "  klasöründe"
'Cells(15, 3).Font.Bold = True
'
'Cells(17, 3) = "   Açık Dosya  (" & sayya & "  Adet)"
'Cells(17, 3).Font.Bold = True
'
'For i = 1 To sayya
'
'    Cells(17 + i, 3) = dizisayya(i)
'
'Next
'
'Cells(18 + sayya + 2, 3) = "   Kapalı Dosya  (" & sayyk & "  Adet)"
'Cells(18 + sayya + 2, 3).Font.Bold = True
'
'For i = 1 To sayyk
'
'    Cells(18 + sayya + 2 + i, 3) = dizisayyk(i)
'
'Next



MsgBox klasöryolu & "  klasöründe" & Chr(10) & Chr(10) & "Açık Dosya  (" & sayya & "  Adet)" & _
 Chr(10) & metina & Chr(10) & Chr(10) & "Kapalı Dosya  (" & sayyk & "  Adet)" & Chr(10) & metink, , " Açık Kapalı Dosyalar "

Exit sub

hata:

Application.ScreenUpdating = False

'Cells(15, 3) = "Bilgisayarınızda"
'
'Cells(17, 3) = "   " & klasöryolu
'Cells(17, 3).Font.Bold = True
'
'Cells(19, 3) = "Klasörü bulunmuyor"

    'With Columns("C:C")
      '  .HorizontalAlignment = xlGeneral
      '  .VerticalAlignment = xlBottom
      '  .WrapText = False
      '  .Orientation = 0
      '  .AddIndent = False
      ' .IndentLevel = 0
      '  .ShrinkToFit = False
      '  .ReadingOrder = xlContext
     '   .MergeCells = False
  '  End With
    
Application.ScreenUpdating = True

MsgBox "Bilgisayarınızda" & Chr(10) & Chr(10) & "  " & klasöryolu & Chr(10) & Chr(10) & "  Klasörü bulunmuyor", , "Klasör"


End sub

bulentkars · 28 Mart 2022

Günaydın,

Emeğinize yüreğinize sağlık. Çok Teşekkür ederim.

kulomer46 · 28 Mart 2022

bulentkars' Alıntı:
Günaydın,

Emeğinize yüreğinize sağlık. Çok Teşekkür ederim.

Selamlar...

Soru Açık Dosya Varmı

bulentkars

kulomer46

Ekli dosyalar

bulentkars

bulentkars

kulomer46

Ekli dosyalar

bulentkars

kulomer46

Ekli dosyalar

bulentkars

kulomer46

bulentkars

kulomer46

bulentkars

kulomer46

bulentkars

kulomer46

bulentkars

kulomer46