Farklı bir çalışma sayfasında veri çekme sorunu

[Soundcraft]

Değerli arkadaşlar,

2 adet excel dosyamız mevcut Urun.xls ve Export.xls

Urun.xls dosyasında A sütunundaki veriyi Export.xls dosyasında C sütununda arayarak bulduğumuz verinin aynı satırında G sütunundaki veriyi Urun.xls dosyasında aradığımız verinin satırındaki AQ sutun hücresine eklemek istiyorum.

Kısacası Urün dosyasındaki ID değeri Export Dosyasındaki WID değeriyle eşleşen stok değerini Ürün dosyasına yazdırmak istiyorum.

Düşeyara ile yapmaya çalıştım ancak nerede hata yaptığımı anlayamadım ve sonuca ulaşamadım.

Bu konuda beni yönlendirebilir ve yardımcı olabilirseniz çok sevinirim.

ilgili 2 dosyayı da ekliyorum.

 

[Emir Hüseyin Çoban]

. . .

2 excel tablosunu aynı klasör içine alın ve
Ürün tablosuna aşağıdaki kodları ekleyerek çalıştırın.

Sub KOD()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    yol = ThisWorkbook.Path & "\"
    Dim K1 As Workbook: Dim S1 As Worksheet
    Dim K2 As Workbook: Dim S2 As Worksheet
    Set K1 = Workbooks("Urun.xls"): Set S1 = K1.Sheets("Worksheet")
    S1.Range("AQ:AQ").ClearContents
    S1.Range("AQ1") = "Stok"

    Workbooks.Open (yol & "Export.xls")
    Application.ActiveProtectedViewWindow.Edit
    Set K2 = Workbooks("Export.xls"): Set S2 = K2.Sheets("Temp1")
    
    For i = 2 To S1.Cells(Rows.Count, "A").End(3).Row
        If WorksheetFunction.CountIf(S2.Range("C:C"), S1.Cells(i, "A")) > 0 Then
            S1.Cells(i, "AQ") = _
            WorksheetFunction.VLookup(S1.Cells(i, "A"), S2.Range("C:G"), 5, 0)
        Else
            S1.Cells(i, "AQ") = 0
        End If
    Next i
    
    K2.Close , False
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "B i t t i "
End Sub

. . .

 

[Soundcraft]

İlgi ve alakanız için teşekkür ederim.

Kod çalıştı. Yanlız bir ihtiyaç daha hasıl oldu.
Aynı seçimle (G sütunundaki veriyi AQ Sütununa ekleme gibi) I sütunundaki veriyi W sütunundaki eşdeğer hücreye
J sütunundaki veriyi de X sütunundaki eşdeğer hücreye eklemek için vede Mantığını da kavramak adına vb kodunda hangi değişikliği yapmalıyız.

Yani stok miktarını aldığımız gibi I sütunu Fiyat1 ve J sütunu Fiyat2 hanelerini de aynı şekilde alabilirmiyiz?

 

[Emir Hüseyin Çoban]

Aynı kodun devamında mı alacak yoksa
2 kodu ayrı ayrı mı çalıştıracaksınız.

.

 

[Soundcraft]

Aynı kod ile çalıştıracağız. Yani tek komut ile hem Stok miktarını hemde Fiyat1 ve Fiyat2 yi çağıracağız

 

[Emir Hüseyin Çoban]

. . .

Export tablosunda fiyatla ilgili sütunlar yok.

. . .

 

[Soundcraft]

Evet haklısınız.

Fiyatları çekmek sonradan hasıl olduğu için yeniden düzenlendi.

Güncel dosyayı ekledim şimdi.

 

[Emir Hüseyin Çoban]

Evet haklısınız.

Fiyatları çekmek sonradan hasıl olduğu için yeniden düzenlendi.

Güncel dosyayı ekledim şimdi.

. . .

Sub KOD()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    yol = ThisWorkbook.Path & "\"
    Dim K1 As Workbook: Dim S1 As Worksheet
    Dim K2 As Workbook: Dim S2 As Worksheet
    Set K1 = Workbooks("Urun.xls"): Set S1 = K1.Sheets("Worksheet")
    S1.Range("AQ:AQ").ClearContents: S1.Range("AQ1") = "Stok"
[COLOR="Blue"]    S1.Range("W:W").ClearContents: S1.Range("W1") = "Fiyat"
    S1.Range("X:X").ClearContents: S1.Range("X1") = "Fiyat1"[/COLOR]
    
    Workbooks.Open (yol & "Export.xls")
    Application.ActiveProtectedViewWindow.Edit
    Set K2 = Workbooks("Export.xls"): Set S2 = K2.Sheets("Temp1")
    
    For i = 2 To S1.Cells(Rows.Count, "A").End(3).Row
        If WorksheetFunction.CountIf(S2.Range("C:C"), S1.Cells(i, "A")) > 0 Then
            S1.Cells(i, "AQ") = _
            WorksheetFunction.VLookup(S1.Cells(i, "A"), S2.Range("[COLOR="Blue"]C:I[/COLOR]"), 5, 0)
            
    [COLOR="Blue"]        S1.Cells(i, "W") = _
            WorksheetFunction.VLookup(S1.Cells(i, "A"), S2.Range("C:I"), 6, 0)
            
            S1.Cells(i, "X") = _
            WorksheetFunction.VLookup(S1.Cells(i, "A"), S2.Range("C:I"), 7, 0)
            [/COLOR]
        Else
            S1.Cells(i, "AQ") = 0
     [COLOR="Blue"]       S1.Cells(i, "W") = 0
            S1.Cells(i, "X") = 0[/COLOR]
            
        End If
    Next i
    
    K2.Close , False
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "B i t t i "
End Sub

. . .

 

[mehmetali.bacak]

veri çekme

. . .

Sub KOD()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    yol = ThisWorkbook.Path & "\"
    Dim K1 As Workbook: Dim S1 As Worksheet
    Dim K2 As Workbook: Dim S2 As Worksheet
    Set K1 = Workbooks("Urun.xls"): Set S1 = K1.Sheets("Worksheet")
    S1.Range("AQ:AQ").ClearContents: S1.Range("AQ1") = "Stok"
[COLOR="Blue"]    S1.Range("W:W").ClearContents: S1.Range("W1") = "Fiyat"
    S1.Range("X:X").ClearContents: S1.Range("X1") = "Fiyat1"[/COLOR]
    
    Workbooks.Open (yol & "Export.xls")
    Application.ActiveProtectedViewWindow.Edit
    Set K2 = Workbooks("Export.xls"): Set S2 = K2.Sheets("Temp1")
    
    For i = 2 To S1.Cells(Rows.Count, "A").End(3).Row
        If WorksheetFunction.CountIf(S2.Range("C:C"), S1.Cells(i, "A")) > 0 Then
            S1.Cells(i, "AQ") = _
            WorksheetFunction.VLookup(S1.Cells(i, "A"), S2.Range("[COLOR="Blue"]C:I[/COLOR]"), 5, 0)
            
    [COLOR="Blue"]        S1.Cells(i, "W") = _
            WorksheetFunction.VLookup(S1.Cells(i, "A"), S2.Range("C:I"), 6, 0)
            
            S1.Cells(i, "X") = _
            WorksheetFunction.VLookup(S1.Cells(i, "A"), S2.Range("C:I"), 7, 0)
            [/COLOR]
        Else
            S1.Cells(i, "AQ") = 0
     [COLOR="Blue"]       S1.Cells(i, "W") = 0
            S1.Cells(i, "X") = 0[/COLOR]
            
        End If
    Next i
    
    K2.Close , False
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "B i t t i "
End Sub

. . .

Hüseyin Bey iyi akşamlar,

Veri çekme ile ilgili bir sorunum var. yapılabilme ihtimali varmıdır bilmiyorum. varsa benim için aylarca sürecek bir işlemi çözmüş olursunuz

şöyleki,

1- bir klasör içinde birçok klasör ve bu klasörlerin içerisinde yüzlerce excel var.
2- bu excel dosyalarının isimleri ve sayfa isimleri farklı. sadece her excelin içinde 1 sayfa var.
3- rapor olarak bir excelin içerisine bu klasörlerdeki excellerden benim belirlediğim değerlere göre (örn. analiz1 değeri, analiz2 değeri gibi) otomatik hepsini getirmek mümkün olurmu?
4- yani hem klasör içindeki tüm excellerden veri getirecek ve rapor excelinde getirdiği veriyi ilgili karşılığını bulup oraya yazacak.

birçok talep sözkonusu ama yapılabilme ihtimali varsa benim için dediğim gibi aylarac sürecek bir işlem. yardımlarınız için şimdiden çok teşekkürler

 

[Emir Hüseyin Çoban]

. . .

Yeni konu açarak tablonuzun örneklerini yükleyin inceleyelim.

. . .