Kapalı belgeden alt alta veri aktarma makrosu

K

Kullancı0642

Katılım
13 Mart 2022
Mesajlar
18
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
15-03-2023
Merhaba arkadaslar
Kapalı belgeden veri aktarmak icin asagıdaki makroyu kullanıyorum. Aktarılan veriyi E8 hücresinden itibaren yapıstırıyor. Birden fazla aktarma yapabilmek ve alt alta yapıstırabilmek icin nasıl bir ekleme yapabiliriz. tsk ederim.

Sub aktar1()
Dim conn As Object, rs As Object, yol As String, dosya
Set conn = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
ChDir (ThisWorkbook.Path)
dosya = Application.GetOpenFilename("Excel Dosyaları,xlsx", , "LÜTFEN DOSYAYI SEÇİNİZ")
If dosya = False Then
MsgBox " *** AKTARMA İPTAL EDİLMİŞTİR *** ", vbExclamation
Exit Sub
End If
conn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=yes"";"
rs.Open "[EK-2$D5:AM" & Rows.Count & "]", conn, 1, 1
If rs.RecordCount > 0 Then Range("E8").CopyFromRecordset rs
rs.Close: conn.Close
MsgBox " *** AKTARMA TAMAMLANDI *** "

End Sub
 
TiOr

TiOr

Katılım
17 Mart 2022
Mesajlar
281
Excel Vers. ve Dili
2016/Türkçe
Altın Üyelik Bitiş Tarihi
22-03-2023
Slm,

Bu kod işinizi görecektir.
Her bir aktarımda size hücre aralığını soracak bu şekilde rahatlıkla hücre aralığını belirleyerek aktarım yapabilirsiniz.
Başarılar...

Kod: 
Private Sub CommandButton1_Click()

With Application.FileDialog(msoFileDialogOpen)

.Filters.Clear
.Filters.Add "Excel 2007-13", "*.xlsx;*.xlsm;*.xlsa"
.AllowMultiSelect = False
.Show

If .SelectedItems.Count = 0 Then

        MsgBox "LÜTFEN VERİ ÇEKMEK İSTEDİĞİNİZ EXCEL DOSYASINI SEÇİNİZ"
    Exit Sub
    
End If

kopya = InputBox("KOPYALAMAK İSTEDİĞİNİZ VERİ ARALIĞINI YAZINIZ.", Default:="A2:G2")
yapistir = InputBox("YAPIŞTIRMAK İSTEDİĞİNİZ HÜCREYİ YAZINIZ.", Default:="A6:G6")

Application.Workbooks.Open .SelectedItems(1)
Set kaynak = Application.ActiveWorkbook

'kaynak.Sheets("Sayfa1").Range(kopya).Copy
kaynak.ActiveSheet.Range(kopya).Copy Thisworkbook.ActiveSheet.Range(yapistir)
kaynak.Close False


End With

End Sub
 
D

DrsnDrsn

Katılım
3 Nisan 2022
Mesajlar
32
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Altın Üyelik Bitiş Tarihi
05-04-2023
TiOr' Alıntı:
Slm,

Bu kod işinizi görecektir.
Her bir aktarımda size hücre aralığını soracak bu şekilde rahatlıkla hücre aralığını belirleyerek aktarım yapabilirsiniz.
Başarılar...

Kod: 
Private Sub CommandButton1_Click()

With Application.FileDialog(msoFileDialogOpen)

.Filters.Clear
.Filters.Add "Excel 2007-13", "*.xlsx;*.xlsm;*.xlsa"
.AllowMultiSelect = False
.Show

If .SelectedItems.Count = 0 Then

        MsgBox "LÜTFEN VERİ ÇEKMEK İSTEDİĞİNİZ EXCEL DOSYASINI SEÇİNİZ"
    Exit Sub
   
End If

kopya = InputBox("KOPYALAMAK İSTEDİĞİNİZ VERİ ARALIĞINI YAZINIZ.", Default:="A2:G2")
yapistir = InputBox("YAPIŞTIRMAK İSTEDİĞİNİZ HÜCREYİ YAZINIZ.", Default:="A6:G6")

Application.Workbooks.Open .SelectedItems(1)
Set kaynak = Application.ActiveWorkbook

'kaynak.Sheets("Sayfa1").Range(kopya).Copy
kaynak.ActiveSheet.Range(kopya).Copy Thisworkbook.ActiveSheet.Range(yapistir)
kaynak.Close False


End With

End Sub
Genişletmek için tıkla ...
Teşekkür ederim. Kod yazmadan yapılabilir mi?
 
Y

yusuf1284

Altın Üye
Katılım
17 Ocak 2015
Mesajlar
224
Excel Vers. ve Dili
Office Pro 2016 TR
Altın Üyelik Bitiş Tarihi
09-02-2028
@TiOr Hocam alan belirledikten sonra tüm sayfalardan verileri alt alta alabilir miyiz?
 
TiOr

TiOr

Katılım
17 Mart 2022
Mesajlar
281
Excel Vers. ve Dili
2016/Türkçe
Altın Üyelik Bitiş Tarihi
22-03-2023
@yusuf1284 Selam,

Veri aralığı ve hücre aralığı tercihi yapılabildiğinden dolayı alt alta veri alınabilmektedir.

Başarılar...

237910

237911
 
TiOr

TiOr

Katılım
17 Mart 2022
Mesajlar
281
Excel Vers. ve Dili
2016/Türkçe
Altın Üyelik Bitiş Tarihi
22-03-2023
@yusuf1284
Kod: 
'kaynak.Sheets("Sayfa1").Range(kopya).Copy
Bu kısımda revize yapılması gerekli. Mevcutta Sayfa 1 den alıyor veriyi.
 
Y

yusuf1284

Altın Üye
Katılım
17 Ocak 2015
Mesajlar
224
Excel Vers. ve Dili
Office Pro 2016 TR
Altın Üyelik Bitiş Tarihi
09-02-2028
Hocam çok fazla sayfa olduğundan tek tek yazmak baya zaman alır bir de her ay sayfa adaları değişiyor biraz uğraştım fakat beceremedim
 
S

Said ERSOY

Katılım
27 Ekim 2020
Mesajlar
25
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
18-10-2024
Merhaba Arkadaşlar,

Yukarıdaki kodları denediğimde her defasında bana tüm işlem adımlarını soruyor otomatik olarak bana sormadan kaynak exceli bulması ilgili sayfadan ilgili hücreyi kopyalayıp hedef excel dökümanına yapıştırmasını bekliyorum. Kurgu şu şekilde:

bir kaynak klasörü içerisinde ham raporlarım bulunuyor ve bunlar örneğin 10001.xls - 10002.xls - 10003.xls isminde excel dökümanlarıdır. bu excellerde standart olarak WRData sayfalarında F10,F15,M10,M15,T10,T15 hücelerinde sabit verilerim var.
masaüstünde boş bir excelde A sütununa sırasıyla ham raporlarımın isimlerini yazıyorum kodların bu ham rapor ismine bakarak ham rapordaki WRData sayfasına gidip F10,F15,M10,M15,T10,T15 hücrelerindeki verileri yan yana boş excele getirmesi gerekiyor. Bunu her satırda yazan dosya isminin karşısına otomatik olarak yapması lazım.

Şimdiden yardımlarını için teşekkür ederim. Altın üye olmadığım için örnek döküman yükleyemiyorum.
 
Son düzenleme:
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Said ERSOY' Alıntı:
Merhaba Arkadaşlar,

Yukarıdaki kodları denediğimde her defasında bana tüm işlem adımlarını soruyor otomatik olarak bana sormadan kaynak exceli bulması ilgili sayfadan ilgili hücreyi kopyalayıp hedef excel dökümanına yapıştırmasını bekliyorum. Kurgu şu şekilde:

bir kaynak klasörü içerisinde ham raporlarım bulunuyor ve bunlar örneğin 10001.xls - 10002.xls - 10003.xls isminde excel dökümanlarıdır. bu excellerde standart olarak WRData sayfalarında F10,F15,M10,M15,T10,T15 hücelerinde sabit verilerim var.
masaüstünde boş bir excelde A sütununa sırasıyla ham raporlarımın isimlerini yazıyorum kodların bu ham rapor ismine bakarak ham rapordaki WRData sayfasına gidip F10,F15,M10,M15,T10,T15 hücrelerindeki verileri yan yana boş excele getirmesi gerekiyor. Bunu her satırda yazan dosya isminin karşısına otomatik olarak yapması lazım.

Şimdiden yardımlarını için teşekkür ederim. Altın üye olmadığım için örnek döküman yükleyemiyorum.
Genişletmek için tıkla ...
Kod: 
Sub veriCek()
    Dim strFolder$, i%
    Dim strFile$, lst, strSQL$
    Dim adoCN As Object, rs As Object

    Set adoCN = CreateObject("ADODB.Connection")
    Set rs = CreateObject("Adodb.RecordSet")
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open

    
    Range("B2:G" & Rows.Count).ClearContents

    strFolder = ThisWorkbook.Path & "\Kaynak"

    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        strFile = strFolder & "\" & Cells(i, 1).Value
        
        If Dir(strFile) <> "" Then
          
            strSQL = "Select F1,F8,F15 From [WRData$F10:T15] IN '' [Excel 12.0;HDR=No;Database=" & strFile & "] "

            rs.Open strSQL, adoCN
            lst = rs.getrows
            
            Cells(i, 2).Value = lst(0, 0)
            Cells(i, 3).Value = lst(0, 5)
            Cells(i, 4).Value = lst(1, 0)
            Cells(i, 5).Value = lst(1, 5)
            Cells(i, 6).Value = lst(2, 0)
            Cells(i, 7).Value = lst(2, 5)
            
            rs.Close
        End If
    
    Next i
    
    Columns.AutoFit
    adoCN.Close
    Set rs = Nothing
    Set adoCN = Nothing
    
End Sub
 
S

Said ERSOY

Katılım
27 Ekim 2020
Mesajlar
25
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
18-10-2024
Merhaba veyselemre bey,

If Dir(strFile) <> "" Then

Bu kısımda hata veriyor sebebini anlayamadım. Sadece dosya yolunu değiştirdim. Hata olarak Run-time error '52' bad file name or number yazıyor.


Sub veriCek()
Dim strFolder$, i%
Dim strFile$, lst, strSQL$
Dim adoCN As Object, rs As Object

Set adoCN = CreateObject("ADODB.Connection")
Set rs = CreateObject("Adodb.RecordSet")
adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
adoCN.Properties("Data Source") = ThisWorkbook.FullName
adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
adoCN.Open


Range("B2:G" & Rows.Count).ClearContents

strFolder = ThisWorkbook.Path & "\C:\Users\Desktop\YEDEK\1. LABORATUVAR\2.ORJİNAL TEST RAPORLARI\"

For i = 2 To Cells(Rows.Count, 1).End(3).Row
strFile = strFolder & "\" & Cells(i, 1).Value

If Dir(strFile) <> "" Then

strSQL = "Select F1,F8,F15 From [WRData$F10:T15] IN '' [Excel 12.0;HDR=No;Database=" & strFile & "] "

rs.Open strSQL, adoCN
lst = rs.getrows

Cells(i, 2).Value = lst(0, 0)
Cells(i, 3).Value = lst(0, 5)
Cells(i, 4).Value = lst(1, 0)
Cells(i, 5).Value = lst(1, 5)
Cells(i, 6).Value = lst(2, 0)
Cells(i, 7).Value = lst(2, 5)

rs.Close
End If

Next i

Columns.AutoFit
adoCN.Close
Set rs = Nothing
Set adoCN = Nothing

End Sub
 
Son düzenleme:
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
strFolder = "C:\Users\Desktop\YEDEK\1. LABORATUVAR\2.ORJİNAL TEST RAPORLARI"
böyle deneyin,
Users den sonra kullanıcı ismi yokmu adres yanlış gibi gözüküyor.
 
Son düzenleme:
S

Said ERSOY

Katılım
27 Ekim 2020
Mesajlar
25
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
18-10-2024
bu şekilde yazdığımda hata almıyorum ama veride getiremiyorum. Dosya yolunu buraya eksik yazmışım normalde kodlarımda tam doğru olarak yazıyor. Aşağıda iki farklı denememi de yazdım.

strFolder = "C:\Users\E0633405\Desktop\YEDEK\1. LABORATUVAR\2.ORJİNAL TEST RAPORLARI\"
strFolder = "C:\Users\E0633405\Desktop\YEDEK\1. LABORATUVAR\2.ORJİNAL TEST RAPORLARI"
 
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Çalışmaması için neden yok örnek dosyalarınızı ekleyin.
 
S

Said ERSOY

Katılım
27 Ekim 2020
Mesajlar
25
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
18-10-2024
Aşağıda örnek dosya ekledim. Örnek çalışma olduğu içinde dosya strFolder uzantısını ona göre revize ettim. Ham raporların excel versiyonları 98-2003 bununla alakası olabilir mi bilmiyorum.

strFolder = "CC:\Users\E0633405\Desktop\Örnek Çalışma"
 

Ekli dosyalar

veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Kaynak dosyalarınız aynı klasörde olursa aşağıdaki gibi kullanabilirsiniz. A sütununda .xls uzantısı verilmediği için önceki kodlar çalışmaz. Aşağıdaki kodlarda .xls uzantısı koda eklenmiştir.

Kod: 
Sub veriCek()
    Dim strFolder$, i%
    Dim strFile$, lst, strSQL$
    Dim adoCN As Object, rs As Object

    Set adoCN = CreateObject("ADODB.Connection")
    Set rs = CreateObject("Adodb.RecordSet")
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
   
    Range("B1:G" & Rows.Count).ClearContents

    strFolder = ThisWorkbook.Path

    For i = 1 To Cells(Rows.Count, 1).End(3).Row
        strFile = strFolder & "\" & Cells(i, 1).Value & ".xls"
       
        If Dir(strFile) <> "" Then
         
            strSQL = "Select F1,F8,F15 From [WRData$F10:T15] IN '' [Excel 12.0;HDR=No;Database=" & strFile & "] "

            rs.Open strSQL, adoCN
            lst = rs.getrows
           
            Cells(i, 2).Value = lst(0, 0)
            Cells(i, 3).Value = lst(0, 5)
            Cells(i, 4).Value = lst(1, 0)
            Cells(i, 5).Value = lst(1, 5)
            Cells(i, 6).Value = lst(2, 0)
            Cells(i, 7).Value = lst(2, 5)
           
            rs.Close
        End If
   
    Next i
   
    Columns.AutoFit
    adoCN.Close
    Set rs = Nothing
    Set adoCN = Nothing
   
End Sub
Kod: 
Sub veriCek2()
    Dim rng
    Dim strFolder$, i%, ii%
    Dim strFile$, lst, strSQL$
    
    rng = Array("F10", "F15", "M10", "M15", "T10", "T15")
    
    Range("B1:G" & Rows.Count).ClearContents

    strFolder = ThisWorkbook.Path

    For i = 1 To Cells(Rows.Count, 1).End(3).Row
        strFile = strFolder & "\" & Cells(i, 1).Value & ".xls"
        
        If Dir(strFile) <> "" Then
           
            strFile = strFolder & "\[" & Cells(i, 1).Value & ".xls]"
            
            For ii = 0 To 5
                Cells(i, ii + 2).Value = Application.ExecuteExcel4Macro("'" & strFile & "WRData'!" & Range(rng(ii)).Address(, , xlR1C1))
            Next ii

        End If
    
    Next i
    
    Columns.AutoFit
    
End Sub
 
Son düzenleme:
S

Said ERSOY

Katılım
27 Ekim 2020
Mesajlar
25
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
18-10-2024
strFolder = "dosya yolu" yazdığımda iki kodda çalışıyor. Emekleriniz için çok teşekkür ederim Emre bey.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst