• DİKKAT

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

Başka Bir Dosyadan Veri Alma Alternatifi

I

ITOKER

Katılım
3 Eylül 2014
Mesajlar
34
Excel Vers. ve Dili
2010
Sub BANKAMODULU()



Dim KTP As Workbook, ASİ As Excel.Application
Dim A1S1 As Worksheet, A2S2 As Worksheet
Dim A1 As String, A2 As String, YOL As String
Dim HCR As Variant
Application.ScreenUpdating = False
Set ASİ = CreateObject("Excel.Application")
ASİ.Visible = False
YOL = "O:\Muhasebe\RAPOR PAKET DOSYASI\"
A1 = ActiveWorkbook.Name
Set A1S1 = Workbooks(A1).Sheets("banka hesap durum raporu")
A2 = "BANKAMODÜLÜ.xlsx"
HCR = ActiveCell.Address
Set KTP = ASİ.Workbooks.Open(YOL & A2)
Set A2S2 = KTP.Sheets("Sayfa1")
A2S2.Range("A1:K80").Copy
A1S1.Range("A1").PasteSpecial (xlPasteValues)
KTP.Save: ASİ.Quit
Range(HCR).Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "BANKA MODÜLÜ"

End Sub




Merhabalar;

Yukarıdaki kod ile başka bir alandaki bir dosyanın istediğim sayfasından veri alıyorum ancak,

veri aldığım dosyayı sistem üretiyor ve her ürettiği dosyaya farklı isim verdiği için her seferinde kodu revize etmek gerekiyor,

bu sorunu aşmak için, bu kod, hedef yolun içerisindeki en son güncellenen dosyanın istenilen sayfasında çalışacak şekilde revize edilebilir mi ?

Saygılarımla.
 
Aşağıdaki kodları inceleyin.
Kod çalıştığında dosya açma iletişim kutusu açılıyor siz istediğiniz dosyayı oradan seçebilirsiniz.

Kod: 
Sub BANKAMODULU()

        Dim KTP As Workbook, ASİ As Excel.Application
    Dim A1S1 As Worksheet, A2S2 As Worksheet
    Dim A1 As String, A2 As String, YOL As String
    Dim HCR As Variant
    Application.ScreenUpdating = False
    Set ASİ = CreateObject("Excel.Application")
    ASİ.Visible = False
    
    Dim DosyaAc As FileDialog
    Set DosyaAc = Application.FileDialog(msoFileDialogFilePicker)
    DosyaAc.Filters.Add "Excel", "*.xls; *.xlsm; *.xlsx"
    
    If DosyaAc.Show = True Then
        YOL = DosyaAc.SelectedItems(1)
    Else
        Exit Sub
    End If

    A1 = ActiveWorkbook.Name
    Set A1S1 = Workbooks(A1).Sheets("banka hesap durum raporu")
    HCR = ActiveCell.Address
    Set KTP = ASİ.Workbooks.Open(YOL)
    Set A2S2 = KTP.Sheets("Sayfa1")
    A2S2.Range("A1:K80").Copy
    A1S1.Range("A1").PasteSpecial (xlPasteValues)
    KTP.Save: ASİ.Quit
    Range(HCR).Select
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
    vbInformation, "BANKA MODÜLÜ"


End Sub
 
Öncelikle Teşekkür Ederim hocam,

Ancak burada benim istediğim şey bu süreçte tam otomasyonu sağlamak, çünki bu işin başka bacakları da var hedef klasörde çok fazla dosya olacak ve birçok noktadan veri alınacak ama bana bu klasörlerdeki dosyalardan her zaman en son klasöre atılan yani son güncellenen klasör lazım olacak hocam. ?
 
Hocam Teşekkürler,

ben aslında bir çırağım :)

benim kodum aşağıda bu koda sizin kodunuzla nasıl düzenleneceğini yapabileceğimi pek sanmıyorum :(


bu konuda yardımcı olmanız mümkün mü ?



Sub BANKAMODULU()



Dim KTP As Workbook, ASİ As Excel.Application
Dim A1S1 As Worksheet, A2S2 As Worksheet
Dim A1 As String, A2 As String, YOL As String
Dim HCR As Variant
Application.ScreenUpdating = False
Set ASİ = CreateObject("Excel.Application")
ASİ.Visible = False
YOL = "O:\Muhasebe\RAPOR PAKET DOSYASI\"
A1 = ActiveWorkbook.Name
Set A1S1 = Workbooks(A1).Sheets("banka hesap durum raporu")
A2 = "BANKAMODÜLÜ.xlsx"
HCR = ActiveCell.Address
Set KTP = ASİ.Workbooks.Open(YOL & A2)
Set A2S2 = KTP.Sheets("Sayfa1")
A2S2.Range("A1:K80").Copy
A1S1.Range("A1").PasteSpecial (xlPasteValues)
KTP.Save: ASİ.Quit
Range(HCR).Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "BANKA MODÜLÜ"

End Sub
 
"RAPOR PAKET DOSYASI" Klasöründe En son güncellenen dosyanın adını bularak işlem yapıyor. Deneyemedim, sorun çıkarsa örnek dosya ekleyin .
Kod: 
Sub BANKAMODULU()
 Dim KTP As Workbook, ASİ As Excel.Application
 Dim A1S1 As Worksheet, A2S2 As Worksheet
 Dim A1 As String, A2 As String, YOL As String
 Dim HCR As Variant
 YOL = "D:\Muhasebe\"
 A1 = ActiveWorkbook.Name
 Dim fs, f, f1, fc, s
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(YOL)
    Set fc = f.Files
    s = 0
    For Each f1 In fc
    If A1 <> f1.Name Then
       If s < CDbl(f1.DateLastModified) Then
         dosyaAdı = f1.Name
       Else
          dosyaAdı = dosyaAdı
          End If
           End If
          s = CDbl(f1.DateLastModified)
          
    Next
 Application.ScreenUpdating = False
 Set ASİ = CreateObject("Excel.Application")
 ASİ.Visible = False
 YOL = "D:\Muhasebe\"
 
 Set A1S1 = Workbooks(A1).Sheets("banka hesap durum raporu")
 A2 = dosyaAdı
 HCR = ActiveCell.Address
 Set KTP = ASİ.Workbooks.Open(YOL & A2)
 Set A2S2 = KTP.Sheets("Sayfa1")
 A2S2.Range("A1:K80").Copy
 A1S1.Range("A1").PasteSpecial (xlPasteValues)
 KTP.Save: ASİ.Quit
 Range(HCR).Select
 Application.ScreenUpdating = True
 MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
 vbInformation, "BANKA MODÜLÜ"
End Sub
 
Son düzenleme:
Hocam Maalesef yine bir yerde takılıyor,

örnek dosya ekte, yardımlarınız rica ediyorum.

Teşekkürler.
 

Ekli dosyalar

Dosyanızı tc.dosya gibi bir dosya paylaşım sitesine atıp linkini bildirirsen.
 
Belki şuna dikkat çekmem gerekebilir,

bu yenilenen bir aynı dosya değil üstat,

bu bahsedilen alana yeni dosyaların aktığı ve bu yeni dosyaların sonuncusundan veri almak istemekteyim.
 
Merhaba sayın ITOKER,

Sistem yeni bir excel dosyası mı üretiyor, olan dosyalardan birinin üzerine mi yazıyor.
Kullandığınız dosya yolunu da gönderebilir misiniz.
 
Selamlar;

Sisten sürekli yeni bir dosya üretiyor, benimde içerisinden veri almak istediğim dosyada bu üretilen dosyalardan sonuncusu olsun istiyorum.
 
Sub BANKAMODULU()
Dim KTP As Workbook, ASİ As Excel.Application
Dim A1S1 As Worksheet, A2S2 As Worksheet
Dim A1 As String, A2 As String, YOL As String
Dim HCR As Variant
YOL = "O:\Muhasebe\RAPOR PAKET DOSYASI\"
A1 = ActiveWorkbook.Name
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(YOL)
Set fc = f.Files
s = 0
For Each f1 In fc
If A1 <> f1.Name Then
If s < CDbl(f1.DateLastModified) Then
dosyaAdı = f1.Name
Else
dosyaAdı = dosyaAdı
End If
End If
s = CDbl(f1.DateLastModified)

Next
Application.ScreenUpdating = False
Set ASİ = CreateObject("Excel.Application")
ASİ.Visible = False
YOL = "O:\Muhasebe\RAPOR PAKET DOSYASI\"

Set A1S1 = Workbooks(A1).Sheets("banka hesap durum raporu")
A2 = dosyaAdı
HCR = ActiveCell.Address
Set KTP = ASİ.Workbooks.Open(YOL & A2)
Set A2S2 = KTP.Sheets("Sayfa1")
A2S2.Range("A1:K80").Copy
A1S1.Range("A1").PasteSpecial (xlPasteValues)
KTP.Save: ASİ.Quit
Range(HCR).Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "BANKA MODÜLÜ"
End Sub
 
Merhaba,

Deneyebilir misiniz.


Kod: 
Sub denemefs()

Cells.Delete

Set fso = VBA.CreateObject("scripting.filesystemobject")

yol = "O:\Muhasebe\RAPOR PAKET DOSYASI\"

For Each dosya In fso.getfolder(yol).Files

If Dir(yol & dosya.Name, vbNormal) = "" Then GoTo 10

If dosya.datelastmodified > mak Then
Sec = dosya.Path
mak = dosya.datelastmodified
End If

10 Next
Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
Sec & ";extended properties=""Excel 12.0;hdr=yes"""

Set rs = con.Execute("select * from[sayfa1$]")

Range("a1").CopyFromRecordset rs

End Sub
 
Öncelikle elinize sağlık gerçekten tebrik ederim,
şunlar var,
En üst satırdaki bazılarını almıyor,
birde sistem bu dosyaları üretirken aynı zamanda gün gün dosya paketi yapıyor,
Yani Ör, yarın 27.7.2016 adında bir dosyanın içine yığın yapacak öbür gün farklı
 
merhaba,

hdr=yes yazan kısmı hdr=no yaparsanız üst satırlar gelecektir.

Son anlattığınız kısmı ise anlayamadım.
 
Burada kullanılan yolda " O:\Muhasebe\RAPOR PAKET DOSYASI\ "
RAPOR PAKET DOSYASI nın alt dosyaları da oluşuyor sistemin oluşturduğu yeni excel tabloları bu dosyaların içinde birikiyor ve hergün yeni bir dosya oluşuyor
dolayısı ile burada O:\Muhasebe\RAPOR PAKET DOSYASI\ yolunun altındaki tüm dosyalarda tarama yapması gerekir diye düşünüyorum.

Acaba anlatabildim mi?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst