Farklı bir çalışma kitabından makro ile veri çekmek

Katılım
11 Eylül 2011
Mesajlar
114
Excel Vers. ve Dili
2013 Türkçe
Arkadaşlar soracağım soruda aslında forumda başlıklar buldum ama maalesef kendi dosyama uygulayamadım. Şimdi benim RAPOR isimli bir dosyam var üzerinde çalıştığım dosya. Bana her hafta şubelerden veriler geliyor. Örnek dosyada ki gibi (A-01.04. 07.04) bu verilen çok fazla. Şimdi ben Rapor isimli bir dosya oluşturdum. bu dosya içinde çalışma sayfalarına bu verileri tek tek gidip yapıştırıyorum. Her hafta veriler geldikçe dosya içeriğinde ki verileri buraya alt alta gelecek şekilde yapıştırıp daha sonra e topla vb formüllerle raporlarımı oluşturuyorum. Ama bu oldukça yorucu olabiliyor. Yapmaya çalıştığım ise Rapor dosyası içinde mesela A ŞİRKETİ ne girip ilgili dosyada ki verileri son dolu satırın bir kaç satır altına gelecek şekilde yapıştırabilmek ama tabiki dosya seçeceğim. Verinin geleceği dosya ismi farklı olsada çekeceği sayfa ismi her zaman Sayfa1 şeklinde olacaktır.
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
RAPOR isimli dosyanızda aşağıdaki kodu deneyiniz.

Kod:
Option Explicit

Sub Veri_Aktar()
    Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet, S2 As Worksheet
    Dim Dosya As Variant, Son As Long, Son_Veri_Satiri As Long
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("A-ŞİRKETİ")
    
    On Error Resume Next
    Son = S1.Cells.Find("*", Searchorder:=xlByRows, Searchdirection:=xlPrevious).Row
    On Error GoTo 0
    
    If Son = 0 Then
        Son = 1
    Else
        Son = Son + 3
    End If
    
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls;*.xlsb;*.xlsx;*.xlsm),*.xls;*xlsb;*.xlsx;*.xlsm", Title:="Lütfen dosya seçimi yapınız...")
    If Dosya = False Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set K2 = Workbooks.Open(Dosya)
    Set S2 = K2.Sheets(1)
    
    On Error Resume Next
    Son_Veri_Satiri = S2.Cells.Find("*", Searchorder:=xlByRows, Searchdirection:=xlPrevious).Row
    On Error GoTo 0
    
    If Son_Veri_Satiri = 0 Then
        Application.ScreenUpdating = True
        MsgBox "Aktarılacak veri bulunamadı!", vbCritical
        GoTo 10
    Else
        S2.Range("A1:X" & Son_Veri_Satiri).Copy S1.Cells(Son, 1)
        Application.ScreenUpdating = True
        MsgBox "Veri aktarımı tamamlanmıştır", vbInformation
    End If

10
    K2.Close 0
    
    Set S2 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
    Set K1 = Nothing
End Sub
 
Katılım
11 Eylül 2011
Mesajlar
114
Excel Vers. ve Dili
2013 Türkçe
Korhan hocam tşk ederim istediğim bu ama sadece bir kaç noktada sıkıntı yaşadım. Birincisi alınan veriyi C sütunu değilde A sütununa yapıştırabilirmiyiz.. Birde ben çok anlayamıyorum son satırın hangisi olduğunu hangi sütuna veya satıra bakıyor. Deneme yaptığım zaman mesela K sütununda 14.satırdan itibaren almıyor. Bunu da halledebilirsem bitmiş olacak. Yardımlarınız için çok tşk ederim.
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Üstteki mesajımdaki kodu güncelledim. Deneyiniz.
 
Katılım
11 Eylül 2011
Mesajlar
114
Excel Vers. ve Dili
2013 Türkçe
Korhan Hocam tşk ederim. Elinize sağlık...:)
 
Üst