ikinci kitabı kapatma hk.

acar6783 · 26 Ocak 2019

Merhabalar,
Hali hazırda var olan bir excel dosyasının yanına bir excel dosyası açtığımda son açtığım dosyayı nasıl kapatabilirim?
not: yeni dosya ile eski dosya birbirinden bağımsız açılıyor.

Yani aşağıdaki kod ile ben o diğer kitabı göremiyorum.

Kod:

Sub kapat()
Dim wb As Workbook
For Each wb In Application.Workbooks
MsgBox wb.Name
If wb.Name <> ThisWorkbook.Name Then
wb.Close SaveChanges:=False
End If
Next wb
End Sub

Haluk · 26 Ocak 2019

-Kapatmaya çalıştığınız dosyanın adının Book1.xlsx olduğu,

-Kodun çalıştırıldığı dosya ile aynı klasörde olduğu,

-Kodun yazıldığı Excel dosyasının içinde bulunduğu oturumdan farklı bir oturumda önceden açılmış olduğu ve halen açık olduğu

hususlarını varsayarak, aşağıdaki kodu deneyin....

Kod:

Sub Test()
    'Haluk 26/01/2019
    'E-Posta: sa4truss@gmail.com
    Dim xlApp As Excel.Application, strFile As String, WB As Workbook
    
    strFile = ThisWorkbook.Path & Application.PathSeparator & "Book1.xlsx"
    Set xlApp = GetObject(strFile).Application
    
    For Each WB In xlApp.Workbooks
        MsgBox WB.Name
        If WB.FullName = strFile Then WB.Close SaveChanges:=False
    Next WB
    
    xlApp.Quit
    Set xlApp = Nothing
End Sub

.

acar6783 · 26 Ocak 2019

Haluk' Alıntı:
-Kodun yazıldığı Excel dosyasının içinde bulunduğu oturumdan farklı bir oturumda önceden açılmış olduğu ve halen açık olduğu

Açık kalan dosyalardan veri aldığım için sonradan açılıp kapanması gerekiyor.

Kodlarım aşağıdaki gibi. Aslında ilk Open olayından sonra kapanıyor fakat Con.open olayında salt okunur olarak tekrar açıyor. O açık kalıyor. Normalde con.open olayında arka planda açılır fakat ben Easyfix programı kurduktan sonra kapanmamaya başladı. Hatta çözüme ulaşamayınca exceli yeniden kurdum.
Şimdi easyfixi tekrar kurup deneme yaptım fakat "test" kodları çalışmadı açık kaldı yine.

Kod:

Sub DETAYCEK()
   
    Dim Con As Object, Rs As Object, Sorgu As String
 
    Set Con = CreateObject("Adodb.Connection")
   
    Set Rs = CreateObject("Adodb.RecordSet")
    scrfalse
babs = Cells(ActiveCell.Row, "A")
If babs = "BA" Then babs = "A"
If babs = "BS" Then babs = "B"

vergino = Replace(Cells(ActiveCell.Row, "D") & Cells(ActiveCell.Row, "E"), " ", "")



  Set ERP = Sheets("DETAY")
     ERP.Cells.ClearContents
   'On Error Resume Next
  dosya_yolu = Left(ThisWorkbook.Path, InStr(ThisWorkbook.Path, "\Kullanıcılar")) & "BABSDETAY.xls"
    Workbooks.Open (dosya_yolu)
        Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        dosya_yolu & ";extended properties=""excel 12.0;hdr=NO"""
        Sorgu = "Select F10,F2,F8,F7,F12,F13,F14 from [Detay$] WHERE F1 = '" & babs & "' AND F3 = '" & vergino & "' ORDER BY F10"
        Rs.Open Sorgu, Con, 1, 1
say = Rs.RecordCount
          ERP.Range("A2").CopyFromRecordset Rs
     Workbooks("BABSDETAY.xls").Close False
     Rs.Close: Con.Close

   
     dosya_yolu = Left(ThisWorkbook.Path, InStr(ThisWorkbook.Path, "\Kullanıcılar")) & "BABSDETAY-MAĞAZA.xls"
    Workbooks.Open (dosya_yolu)
        Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        dosya_yolu & ";extended properties=""excel 12.0;hdr=NO"""
        Sorgu = "Select F6,F5,F2,F3&F4,F7,F8,F9 from [Detay$] WHERE  F1 = '" & vergino & "' ORDER BY F6"
        Rs.Open Sorgu, Con, 1, 1

          ERP.Range("A" & ERP.Cells(Rows.Count, 1).End(3).Row + 1).CopyFromRecordset Rs
  Workbooks("BABSDETAY-MAĞAZA.xls").Close False
     Rs.Close: Con.Close
     
    Set Con = Nothing: Set Rs = Nothing: Sorgu = ""

UserForm3.Show
scrtrue
End Sub

acar6783 · 26 Ocak 2019

Haluk' Alıntı:
-Kodun yazıldığı Excel dosyasının içinde bulunduğu oturumdan farklı bir oturumda önceden açılmış olduğu ve halen açık olduğu

Önce açılmış bir dosyada denedim çalışıyor. Ama dediğim gibi sonra açılmış olanı kapatması gerekiyor. Ya da farklı bir alternatif

Haluk · 26 Ocak 2019

acar6783' Alıntı:
Ya da farklı bir alternatif

Aşağıdaki revize kodu deneyin..... bakalım işinize yarayacak mı?

Kod:

Sub Test2()
    'Haluk 26/01/2019
    'E-Posta: sa4truss@gmail.com
    Dim objWord As Object, xlApp As Excel.Application
    Dim strFileName As String, strFile As String, WB As Workbook
    
    strFileName = "Book1.xlsx"
    strFile = ThisWorkbook.Path & Application.PathSeparator & strFileName
    Set objWord = CreateObject("Word.Application")
    If objWord.Tasks.Exists(strFileName) Then
        MsgBox strFileName & " dosyası açık"
        objWord.Tasks(strFileName).Close
        Set xlApp = GetObject(strFile).Application
        xlApp.Workbooks(strFileName).Close SaveChanges:=False
        MsgBox strFileName & " dosyası kapatıldı"
    Else
        MsgBox "Açık dosyaların arasında " & strFileName & " bulunamadı"
    End If
    objWord.Quit
    Set xlApp = Nothing
    Set objWord = Nothing
End Sub

acar6783 · 26 Ocak 2019

Haluk bey

MsgBox "Açık dosyaların arasında " & strFileName & " bulunamadı"

Maalesef olmadı yine.Dosyalar açık olmasına rağmen kapanmadı.

acar6783 · 26 Ocak 2019

Haluk' Alıntı:
Aşağıdaki revize kodu deneyin..... bakalım işinize yarayacak mı?

3 nolu mesajımdaki kodları revize edebilirmiyiz? Bu işleme gerek kalmaması adına

Haluk · 26 Ocak 2019

Benim yaptığım tüm denemelerde hiçbir sorunla karşılaşmadan söz konusu diğer dosya kapanıyor..... sizde neden olmuyor bilemiyorum.

Kolay gelsin,

.

acar6783 · 26 Ocak 2019

Haluk' Alıntı:
Benim yaptığım tüm denemelerde hiçbir sorunla karşılaşmadan söz konusu diğer dosya kapanıyor..... sizde neden olmuyor bilemiyorum.

Kolay gelsin,

.

Dediğim gibi Excel Easyfix kurmuştum . Her dosya farklı bir uygulamada açılıyor.Birbirinden bağımsız çalışıyor.

Workbooks.Open (dosya_yolu)
Burada açılan dosya sonraki kod ile kapanıyor .

Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
dosya_yolu & ";extended properties=""excel 12.0;hdr=NO"""
Fakat buradan açılan aynı dosya salt okunur uyarısı ile açık kalıyor.

Haluk · 26 Ocak 2019

