İki Veri Arasına Sütun Oluşturma ve Değer Aktarma,

[Utekiner]

Merhaba;


C sütunu ile D sütunu arasına yeni bir sütun oluşturmasını,
Sheet2 sayfasındaki A1:B18 arasındaki değerleri Sheet1 nin C sütunundaki değerlere göre aramasını ve oluşan sütuna başlığı ile birlikte yazmasını istiyorum.

Eğer aranacak veri kapalı bir dosyada ise,dosya adı (ID_Bilgileri) Sheet1 nin A1:B18 arasındaysa ekte paylaştığım örnekteki çalışma nasıl yapılabilir. İki farklı durum için makro oluşturulması için destek olabilir misiniz. Ekte tamamlanmış hali mevcuttur.

https://s4.dosya.tc/server7/iw1o6t/Sutun_Olusturma_ve_Deger_Aktarma.xlsm.html

 

[metehan8001]

Sub ExcelDestek()
Dim s2 As Worksheet: Set s2 = Sheets("Sheet2")
With Sheets("Sheet1")
    .Columns("D:D").Insert Shift:=xlToRight
    .Range("D1").Value = "Name"
        For a = 2 To .Cells(Rows.Count, 3).End(xlUp).Row
            Set bul = s2.Range("A:A").Find(.Cells(a, 3))
            If Not bul Is Nothing Then
                .Cells(a, 4) = bul.Offset(0, 1)
            End If
        Next a
End With

End Sub

 

[Utekiner]

Sn. @metehan8001 Bey çok teşekkür ederim. Elinize sağlık.

Sheet2 bilgiler kapalı dosya da olsa idi kod nasıl olmalıydı. Dosya ismi: ID_Bilgileri

 

[metehan8001]

Sn. @metehan8001 Bey çok teşekkür ederim. Elinize sağlık.

Sheet2 bilgiler kapalı dosya da olsa idi kod nasıl olmalıydı. Dosya ismi: ID_Bilgileri

Sub ExcelDestek_ADO()
dosya_yolu = ThisWorkbook.Path & "\Sutun_Olusturma_ve_Deger_Aktarma.xlsm" ' DOSYA YOLUNU
sayfa = "Sheet2" ' SAYFA ADINI YAZIN
''^^
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
dosya_yolu & ";extended properties=""Excel 12.0;hdr=yes"""
With Sheets("Sheet1")
    .Columns("D:D").Insert Shift:=xlToRight
    .Range("D1").Value = "Name"
        For a = 2 To .Cells(Rows.Count, 3).End(xlUp).Row
            sorgu = "Select [Name] From [" & sayfa & "$] Where [ID] = '" & .Cells(a, 3) & "'"
            rs.Open sorgu, con, 1, 1
            If rs.RecordCount > 0 Then .Cells(a, 4).CopyFromRecordset rs
            rs.Close
        Next a
        con.Close: Set rs = Nothing: Set con = Nothing
End With

End Sub

 

[Utekiner]

Sn. @metehan8001 Bey,

Bu şekilde bir hatada kaldı.

 

[metehan8001]

Test ederek, yazdım kodları. 1.mesajdaki dosya üzerinde denediğinizde çalışır.
Kapalı dosyanıza uyarlamada sıkıntı yaşamışsınızdır.
Ayrıca bu tür konularda hata kodu ve hata satırını da paylaşın. Aksi halde afaki cevaplar alırsınız veya cevap bile alamazsınız.

 

[Utekiner]

Test ederek, yazdım kodları. 1.mesajdaki dosya üzerinde denediğinizde çalışır.
Kapalı dosyanıza uyarlamada sıkıntı yaşamışsınızdır.
Ayrıca bu tür konularda hata kodu ve hata satırını da paylaşın. Aksi halde afaki cevaplar alırsınız veya cevap bile alamazsınız.

Metehan Bey şöyle bir adım uyguladım.

- Sütun Oluşturma ve Değer Aktarma.xlsm dosyasını yeni bir klasör oluşturdum ve taşıdım.
- Sheet2 sildim.
-Yeni Klasörün içerisine ID_Bilgileri adında yeni bir çalışma kitabı oluşturdum. Sayfa adını Sheet2 yaptım. Bilgileri kopyalayıp kapattım.
-Paylaştığınız kodda - dosya_yolu = ThisWorkbook.Path & "\Sutun_Olusturma_ve_Deger_Aktarma.xlsm" ' DOSYA YOLUNU yerine "\ID_Bilgileri.xlsm" yazarak değiştirdim.
- Daha sonra makroyu çalıştırdım.

Yapmış olduğum hata acaba nedir.

Makro çalıştırdığımda aldığım hata ;

 

[metehan8001]

Paylaştığınız hatayı göremiyorum. Oluşturduğunuz klasörü sıkıştırıp paylaşır mısınız?

 

[Utekiner]

Paylaştığınız hatayı göremiyorum. Oluşturduğunuz klasörü sıkıştırıp paylaşır mısınız?

Metehan Bey ,
.rar programı olmadığı için bu şekilde yükledim.
Klasör yeri : Masaüstü
İsmi: Sütun Oluşturma ve Değer Aktarma

Kapalı Dosya
https://dosya.co/9ojuj1is1y1n/ID_Bilgileri.xlsx.html
Açık Dosya
https://dosya.co/jbz9ueal4iws/Sütun_Oluşturma_ve_Değer_Aktarma.xlsm.html

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Veri_Al()
    Dim Yol As String, Dosya_Adi As String
    Dim Sayfa_Adi As String, Adres As String, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya_Adi = "[ID_Bilgileri.xlsx]"
    Sayfa_Adi = "Sheet2'"
    Adres = "'" & Yol & Dosya_Adi & Sayfa_Adi & "!A:B"
    
    Range("D:D").Insert
    Range("D1") = "Name"
    Son = Cells(Rows.Count, 1).End(3).Row
    
    With Range("D2:D" & Son)
        .Formula = "=IFERROR(VLOOKUP(C2," & Adres & ",2,0),"""")"
        .Value = .Value
    End With
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Veri alma işlemi tamamlanmıştır.", vbInformation
End Sub

 

[metehan8001]

Metehan Bey ,
.rar programı olmadığı için bu şekilde yükledim.
Klasör yeri : Masaüstü
İsmi: Sütun Oluşturma ve Değer Aktarma

Kapalı Dosya
https://dosya.co/9ojuj1is1y1n/ID_Bilgileri.xlsx.html
Açık Dosya
https://dosya.co/jbz9ueal4iws/Sütun_Oluşturma_ve_Değer_Aktarma.xlsm.html

Hata resimleri görünmüyordu gece, şimdi açılıyor.
Buğün mobilim ama gördüğüm kadarı ile kapalı dosyanın uzantısını yanlış yazmışsınız.

 

[Utekiner]

Sn. @Korhan Ayhan Bey iyi ki buradasınız. Elinize emeğinize sağlık. Allah sizden razı olsun.

 

[Utekiner]

Hata resimleri görünmüyordu gece, şimdi açılıyor.
Buğün mobilim ama gördüğüm kadarı ile kapalı dosyanın uzantısını yanlış yazmışsınız.

Sn. @metehan8001 Bey evet xlsm yerine xlsx yaptım tıkır tıkır çalışıyor. Yardımlarınız için teşekkür ederim.