Kapalı Çalışma kitabını şartlı açmak

bulentkars · 17 Mart 2022

Arkadaşlar Merhaba
Makro ile aşağıdaki dosyayı şartlı açmak istiyorum. Kontrol xlsx A1 satırında eğer Aç yazıyorsa işlem yapacak yazmıyorsa yapmayacak.
C:\Mutabakat\Kontrol.xlsx çalışma kitabının içindeki sayfa1 de A1 satırında eğer AÇ yazıyorsa kontrol.xlsx çalışma kitabını D:\\Mutabakat\klasörüne kopyalayıp açmak istiyorum. Eğer A1 satırında AÇ yazmıyorsa dosyaya herhangi bir işlem yapılmasını istemiyorum.
Bu konuda yardımcı olabilirseniz sevinirim. Şimdiden Teşekkürler.

Korhan Ayhan · 17 Mart 2022

Deneyiniz.

C++:

Option Explicit

Sub Kapali_Dosyayi_Kosula_Gore_Ac()
    Dim Yol As String, Dosya_Adi As String, Sayfa_Adi As String
    Dim Hedef_Yol As String, WB As Workbook, Kosul As Variant
   
    Yol = "C:\Mutabakat\"
    Dosya_Adi = "Kontrol.xlsx"
    Sayfa_Adi = "Sayfa1"
    Hedef_Yol = "D:\Mutabakat\"

    If Dir(Yol & Dosya_Adi) <> "" Then
        Sendkeys "123" & "{ENTER}", True
        Kosul = ExecuteExcel4Macro("'" & Yol & "[" & Dosya_Adi & "]" & _
        Sayfa_Adi & "'!" & Range("A1").Address(, , xlR1C1))
   
        If UCase(Kosul) = "AÇ" Then
            If Dir(Hedef_Yol, vbDirectory) = "" Then MkDir Hedef_Yol
            On Error Resume Next
            Set WB = Application.Workbooks.Item(Dosya_Adi)
            On Error GoTo 0
            If Not WB Is Nothing Then WB.Close True
            FileCopy Yol & Dosya_Adi, Hedef_Yol & Dosya_Adi
            Workbooks.Open Hedef_Yol & Dosya_Adi
        End If
   
        MsgBox "İşleminiz tamamlanmıştır."
    Else
        MsgBox "Dosya bulunamadı!", vbCritical
    End If
End Sub

bulentkars · 17 Mart 2022

Merhaba,

Then MkDir Hedef_Yol

then den sonraki alanda hata veriyor

bulentkars · 17 Mart 2022

Korhan Bey,

Bir üst satıra
On Error Resume Next kopyladım oldu. Çok Teşekkür ederim. ancak hücre adını belirgin olarak gösterebiirmiyiz acaba
!R1C1 yerine range("a1") gibi olursa çok sevinirim.

Korhan Ayhan · 17 Mart 2022

#3 nolu mesajınızda bahsettiğiniz hatanın olmaması gerekir. Çünkü o satırda zaten klasörün var olup olmadığı kontrol ediliyor.

A1 adres belirtimi için kodu revize ettim. Deneyebilirsiniz.

bulentkars · 17 Mart 2022

Elinize emeğinize sağlık. Tam istediğim gibi olmuş çok teşekkür ederim.

bulentkars · 16 Nisan 2022

Makro çalışma kitabını açıyor açarken dosya açılış parolası var "123" sizden ricam önce parolayı kod ile girilmesini istiyorum , koda açılış parolasını ekleyebilirseniz çok sevinirim. teşekkürler.

Korhan Ayhan · 16 Nisan 2022

#2 nolu mesajimda ki koda küçük bir ekleme yaptım. Ben olumlu sonuç aldım umarım sizde de çalışır.

bulentkars · 17 Nisan 2022

Korhan Bey,
Çok çok teşekkür ederim Allah sizden razı olsun.
sizden son ricam ADO ile dışardan veri aldığım açılış parolası olan kodada aynı şekilde "123" şifreyi giriş yapabilirsek çok iyi olur.
şimdiden çok teşekkür ederim.

ADO ile Hesaplar.xlsm den veri alırken açılış parolası olan"123" kod ile az önce yaptığınız gibi olmasını istiyorum.

Kod:

Private Sub UserForm_Initialize()
    Set ADODB_DATA = CreateObject("ADODB.Connection")
    
    
    
    DOSYA_YOLU = "Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & "C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm" & ";Extended Properties=""Excel 8.0;HDR=no;IMEX=1"";"
    
    
    ADODB_DATA.Open DOSYA_YOLU

    

      

Dim sorgu As String
sorgu = "Select * From [" & ActiveSheet.Name & "$A2:D65536]"
SQL_SORGUSU = sorgu

    
    
      
    Set KAYIT_SETİ = ADODB_DATA.Execute(SQL_SORGUSU)
    
    ListBox1.ColumnCount = 4
    ListBox1.ColumnWidths = "265;80;125;70"
      '  ListBox1.ColumnWidths = "283;68;125;70"
    ListBox1.Column = KAYIT_SETİ.GetRows
    
End Sub
Kod:

Korhan Ayhan · 17 Nisan 2022

ADO kodlamasında şifreli dosyalara bağlantı için önce dosyayı açmanız gerekir. Bununla ilgili komut satırı için WorkBooks.Open+Password ile arama yapabilirsiniz.

bulentkars · 17 Nisan 2022

Korhan Bey,

Sitede bulamadım, size zahmet olmayacaksa eğer benim paylaştığım koda ilave edebiirseniz sevinirim. Teşekkürler

Korhan Ayhan · 17 Nisan 2022

Aşağıdaki satırı deneyebilirsiniz.

Workbooks.Open Filename:="C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm", Password:="123"

bulentkars · 17 Nisan 2022

Korhan Bey

Aşağıdaki şekilde yaptım, Hesaplar.xlsm AÇIK KALIYOR. Kapalı görünmez olmasını sağlayamaz mıyız.. teşekkürler

Kod:

Private Sub UserForm_Initialize()
    Set ADODB_DATA = CreateObject("ADODB.Connection")
    
    
    Workbooks.Open Filename:="C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm", Password:="123"
    DOSYA_YOLU = "Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & "C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm" & ";Extended Properties=""Excel 8.0;HDR=no;IMEX=1"";"
    
    
    ADODB_DATA.Open DOSYA_YOLU

    

      

Dim sorgu As String
sorgu = "Select * From [" & ActiveSheet.Name & "$A2:D65536]"
SQL_SORGUSU = sorgu

    
    
      
    Set KAYIT_SETİ = ADODB_DATA.Execute(SQL_SORGUSU)
    
    ListBox1.ColumnCount = 4
    ListBox1.ColumnWidths = "265;80;125;70"
      '  ListBox1.ColumnWidths = "283;68;125;70"
    ListBox1.Column = KAYIT_SETİ.GetRows
    
End Sub
Kod:

bulentkars · 17 Nisan 2022

Korhan Bey

Aşağıdaki şekilde yaptım, Hesaplar.xlsm AÇIK KALIYOR. Kapalı görünmez olmasını sağlayamaz mıyız.. teşekkürler

Kod:

Private Sub UserForm_Initialize()
    Set ADODB_DATA = CreateObject("ADODB.Connection")
    
    
    Workbooks.Open Filename:="C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm", Password:="123"
    DOSYA_YOLU = "Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & "C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm" & ";Extended Properties=""Excel 8.0;HDR=no;IMEX=1"";"
    
    
    ADODB_DATA.Open DOSYA_YOLU

    

      

Dim sorgu As String
sorgu = "Select * From [" & ActiveSheet.Name & "$A2:D65536]"
SQL_SORGUSU = sorgu

    
    
      
    Set KAYIT_SETİ = ADODB_DATA.Execute(SQL_SORGUSU)
    
    ListBox1.ColumnCount = 4
    ListBox1.ColumnWidths = "265;80;125;70"
      '  ListBox1.ColumnWidths = "283;68;125;70"
    ListBox1.Column = KAYIT_SETİ.GetRows
    
End Sub
Kod:

bulentkars · 17 Nisan 2022

Korhan Bey

Aşağıdaki şekilde yaptım, Hesaplar.xlsm AÇIK KALIYOR. Kapalı görünmez olmasını sağlayamaz mıyız.. teşekkürler

Kod:

Private Sub UserForm_Initialize()
    Set ADODB_DATA = CreateObject("ADODB.Connection")
    
    
    Workbooks.Open Filename:="C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm", Password:="123"
    DOSYA_YOLU = "Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & "C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm" & ";Extended Properties=""Excel 8.0;HDR=no;IMEX=1"";"
    
    
    ADODB_DATA.Open DOSYA_YOLU

    

      

Dim sorgu As String
sorgu = "Select * From [" & ActiveSheet.Name & "$A2:D65536]"
SQL_SORGUSU = sorgu

    
    
      
    Set KAYIT_SETİ = ADODB_DATA.Execute(SQL_SORGUSU)
    
    ListBox1.ColumnCount = 4
    ListBox1.ColumnWidths = "265;80;125;70"
      '  ListBox1.ColumnWidths = "283;68;125;70"
    ListBox1.Column = KAYIT_SETİ.GetRows
    
End Sub
Kod:

bulentkars · 17 Nisan 2022

Korhan Ayhan' Alıntı:
#2 nolu mesajimda ki koda küçük bir ekleme yaptım. Ben olumlu sonuç aldım umarım sizde de çalışır.

Korhan Bey,
kodun içinde iken yani vba sayfasında kodu çalıştırdığımda şifreyi sormuyor, kod ile istediğim gibi yapıyor. ancak kodu auto_open ile çalıştırdığımda parola istiyor. kodum son hali

Kod:

Option Explicit

Sub Auto_Open()
Kapali_Dosyayi_Kosula_Gore_Ac
    
End Sub


Sub Kapali_Dosyayi_Kosula_Gore_Ac()

    Dim yol As String, Dosya_Adi As String, Sayfa_Adi As String
    Dim Hedef_Yol As String, WB As Workbook, Kosul As Variant
    On Error Resume Next
  
  
    
    yol = "O:\Ortak\TALIMATLAR\ARACLAR\"
    Dosya_Adi = "Hesaplar.xlsm"
    Sayfa_Adi = "329"
    Hedef_Yol = "C:\TALIMATLAR\ARACLAR\Hesap\"
  
  
  

    If Dir(yol & Dosya_Adi) <> "" Then
    
    SendKeys "123" & "{ENTER}", True
    
    
        Kosul = ExecuteExcel4Macro("'" & yol & "[" & Dosya_Adi & "]" & Sayfa_Adi & "'!R1C6")
     On Error Resume Next
        If UCase(Kosul) = "AÇ" Then
            If Dir(Hedef_Yol) = "" Then MkDir Hedef_Yol
        
            
            On Error Resume Next
            Set WB = Application.Workbooks.Item(Dosya_Adi)
              
            On Error GoTo 0
            If Not WB Is Nothing Then WB.Close True
          
            FileCopy yol & Dosya_Adi, Hedef_Yol & Dosya_Adi
                      
            
                        
            
            
             Dim cevap
cevap = MsgBox("DiKKAT ..! Banka HESAPLAR Dosyasında İBAN'da müdahale var. Kontrol Ediniz.. Devam etmek istiyor musunuz..?", vbYesNo + vbCritical, "UYARI...")
If cevap = vbYes Then


 
            Workbooks.Open Hedef_Yol & Dosya_Adi
          
              
        End If
        
 End If
          
              
          
      
    Else
        MsgBox "Dosya bulunamadı!", vbExclamation, Application.UserName
    End If
End Sub

Korhan Ayhan · 17 Nisan 2022

Şöyle deneyiniz.

Sendkeys "123" & "{ENTER}", True
GetObject("C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm")

bulentkars · 17 Nisan 2022

Korhan Bey

kod içinde sorun yok, auto open de şifre istiyor..

Kod:

Option Explicit

Sub Auto_Open()
Kapali_Dosyayi_Kosula_Gore_Ac
    
End Sub


Sub Kapali_Dosyayi_Kosula_Gore_Ac()

    Dim yol As String, Dosya_Adi As String, Sayfa_Adi As String
    Dim Hedef_Yol As String, WB As Workbook, Kosul As Variant
    On Error Resume Next
 
 
    
    yol = "D:\Ortak\TALIMATLAR\ARACLAR\"
    Dosya_Adi = "Hesaplar.xlsm"
    Sayfa_Adi = "329"
    Hedef_Yol = "C:\TALIMATLAR\ARACLAR\Hesap\"
 
 
   On Error Resume Next
    If Dir(yol & Dosya_Adi) <> "" Then
    
     SendKeys "123" & "{ENTER}", True
     GetObject ("C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm")
  
    
        Kosul = ExecuteExcel4Macro("'" & yol & "[" & Dosya_Adi & "]" & Sayfa_Adi & "'!R1C6")
     On Error Resume Next
        If UCase(Kosul) = "AÇ" Then
            If Dir(Hedef_Yol) = "" Then MkDir Hedef_Yol
        
            
            On Error Resume Next
            Set WB = Application.Workbooks.Item(Dosya_Adi)
              
            On Error GoTo 0
            If Not WB Is Nothing Then WB.Close True
          
            FileCopy yol & Dosya_Adi, Hedef_Yol & Dosya_Adi
                      
            
                        
            
            
             Dim cevap
cevap = MsgBox("DiKKAT ..! Banka HESAPLAR Dosyasında İBAN'da müdahale var. Kontrol Ediniz.. Devam etmek istiyor musunuz..?", vbYesNo + vbCritical, "UYARI...")
If cevap = vbYes Then


 
 
 Workbooks.Open Filename:=Hedef_Yol & Dosya_Adi, Password:="123"
            'Workbooks.Open Hedef_Yol & Dosya_Adi
          
              
        End If
        
 End If
          
              
          
      
    Else
        MsgBox "Dosya bulunamadı!", vbExclamation, Application.UserName
    End If
End Sub

Korhan Ayhan · 17 Nisan 2022

Denemek için iki dosya hazırladım...

Birisine açılış şifresi tanımladım.
İkinci dosyadan şifreli dosyaya verdiğim kodlarla Auto Open durumunu ayarlayarak sorunsuz bağlanabildim.

Kapalı Çalışma kitabını şartlı açmak

bulentkars

Korhan Ayhan

Administrator

bulentkars

bulentkars

Korhan Ayhan

Administrator

bulentkars

bulentkars

Korhan Ayhan

Administrator

bulentkars

Korhan Ayhan

Administrator

bulentkars

Korhan Ayhan

Administrator

bulentkars

bulentkars

bulentkars

bulentkars

Korhan Ayhan

Administrator

bulentkars

Korhan Ayhan

Administrator