Pasif olan excel dosyasını kapatma

[metince54]

merhaba arkadaşlar.günlük olarak farklı isimlerdeki excel dosyalarımı sabit adlı bir excel kullanarak atıyorum. değişken isimli excel dosyamdaki 2 ayrı makro ile. kullandığım makro da kişisel kitap macrosu. istediğim şey değişken isimli excel dosyamdaki makroları birleştirip 1 tıklama ile 2 sekmedeki dosyam sabit kullanıcısı excele veriyi taşıdığı zaman değişken dosya excel dosyam kapansın ama kişisel kitap macrosu bulunanan dosya ve sabit isimli dosya kalsın. kullandığım kodlarıda aşağıda paylaşıyorum. şimdiden emeği geçen herkese teşekkür ediyorum.

Option Explicit
Sub A_Günlük()
' A_Günlük Makro
'

Application.ScreenUpdating = False
Sheets("Verilen Malzeme").Select
Range("B3").Select
Range("B3", Range("m3").End(xlToRight).End(xlDown)).Select
Selection.Copy
Windows("1.xlsx").Activate
Sheets("Verilen Malzeme").Select
Range("C2").Select
Application.Goto Reference:="R50000C3"
Selection.End(xlUp).Select
ActiveCell.Offset(2, -1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, 1).Range("A1").Select
Application.Goto Reference:="R50000C3"
Selection.End(xlUp).Select
ActiveCell.Offset(2, 0).Range("A1").Select

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

---------------------------------------------------


Sub fiş()
'
' fiş Makro
'

'
Sheets("DEPO ÇIKIŞLAR").Select
Range("B3:I3").Select
Selection.ClearContents
Range("D7").Select
Selection.CurrentRegion.Select
ActiveWindow.SmallScroll Down:=-6
Selection.Copy
Windows("1.xlsx").Activate
Sheets("DEPO ÇIKIŞLAR").Select
Range("B2").Select
Application.Goto Reference:="R5000C2"
Selection.End(xlUp).Select
ActiveCell.Offset(2, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Select
Application.CutCopyMode = False

End Sub

 

[Korhan Ayhan]

Örnek dosyalarınızı ekleyip yapmak istediğiniz işlemi açıklarsanız farklı çözüm yolları önerilebilir. Böyle sadece kodu eklemek bazen yol gösterici olmayabiliyor.

 

[metince54]

kusra bakmayın iş yoğunluğundan dolayı örnek dosyaları yükleyemedim. 1 xls dosyasında açıklamalar olacak. gereksiz sekmeleri gizledim. şimdiden teşekkür ederim.

 

[Korhan Ayhan]

"1.xlsx" dosyasında verleri aktar dediğinizde her seferinde ilgili iki sayfadaki eski veriler temizlenip yeni veriler mi aktarılacak?

 

[Korhan Ayhan]

Merhaba,

İlk olarak klasörünüzün içindeki 1.xlsx dosyasını siliniz. Ekteki dosyayı klasör içine alınız.

Dosyayı açıp butona tıklayınız.

Kod sayfalardaki eski verileri temizleyip klasör içindeki dosyaların tümünden ilgili sayfalardaki verileri aktarıp işlemi tamamlayacaktır.

Veri alınacak dosyalarınızı açıp ilk sayfalarda CTRL+END yaptığımda 1 milyonlu satırlara gidiyor. Gereksiz satır kullanımından sakının. İhtiyacınız kadar satırı kullanmaya gayret gösterin.

Umarım sizde hata vermeden çalışır.

 

[metince54]

Teşekkür ederim öncelikle emek verdiniz zaman ayırdığınız için. uygulamayı çalıştırdım lakin bir yerden sonra hata verdi. birde eğer yapabilirsek günleri sıralı alabilirsek sevinirim düzen açısından iş takibi konusunda. Ayrıca gereksiz hücre kullanımı için de Kes yapıştır yaparak yeni sekmeye taşıma yapacağım. bilgilendirme için ayrıca teşekkür ediyorum.

 

[metince54]

yükleme hata verdiği yere kadar aldığı yere kadar olan dosyayı da yükleme yapayım belki işinizi kolaylaştırır.

 

[Korhan Ayhan]

Hata veren satırda hangi dosya olduğunu bilmek gerekiyor. Bu sebeple Dosya yazan bölüm üzerine mouse ile gelip biraz beklediğinizde size dosya adını verecektir. Bu dosyayı paylaşırsanız kontrol edebilirim.

 

[metince54]

hata veren örnek dosyalardan paylaştım. ilginiz için çok teşekkür ederim.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Verileri_Aktar()
    Dim Zaman As Double, Baglanti As Object, Kayit_Seti As Object, Yol As String
    Dim Dosya As String, S1 As Worksheet, S2 As Worksheet, Satir As Long, Sorgu As String
    
    Zaman = Timer
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Verilen Malzeme")
    Set S2 = Sheets("DEPO ÇIKIŞLAR")
    
    S1.Range("A2:O" & S1.Rows.Count).Clear
    S2.Range("A2:J" & S2.Rows.Count).Clear
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya = Dir(Yol & "*.xls")
    
    While Dosya <> ""
        If Yol & Dosya <> ThisWorkbook.FullName Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Yol & Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
            
            Kayit_Seti.Open "Select Max(F1) From [Verilen Malzeme$]", Baglanti, 1, 1
            If Not IsNumeric(Kayit_Seti.Fields(0)) Then
                Satir = 65536
            Else
                Satir = Kayit_Seti.Fields(0) + 3
            End If
            Kayit_Seti.Close
            
            Sorgu = "Select * From [Verilen Malzeme$A3:O" & Satir & "]"
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1
            If Kayit_Seti.RecordCount > 0 Then S1.Cells(S1.Rows.Count, 1).End(3)(2, 1).CopyFromRecordset Kayit_Seti
            Kayit_Seti.Close
            S1.Range("L2:L" & S1.Rows.Count).NumberFormat = "dd.mm.yyyy"
            S1.Columns.AutoFit
            
            Sorgu = "Select * From [DEPO ÇIKIŞLAR$B3:J]"
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1
            If Kayit_Seti.RecordCount > 0 Then S2.Cells(S2.Rows.Count, 1).End(3)(2, 1).CopyFromRecordset Kayit_Seti
            S2.Range("I2:I" & S1.Rows.Count).NumberFormat = "dd.mm.yyyy"
            S2.Columns.AutoFit
            
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
        Dosya = Dir
    Wend
    
    S1.Range("A2:O" & S1.Rows.Count).Sort S1.Range("L2"), xlAscending, S1.Range("B2"), , xlAscending
    S2.Range("A2:I" & S2.Rows.Count).Sort S2.Range("I2"), xlAscending, S2.Range("F2"), , xlAscending
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[metince54]

teşekkür edeceğim zaman ayırdığınız için ama nedense bu sefer veri almadı hiç nedense sizinde kıymetli zamanınızı çalıyorum son bir revize edebilir misiniz kodları. şimdiden çok teşekkür ederim

 

[Korhan Ayhan]

#9 nolu mesajınızda paylaştığınız klasörde denedim ve olumlu sonuç aldım.

 

[metince54]

kodları module yapıştırmıyor muyuz. modulun içini sildim hatta kaldırdım yeni modul actımda denedim bu sefer hiç almadı veri içine nedense

 

[Korhan Ayhan]

Şimdi tekrar denedim. Veriler bende geliyor.

 

[Korhan Ayhan]

Siz birde ekteki dosyayı deneyin.

Bu dosyada farklı bir kodlama kullandım.

 

[metince54]

çok teşekkürüm derim emeğinize sağlık hızlı ve doğru bir şekilde işlem yapıyor. sadece birinde hata verdi onuda ben inceleme yapacağım diğerlerini alıp onu almıyorsa benlik bir durumdur sanırım. tekrardan ilginiz alakanız için teşekkür ederim .