acar6783' Alıntı:
Dediğim gibi Excel Easyfix kurmuştum . Her dosya farklı bir uygulamada açılıyor.Birbirinden bağımsız çalışıyor.

Workbooks.Open (dosya_yolu)
Burada açılan dosya sonraki kod ile kapanıyor .

Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
dosya_yolu & ";extended properties=""excel 12.0;hdr=NO"""
Fakat buradan açılan aynı dosya salt okunur uyarısı ile açık kalıyor.

Bahsettiğiniz EasyFix nedir bilemiyorum, o konuda yorum yapamayacağım.

Ancak bana öyle geliyor ki; ADO bağlantısında "Extended Properties" kısmında IMEX=1 ifadesi olmadığı için, ADO tarafından dosya salt okunur olarak açılıyor.

Kısaca.... aşağıdaki şekliyle deneyin;

Kod:

 Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        dosya_yolu & ";extended properties=""excel 12.0;hdr=NO;IMEX=1"""

.

acar6783 · 26 Ocak 2019

Maalesef

Haluk' Alıntı:
Bahsettiğiniz EasyFix nedir bilemiyorum, o kunuda yorum yapamayacağım.

Exceli her açtığımda farklı uygulamada birbirinden bağımsız açması için kurmuştum. Başta herşey güzel gidiyordu fakat bu dosyadan önce bir dosya açıksa kodlarda bulunan con.open ile açılan kitaplar açık kalıyor.

Haluk · 26 Ocak 2019

Siz 10 mesajda verdiğim düzeltmeyi kendi kodlarınızda yaptınız mı ?

Kodlarınızda 2 yerde geçiyor bu durum...

.

acar6783 · 26 Ocak 2019

Kod:

Sub DETAYCEK()
    
    Dim Con As Object, Rs As Object, Sorgu As String
  
    Set Con = CreateObject("Adodb.Connection")
    
    Set Rs = CreateObject("Adodb.RecordSet")
    scrfalse
babs = Cells(ActiveCell.Row, "A")
If babs = "BA" Then babs = "A"
If babs = "BS" Then babs = "B"

vergino = Replace(Cells(ActiveCell.Row, "D") & Cells(ActiveCell.Row, "E"), " ", "")



  Set ERP = Sheets("DETAY")
     ERP.Cells.ClearContents
   'On Error Resume Next
  dosya_yolu = Left(ThisWorkbook.Path, InStr(ThisWorkbook.Path, "\Kullanıcılar")) & "BABSDETAY.xls"
  Set KAPA = Workbooks.Open(dosya_yolu)
        Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        dosya_yolu & ";extended properties=""excel 12.0;hdr=NO;IMEX=1"""
        Sorgu = "Select F10,F2,F8,F7,F12,F13,F14 from [Detay$] WHERE F1 = '" & babs & "' AND F3 = '" & vergino & "' ORDER BY F10"
        Rs.Open Sorgu, Con, 1, 1
 say = Rs.RecordCount
          ERP.Range("A2").CopyFromRecordset Rs
 KAPA.Close False
     Rs.Close: Con.Close

    
     dosya_yolu = Left(ThisWorkbook.Path, InStr(ThisWorkbook.Path, "\Kullanıcılar")) & "BABSDETAY-MAĞAZA.xls"
  Set KAPA2 = Workbooks.Open(dosya_yolu)
        Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        dosya_yolu & ";extended properties=""excel 12.0;hdr=NO;IMEX=1"""
        Sorgu = "Select F6,F5,F2,F3&F4,F7,F8,F9 from [Detay$] WHERE  F1 = '" & vergino & "' ORDER BY F6"
        Rs.Open Sorgu, Con, 1, 1
 
          ERP.Range("A" & ERP.Cells(Rows.Count, 1).End(3).Row + 1).CopyFromRecordset Rs
 KAPA2.Close False
     Rs.Close: Con.Close
      
    Set Con = Nothing: Set Rs = Nothing: Sorgu = ""

 UserForm3.Show
 scrtrue
End Sub

Evet yaptım. Hatta workbook.open kodlarında değişiklik yaptım ama yine olmadı
Sonrasında Test2 kodlarını çalıştırdım ama açık olan kitapları bulamadı.

Haluk · 26 Ocak 2019

Sizin koddaki dosya_yolu değişkenini anlamadım ...

Koddaki BABSDETAY ve BABSDETAY-MAĞAZA dosyaları kodun olduğu dosya ile aynı yerde mi?

.

acar6783 · 26 Ocak 2019

Haluk' Alıntı:
Sizin koddaki dosya_yolu değişkenini anlamadım ...

Koddaki BABSDETAY ve BABSDETAY-MAĞAZA dosyaları kodun olduğu dosya ile aynı yerde mi?

.

Aslında dosyanın olduğu klasörün iki üst klasöründe.

Haluk · 26 Ocak 2019

Aslında o dosyaları açıp, kapatmanın da bir manası yok bence....

Aşağıdakini dener misiniz?

Kod:

Sub DETAYCEK()
    Dim Con As Object, Rs As Object, Sorgu As String
    
    dosya_yolu = Left(ThisWorkbook.Path, InStr(ThisWorkbook.Path, "\Kullanıcılar")) & "BABSDETAY.xls"
    
    If Dir(dosya_yolu) = Empty Then
        MsgBox dosya_yolu & " bulunamadı!"
        Exit Sub
    End If
    
    Set Con = CreateObject("Adodb.Connection")
    Set Rs = CreateObject("Adodb.RecordSet")

    babs = Cells(ActiveCell.Row, "A")
    If babs = "BA" Then babs = "A"
    If babs = "BS" Then babs = "B"

    vergino = Replace(Cells(ActiveCell.Row, "D") & Cells(ActiveCell.Row, "E"), " ", "")

    Set ERP = Sheets("DETAY")
    ERP.Cells.ClearContents
    
    Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        dosya_yolu & ";extended properties=""excel 12.0;hdr=NO;IMEX=1"""
        Sorgu = "Select F10,F2,F8,F7,F12,F13,F14 from [Detay$] WHERE F1 = '" & _
                babs & "' AND F3 = '" & vergino & "' ORDER BY F10"
        Rs.Open Sorgu, Con, 1, 1
            ERP.Range("A2").CopyFromRecordset Rs
        Rs.Close
    Con.Close
    
    dosya_yolu = Left(ThisWorkbook.Path, InStr(ThisWorkbook.Path, "\Kullanıcılar")) & "BABSDETAY-MAĞAZA.xls"
    
    Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        dosya_yolu & ";extended properties=""excel 12.0;hdr=NO;IMEX=1"""
        Sorgu = "Select F6,F5,F2,F3&F4,F7,F8,F9 from [Detay$] WHERE  F1 = '" & vergino & "' ORDER BY F6"
        Rs.Open Sorgu, Con, 1, 1
            ERP.Range("A" & ERP.Cells(Rows.Count, 1).End(3).Row + 1).CopyFromRecordset Rs
        Rs.Close
    Con.Close
    
    Set Con = Nothing
    Set Rs = Nothing
    Sorgu = ""
    
    UserForm3.Show
End Sub

.

acar6783 · 26 Ocak 2019

Rs.Open Sorgu, Con, 1, 1
Satırında hataya düşüyor. Daha önce bu haliyle hata almıyordum. Workbook.open olayını yazmamın sebebi. Dosya açılmadan adonun boş veri getirmesiydi.
Normalde kodlar sıkıntısız çalışıyor.Ben dosyalar faklı uygulamalarda açılması için kurduğum program sonrası sıkıntı yaşamaya başladı.

acar6783 · 26 Ocak 2019

Evet tekrar verilerin çekileceği kitapları manuel olarak açtığımda ado kodları hata vermedi fakat açık olan kitapların üstüne bir de salt okunur olarak açtı.

Sizi de meşgul ettim kusura bakmayın. Çözüm olarak sanırım eski haline getireceğim officei. her kolaylığın bir zorluğu oluyor maalesef. Olsaydı güzel olacaktı.Birbirinden bağımsız çalışan dosyalarda çalışmak güzel olurdu. Biri mail gönderirken(1-2saat sürüyor) diğerinde farklı işler yapılabilirdi.

Haluk · 26 Ocak 2019

Dosyalarınızı görmediğim için emin değilim ama belki de ADO ile ilgili bilmediğimiz bir sıkıntı olabilir...

Bu nedenle, açık olan diğer dosyaları elle kapattıktan sonra bir de aşağıdaki gibi DAO kullanmayı deneyin...

Kod:

Sub DETAYCEK_DAO()
    Dim daoDBEngine As Object, DB As Object, Rs As Object, Sorgu As String
    
    dosya_yolu = Left(ThisWorkbook.Path, InStr(ThisWorkbook.Path, "\Kullanıcılar")) & "BABSDETAY.xls"
    If Dir(dosya_yolu) = Empty Then
        MsgBox dosya_yolu & " bulunamadı!"
        Exit Sub
    End If
    
    babs = Cells(ActiveCell.Row, "A")
    If babs = "BA" Then babs = "A"
    If babs = "BS" Then babs = "B"

    vergino = Replace(Cells(ActiveCell.Row, "D") & Cells(ActiveCell.Row, "E"), " ", "")

    Set ERP = Sheets("DETAY")
    ERP.Cells.ClearContents
    
    On Error Resume Next
        Set daoDBEngine = CreateObject("DAO.DBEngine")
        Set daoDBEngine = CreateObject("DAO.DBEngine.36")
        Set daoDBEngine = CreateObject("DAO.DBEngine.120")
    On Error GoTo 0
    
    Set DB = daoDBEngine.OpenDatabase(dosya_yolu, False, False, "Excel 8.0; HDR=No; IMEX=1;")
    
    Sorgu = "Select F10,F2,F8,F7,F12,F13,F14 from [Detay$] WHERE F1 = '" & _
            babs & "' AND F3 = '" & vergino & "' ORDER BY F10"
    Set Rs = DB.OpenRecordset(Sorgu)
    ERP.Range("A2").CopyFromRecordset Rs
    Rs.Close
    
    dosya_yolu = Left(ThisWorkbook.Path, InStr(ThisWorkbook.Path, "\Kullanıcılar")) & "BABSDETAY-MAĞAZA.xls"
    If Dir(dosya_yolu) = Empty Then
        MsgBox dosya_yolu & " bulunamadı!"
        Exit Sub
    End If
    
    Sorgu = "Select F6,F5,F2,F3&F4,F7,F8,F9 from [Detay$] WHERE  F1 = '" & vergino & "' ORDER BY F6"
    Set Rs = DB.OpenRecordset(Sorgu)
    ERP.Range("A" & ERP.Cells(Rows.Count, 1).End(3).Row + 1).CopyFromRecordset Rs
    Rs.Close
    Con.Close
    
    Set DB = Nothing
    Set Rs = Nothing
    Sorgu = ""
    
    UserForm3.Show
End Sub

.
.

acar6783 · 26 Ocak 2019

Set Rs = DB.OpenRecordset(Sorgu)
Bu bölümde hataya düşüyor.

Dosyaları manuel olarak açarsam yine adodaki gibi dosyayı yine açıyor fakat "con.close" da hataya düşüyor.

ikinci kitabı kapatma hk.

acar6783

Haluk

Özel Üye

acar6783

acar6783

Haluk

Özel Üye

acar6783

acar6783

Haluk

Özel Üye

acar6783

Haluk

Özel Üye

acar6783

Haluk

Özel Üye

acar6783

Haluk

Özel Üye

acar6783

Haluk

Özel Üye

acar6783

acar6783

Haluk

Özel Üye

acar6783