kapalı excel den gelen veriyi for ile yerleştirme ?

[blackkugu]

Merhaba arkadaşlar bir kapalı excel dosyasındaki verileri direk çekiyorum burada sorun yok. Tek sorun for döngüsü ile verileri karşılaştırıp yazdırmak.

Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(ThisWorkbook.Path & "\" & Range("S2").Value & "\" & ActiveCell.Value & "E.xls")
If a = True Then

Range("O7:O35").Value = "" ' temizle

Dim conn As Object, rs As Object, yol As String, dosya
Set conn = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
conn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\" & Range("S2").Value & "\" & ActiveCell.Value & "E.xls" & ";extended properties=""excel 12.0;hdr=yes;imex=1"""

rs.Open "Select * from [Sayfa1$D235]", conn, 1, 1
Range("O7").CopyFromRecordset rs
rs.Close: conn.Close

Else
MsgBox ActiveCell.Value & " 'isimde bir dosya yok"

End If


şöyle yapmak istiyorum ; kapalı sayfada D sutunundaki veriyi açık sayfadaki O sutunundaki aynı veriyi bulma bulunan verileri D nin yanındaki yani E sutunundaki bilgileri açık sayfadaki aynı verinin yanına yani O sutunun yanındaki P karşısına kopyalasın. Biraz karışık anlattım sanırım

 

[RBozkurt]

İki dosyadan da örnek ekleyiniz

 

[blackkugu]

Merhaba

İki dosyadan da örnek ekleyiniz

ücretli üyeliğim yok maalesef dosyaları yüklesemde buradaki dosyaları indiremiyorum

 

[RBozkurt]

Merhaba

ücretli üyeliğim yok maalesef dosyaları yüklesemde buradaki dosyaları indiremiyorum

Dosya.tc - Ücretsiz, Hızlı ve Kolay Dosya Paylaşımı - Dosya Upload

Dosya.tc, dosya yükleme ve paylaşım platformudur. Her türlü veriyi (dosya, resim, müzik, video vb.) saklayabilir ve paylaşabilirsiniz. Tamamen ücretsiz, üyeliğe gerek yok. Hiçbir limit yok. Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

Burası olabilir

 

[blackkugu]

Lifebox Transfer: Upload File! Send and Share Large Files

Lifeboxtransfer is a fast file transfer service for sharing your files easily without membership. Click and start sharing your files fast and easily with lifeboxtransfer.

lifeboxtransfer.com

İki dosyadan da örnek ekleyiniz

 

[blackkugu]

Dosya.tc - Ücretsiz, Hızlı ve Kolay Dosya Paylaşımı - Dosya Upload

Dosya.tc, dosya yükleme ve paylaşım platformudur. Her türlü veriyi (dosya, resim, müzik, video vb.) saklayabilir ve paylaşabilirsiniz. Tamamen ücretsiz, üyeliğe gerek yok. Hiçbir limit yok. Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

Burası olabilir

ornek.rar dosyasını indir - download

ornek.rar dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

 

[RBozkurt]

@blackkugu deneyiniz.

Sub NotGetir()
    Dim dosya_yolu As String, dosya_adı As String
    Dim wb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim son_satir As Long, i As Long
    
    dosya_yolu = ThisWorkbook.Path & "\2023\"
    dosya_adı = "kapali.xlsx"
    
    Set wb = Workbooks.Open(dosya_yolu & dosya_adı)
    Set ws1 = ThisWorkbook.Sheets("Sayfa1")
    Set ws2 = wb.Sheets(1)
    
    son_satir = ws1.Cells(Rows.Count, "O").End(xlUp).Row
    
    For i = 7 To son_satir
        If ws2.Range("D:D").Find(ws1.Range("O" & i).Value) Is Nothing Then
            MsgBox "Dosyada " & ws1.Range("O" & i).Value & " bulunamadı."
        Else
            ws1.Range("P" & i).Value = ws2.Range("E" & _
              ws2.Range("D:D").Find(ws1.Range("O" & i).Value).Row).Value
        End If
    Next i
    wb.Close SaveChanges:=False
End Sub

 

[blackkugu]

@blackkugu deneyiniz.

Sub NotGetir()
    Dim dosya_yolu As String, dosya_adı As String
    Dim wb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim son_satir As Long, i As Long
   
    dosya_yolu = ThisWorkbook.Path & "\2023\"
    dosya_adı = "kapali.xlsx"
   
    Set wb = Workbooks.Open(dosya_yolu & dosya_adı)
    Set ws1 = ThisWorkbook.Sheets("Sayfa1")
    Set ws2 = wb.Sheets(1)
   
    son_satir = ws1.Cells(Rows.Count, "O").End(xlUp).Row
   
    For i = 7 To son_satir
        If ws2.Range("D:D").Find(ws1.Range("O" & i).Value) Is Nothing Then
            MsgBox "Dosyada " & ws1.Range("O" & i).Value & " bulunamadı."
        Else
            ws1.Range("P" & i).Value = ws2.Range("E" & _
              ws2.Range("D:D").Find(ws1.Range("O" & i).Value).Row).Value
        End If
    Next i
    wb.Close SaveChanges:=False
End Sub

eline sağlık tam aradığım gibi oldu çok tşk ederim.

 

[RBozkurt]

Rica ederim, kolay gelsin.