Soru Adresini Gösterdiğim Excelden belirli sütunlarındaki verileri Makrodaki sayfaya çektirme

[ayhanycelik]

Merhabalar;

Makro tuşuna bastığımda gösterdiğim yerdeki (masa üstü new klasörü ya da farklı bir alanda da olabilir) Exceli açıp B,C,E,H,I,J,BT,CE sütunlarındaki verileri Makromda bulunana Sayfa1 sekmesine çektirmek istiyorum mümkün müdür?

Çok teşekkür ederim

 

[mesuttasar]

Makronuzun bulunduğu çalışma kitabındaki sayfanın aynı sütunlarına mı kaydetmek istiyorsunuz_

 

[ayhanycelik]

Merhaba @mesuttasar bey ; Hayır A sütunundan başlayarak sütunları yana yana koplamak istiyorum; Yolunu gösterdiğim excelde çokfazla sütun var ve bana gerekli olan sütunlar sadece (B,C,E,H,I,J,BT,CE ) sütunları ben bu sütunlardaki tüm hücreleri makromun olduğu excelede bulunan sayfa1 sekmesine A sütunundan başlayarak kopyalamak isityorum.

 

[mesuttasar]

Kolonları koyalanacak çalışma kitabının sayfa isminin de Sayfa1 olması durumunda aşağıdaki kodları kullanabilirsiniz.

sub verigetir()
Dim kaynakkitap As Workbook
Dim kaynaksayfa As Worksheet
Dim bukitap As Workbook
Dim hedefsayfa As Worksheet
Dim kolon As Variant
Dim s As Variant
dim i as long

Dim fileDialog As fileDialog
    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    With fileDialog
        .AllowMultiSelect = False
        .Title = "Kaynak Dosya Seç"
        .Filters.Clear
        .Filters.Add "Excel Dosyaları", "*.xls; *.xlsx; *.xlsm", 1
        If .Show = -1 Then ' Kullanıcı "Aç" butonuna bastıysa
            sourceFilePath = .SelectedItems(1)
        Else
            MsgBox "Dosya seçimi iptal edildi.", vbExclamation
            Exit Sub
        End If
    End With


    Set kaynakkitap = Application.Workbooks.Open(sourceFilePath)
    Set kaynaksayfa = kaynakkitap.Sheets("Sayfa1")
    Set bukitap = ThisWorkbook
    Set hedefsayfa = ThisWorkbook.Sheets("Sayfa1")

    kolon = Array("B", "C", "E", "H", "I", "J", "BT", "CE")
    i=1
        For Each s In kolon
            kaynaksayfa.Columns(s).Copy Destination:=hedefsayfa.Columns(i)
        i=i+1
        Next s
kaynakkitap.Close SaveChanges:=False

MsgBox "Veriler kopyalandı!"
end sub

 

[Korhan Ayhan]

Veri aktarımı sırasında BİÇİMLENDİRMELER önemli değilse ADO ile hedef dosyayı açmadan işlem yapabilirsiniz..

 

[mesuttasar]

@Korhan Ayhan hocam, benim excel'im ADO'ya yetmiyor

 

[Korhan Ayhan]

@mesuttasar,

Aslında gözde büyütüldüğü kadar zor değil. Bende önceleri hiç bulaşmak istememiştim.

ADO için bağlantı açma-kapama satırları sabit zaten. Sizi zorlayacak asıl iş ise sorgu satırının kurgularıdır. Ben bile halâ kendimi geliştirmek için sürekli araştırıyorum. Hele ki yapay zeka çıktı bazı işler daha da kolaylaştı.

Bence ufak ufak en basit haliyle forumdaki kodları inceleyerek başlayabilirsiniz. Eliniz alışınca ne kadar kolaşmış diyeceğinize eminim.

Hatta aşağıdaki linkte Erdem beyin videolu anlatımları bulunuyor. Size oldukça faydası olacaktır.

https://www.excel.web.tr/threads/excel-ado-kapali-dosyalarla-calisma-egitimi-uecretsiz-youtubeda.190769/

 

[Korhan Ayhan]

Örnek olması açısından ADO kodlarını paylaşıyorum.

Option Explicit

Sub Import_Data()
    Dim Process_Time As Double, My_Connection As Object, My_File As Variant, My_Recordset As Object
    
    Range("A:H").ClearContents
    
    My_File = Application.GetOpenFilename(FileFilter:="Excel Dosyaları (*.xls*), *.xls*", Title:="Lütfen bir dosya seçiniz...")

    If My_File = False Then
        MsgBox "Dosya seçimi yapmadığınız için işleminiz iptal edilmiştir.", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Process_Time = Timer

    Set My_Connection = CreateObject("AdoDb.Connection")

    Select Case Val(Application.Version)
        Case Is < 12
            My_Connection.Open "Provider=Microsoft.Jet.OleDb.4.0;Data Source=" & My_File & ";Extended Properties=""Excel 8.0;HDR=No"""
        Case Is > 11
            My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & My_File & ";Extended Properties=""Excel 12.0 Xml;Hdr=No"""
    End Select

    Set My_Recordset = My_Connection.Execute("Select F2,F3,F5,F8,F9,F10,F72,F83 From [Sheet1$]")
    Range("A1").CopyFromRecordset My_Recordset
  
    My_Recordset.Close
    My_Connection.Close

    Set My_Recordset = Nothing
    Set My_Connection = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "Veriler aktarılmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[ayhanycelik]

