• DİKKAT

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

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

bulentkars

bulentkars

Altın Üye
Katılım
5 Ağustos 2005
Mesajlar
674
Excel Vers. ve Dili
2003 TR
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.
 
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
 
Merhaba,

Then MkDir Hedef_Yol

then den sonraki alanda hata veriyor
 
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.
 
#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.
 
Elinize emeğinize sağlık. Tam istediğim gibi olmuş çok teşekkür ederim.
 
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.
 
#2 nolu mesajimda ki koda küçük bir ekleme yaptım. Ben olumlu sonuç aldım umarım sizde de çalışır.
 
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:
 
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.
 
Korhan Bey,

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

Workbooks.Open Filename:="C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm", Password:="123"
 
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:
 
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:
 
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:
 
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.
Genişletmek için tıkla ...

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
 
Şöyle deneyiniz.

Sendkeys "123" & "{ENTER}", True
GetObject("C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm")
 
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
 
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst