Kapalı Dosyalardan Veri Aktarımı

[mukoli]

Merhabalar Günlük şubelerimden gelen mailler vardır örnek dosya ekledim aktuel ve aydın diye bu şekilde gelen dosyaları toplam kasa dosyasındaki karşılıklara getirmesi. Aktuel dosyası toplam kasa dosyasındaki aktuelin karşısına gibi teşekkürler şimdiden yardımlarınıza

 

[mukoli]

Merhaba yardımcı olan varmıdır acaba teşekkür ederim.

 

[mukoli]

Sub Aç()
ad = ActiveSheet.name
For i = 2 To 28
shr = Range("A" & i)
On Error Resume Next
Workbooks.Open Filename:=ThisWorkbook.Path & "/" & shr & " Kasa Defteri.xlsm"
ad2 = Sheets("Sayfa1").Range("A8")
ad = Replace(ad, ".", "/")
If ad = CStr(ad2) Then

Range("B" & i) = Sheets("Sayfa1").Range("D8")
Range("C" & i) = Sheets("Sayfa1").Range("D9")
Range("D" & i) = Sheets("Sayfa1").Range("D10")
Range("E" & i) = Sheets("Sayfa1").Range("D11")
Range("F" & i) = Sheets("Sayfa1").Range("D12")
dgr = Sheets("Sayfa1").Range("D13")
Range("J" & i) = Sheets("Sayfa1").Range("K8")
Range("H" & i) = WorksheetFunction.Sum(Sheets("Sayfa1").Range("K9:K12"))
Range("I" & i) = WorksheetFunction.Sum(Sheets("Sayfa1").Range("K13:K15"))
End If
Workbooks(shr & " Kasa Defteri.xlsm").Close SaveChanges:=False
Next i


End Sub

Böyle kod var ama herhangi bir aktarım yapmıyor

 

[tahsinanarat]

Sn. @mukoli, şubelerden gelen dosyalarınız aynı formatta ise;

aşağıdaki kodları kendinize göre uyarlayabilirsiniz; (buna benzer konu ile ilgili bu siteden değerli bir hocamdan yardım almıştım)

Sub Tek_Excel()
    Application.ScreenUpdating = False
'    On Error Resume Next
    Dosya_Yolu = "C:\Users\tomson\Desktop\Yeni klasör\" 'şubelerden gelen dosya yolu
    Set S3 = Sheets("Toplam")
    S3.Select
    [A2:Z65536].ClearContents
     Sat = 2
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    For Each Dosya In Klasör
    If InStr(Dosya.name, ".xlsm") > 0 Then
    If Dosya.name <> "Toplam_Kasa.xlsm" Then
    Workbooks.Open Filename:=Dosya, UpdateLinks:=0
    Sheets("Sayfa1").Select
    S3.Cells(Sat, 1) = Dosya.name
    S3.Cells(Sat, 2) = [D8]
    S3.Cells(Sat, 3) = [D9]
    S3.Cells(Sat, 4) = [D10]
    S3.Cells(Sat, 5) = [D11]
    S3.Cells(Sat, 6) = [D12]
    S3.Cells(Sat, 7) = [K8]
    S3.Cells(Sat, 8) = [K9]
    S3.Cells(Sat, 9) = [K10]
    S3.Cells(Sat, 10) = [K11]
    S3.Cells(Sat, 11) = [K12]
    S3.Cells(Sat, 12) = [K13]
    S3.Cells(Sat, 13) = [K14]
    S3.Cells(Sat, 14) = [K15]
    S3.Cells(Sat, 15) = [K16]
    ActiveWorkbook.Close True
    Sat = Sat + 1
    End If
    End If
    Next
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mukoli]

Teşekkürler hocam deniyorum

 

[mukoli]

Malesef hocam siizn kod istediğimi karşılamadı çok teşekkür ederim zahmet verdim

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Import_Data()
    Dim K1 As Workbook, S1 As Worksheet, K2 As Workbook, S2 As Worksheet
    Dim File_Path As String, My_File As String, XL_App As Object, My_Date As String
    Dim Find_Store As Range, Store_Name As String, Process_Time As Double
    
    Process_Time = Timer
    
    Set K1 = ThisWorkbook
    Set XL_App = VBA.CreateObject("Excel.Application")
    XL_App.Visible = False
    
    File_Path = K1.Path & "\"
    
    My_File = Dir(File_Path & "*.xls*")
    
    While My_File <> ""
        If My_File <> K1.name Then
            Set K2 = XL_App.Workbooks.Open(File_Path & My_File)
            Set S2 = K2.Sheets(1)
            My_Date = Replace(Format(S2.Range("A8").Value, "dd.mm.yyyy"), "/", ".")
            Set S1 = K1.Sheets(CStr(My_Date))
            Store_Name = VBA.Split(My_File, " ")(0)
            Set Find_Store = S1.Range("A:A").Find(Store_Name, , , xlWhole)
            If Not Find_Store Is Nothing Then
                S1.Cells(Find_Store.Row, 2).Value = IIf(S2.Range("D8").Value = Empty, 0, S2.Range("D8").Value)
                S1.Cells(Find_Store.Row, 3).Value = IIf(S2.Range("D9").Value = Empty, 0, S2.Range("D9").Value)
                S1.Cells(Find_Store.Row, 4).Value = IIf(S2.Range("D10").Value = Empty, 0, S2.Range("D10").Value)
                S1.Cells(Find_Store.Row, 5).Value = IIf(S2.Range("D11").Value = Empty, 0, S2.Range("D11").Value)
                S1.Cells(Find_Store.Row, 6).Value = IIf(S2.Range("D12").Value = Empty, 0, S2.Range("D12").Value)
                S1.Cells(Find_Store.Row, 8).Value = WorksheetFunction.Sum(S2.Range("K9:K12"))
                S1.Cells(Find_Store.Row, 9).Value = WorksheetFunction.Sum(S2.Range("K13:K15"))
                S1.Cells(Find_Store.Row, 10).Value = IIf(S2.Range("K8").Value = Empty, 0, S2.Range("K8").Value)
            End If
            K2.Close 0
        End If
        My_File = Dir
    Wend
    
    XL_App.Quit
    
    Set XL_App = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing
    
    MsgBox "Depo verileri güncellenmiştir." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub

 

[maliex]

Ado ile yapan da çıkardie takipdeyim saygılar

 

[tahsinanarat]

Sn. @Korhan Ayhan Hocam;

            Set S1 = K1.Sheets(CStr(My_Date))

satırında Run Time Error "9" hatası veriyor

 

[Korhan Ayhan]

Sisteminizdeki tarih biçimiyle alakalıdır.

14/10/2021 şeklindeyse hata verecektir.

Hata veren satırda replace komutu ile bölme işaretlerini nokta ile değiştirip çözüme gidebilirsiniz.

 

[tahsinanarat]

Hocam yukarıda verilen örnek dosyalarda denemiştim, tarihler arasında nokta var.

 

[mukoli]

Merhaba benim dosyamda çalıştı ana dosyadaki sayfa ismi ile veri alıcagımız a8 deki tarih aynı olması lazım korhan hocam cok teşekkürler

 

[Korhan Ayhan]

Pardon @tahsinanarat bey üyemiz başka bir başlık daha açmıştı. Ben o başlıktaki dosyalara göre kodu tasarlamıştım. Dosyaların aynı olduğunu düşünerek size bu yönde cevap vermiştim. Siz şimdi hata veriyor deyince dosyaları tekrar indirdiğimde "Toplam Kasa.xlsm" dosyasının farklı olduğunu gördüm. Önerdiğim kod bu dosya için çalışmayacaktır.

Birazdan güncel halini paylaşırım.

 

[mukoli]

Korhan hocam merhaba klasörde aynı şablonda exceller var tek dosyayı işleme alıyor diğerlerinide alması için nasıl yapabiliriz.. Dosyaları ekledim hocam toplam kasalarda makro çalıştırınca diğer şubelerin isimlerine bakarak ana dosyada aktuelse karşısına getircek sonra pendik bayramyeri vs. bunun gibi 30 tane var dosya teşekkür ederim yardımınıza

 

[Korhan Ayhan]

Aktarım işleminin sağlıklı olabilmesi için dosya isimlerindeki ilk kelimenin A sütunundaki isimler ile aynı olmasını sağlamanız gerekir.

 

[mukoli]

Aktarım işleminin sağlıklı olabilmesi için dosya isimlerindeki ilk kelimenin A sütunundaki isimler ile aynı olmasını sağlamanız gerekir.

Özür dilerim hocam benim hatammış sorunsuz çalışmaktadır ellerinize sağlık teşekkür ederim tekrardan

 

[Korhan Ayhan]

Tarih biçimiyle ilgili sorun olmaması adına koda küçük bir ekleme yaptım. #7 nolu mesajdaki son halini kullanırsınız.

 

[mukoli]

Korhan hocam sizden birşey daha istesem ayıp olurmu gerçekten hakkınız ödenmez sizin bilginizle binlerce insan yararlanıyor. Aktaracagımız sayfalardaki gider alanındaki açıklama ve yanındaki tutarları ayrı sayfaya getirebilirmiyiz sadece oraları açıklamalarda olucak yanında yine aynı şekilde olucak dosya biçimi sadece dediğim gibi gider alanındaki açıklama ve tutarlar ayrı sayfaya gelicek örnek dosya gönderebilirim isterseniz

 

[Korhan Ayhan]

Siz dosyalarınızı paylaşın. Müsait olduğumda cevaplamaya çalışırım.

 

[mukoli]

Merhaba hocam dosyayı ekledim normal sayfaya verileri getirecek . Diğer sayfaya giderleri getirecek aynı tarihte teşekkürler