@mesuttasar , @Korhan Ayhan bey çok teşekkür ederim, yukarıdaki işlemi bir adım ilerletmek istiyorum şöyle ki; gösterdiğim klasörde 7 aylık 7 adet excel verisini alt alta tek excel’de birleştirmek istiyorum ama; bazı aylarda dosya içerikleri aynı olmasına rağmen, girişi yapan arkadaş Sütun başlığı hücre yerini farklı hücrede başlatmış (Ocak ayında D1 Hücresinde Olan “Ardiye” Satır başlığı Mart Ayında K1 Hücresinde yazmış bu sebeple alt alta verileri kopyalasam sütün başlığı eşleşmediği için işlemi uygulayamıyorum destek olabilir misiniz

 

[Korhan Ayhan]

Bu şekilde olan 2 dosya paylaşırsanız destek olabiliriz..

 

[Korhan Ayhan]

Sadece sarı renkli alanlar mı aktarılacak?

Ayrıca paylaştığınız dosyalarda sütun başlıklarıda farklı görünüyor. Bu durumda bildiğim kadarıyla ADO kullanımı devre dışı kalacaktır.

 

[ayhanycelik]

@Korhan Ayhan bey; Hayır tüm ütun başlık verileri alt alta gelmeli (7 adet dosyam var)

 

[Korhan Ayhan]

Dosyalarda sütunların farklı yerde olması önemli değil fakat başlık isimleri aynı değilse benim önerdiğim yöntemi kullanamayız.

 

[ayhanycelik]

Başlık isimleri aynı aslında değişik olan varsa ben elle başlık ismini değiştririm

 

[Korhan Ayhan]

İlk gözüme çarpan... AÇIKLAMA

 

[ayhanycelik]

manuel değiştirebilirm hepsini Açıklama olarak

 

[ayhanycelik]

Başlığı güncelledim

 

[Haluk]

Yeni bir Excel dosyası açın ve verilerin alınacağı Excel dosyalarının olduğu klasöre yerleştirin ve aşağıdaki kodu yeni Excel dosyasında çalıştırın...

Benzer şekilde diğer dosyaları ve tablolardaki alanları ilave edebilirsiniz....

Sub Test()
    'Haluk 29/08/2023
    Dim WB1 As String, WB2 As String, WB3 As String
    Dim strConnection As String
    Dim strQuery As String
    Dim objConnection As Object
    Dim RS As Object
   
    WB1 = ThisWorkbook.Path & Application.PathSeparator & "ocak.xlsx"
    WB2 = ThisWorkbook.Path & Application.PathSeparator & "şubat.xlsx"
    WB3 = ThisWorkbook.Path & Application.PathSeparator & "temmuz.xlsx"
   
    strConnection = _
        "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "User ID=Admin;" & _
        "Data Source='" & ThisWorkbook.FullName & "';" & _
        "Mode=Read;" & _
        "Extended Properties=""Excel 12.0 Macro;"";"

    strQuery = _
        "Select [Ay], [Referans], [Link], [Mücbir], [TescilNo], [TescilTarihi] from [Export$] " & _
        "in '" & WB1 & "' " & _
        "[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties='HDR=Yes;'] " & _
        "union all " & _
        "select [Ay], [Referans], [Link], [Mücbir], [TescilNo], [TescilTarihi]  from [Export$] " & _
        "in '" & WB2 & "' " & _
        "[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties='HDR=Yes;'] " & _
        "union all " & _
        "select [Ay], [Referans], [Link], [Mücbir], [TescilNo], [TescilTarihi] from [Export$] " & _
        "in '" & WB3 & "' " & _
        "[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties='HDR=Yes;']"

    Set objConnection = CreateObject("ADODB.Connection")
    objConnection.Open strConnection
   
    Set RS = objConnection.Execute(strQuery)
   
    For j = 0 To RS.Fields.Count - 1
        Cells(1, j + 1) = RS.Fields(j).Name
    Next
   
    Range("A2").CopyFromRecordset RS
   
    objConnection.Close
    Set objRecordSet = Nothing
    Set objConnection = Nothing
End Sub

.

 

[ayhanycelik]

Merhaba Haluk Bey; aşağıdaki hatayı aldım ama

 

[Haluk]

Kodda belirtilen tum dosyalrin oldugundan ve sayfa isimlerinin "Export" oldugundan emin olun...

.