• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Farklı çalışma kitaplarındaki verilerden liste oluşturma

A

ardakose

Katılım
29 Temmuz 2014
Mesajlar
23
Excel Vers. ve Dili
2016 tr
Herkese iyi günler.
Belirli sırayla adlandırılmış sipariş formlarım mevcut. 2016_001 , 2016_002 olarak devam edip gidiyor.
Tüm Siparişler adında bir dosya oluşturup
Dosya adını A sütununa yazdığımda B sütuna 2016_001 de yazan tarihi C ye Proje adını.... yazmadırmam gerekiyor.

Bunun için nasıl bir yol izleyebilirim.
 
Merhaba
Örnek dosya ekler misiniz ?
 
Örnek dosyaları ekledim.
Listedeki birçok bölüm boş ama hepsi benzer yöntemle ana dosyalardan çekilecek.
 

Ekli dosyalar

Merhaba
Dosyadaki Sipariş içeriğini hangi satırdan alacak. Onların bilgisini de verirseniz daha net yardımcı olabilirim.
Birden fazla satırdan bilgi alacaksa bunun krtieri ne olacak onlarıda mümkünse söyleyin.
Bir de bunu nasıl çalıştırmak istiyorsunuz. A sütununda herhangi bir hücreye yazdığınızda mı çalışsın. Yoksa bir butona bağlayıp siz istediğiniz de mi çalışacak.

Kod ile yapacağım.
 
Tüm liste dosyasındaki sipariş no sutununa sipariş no girildiğinde sipariş tarihini sipariş no ile aynı ada sahip dosyanın k12 hücresinden çekecek. Bunun nasıl yapıldığını öğrenebilirsem diğer ihtiyaçlarımı kendim yapabilirim.
 
ardakose' Alıntı:
Tüm liste dosyasındaki sipariş no sutununa sipariş no girildiğinde sipariş tarihini sipariş no ile aynı ada sahip dosyanın k12 hücresinden çekecek. Bunun nasıl yapıldığını öğrenebilirsem diğer ihtiyaçlarımı kendim yapabilirim.
Genişletmek için tıkla ...

Dosyayı dener misiniz ?
Kod şimdilik A5:A8 arasında çalışır.
Çalışma şekli dosya adını A sütununda bir yere yazın. ( 5 ila 8 satır arasında ) diğer bilgiler otomatik geliyor.
 

Ekli dosyalar

Evet çalıştı. Teşekkür ederim. Kod mantığını anladığımda kendi istediklerimi yapabilirim sanırım.
Yapamazsam tekrar danışırım. Hayırlı akşamlar.
 
Yaptım güzel oldu teşekkürler. Bunu birde sütunlara kopyalacak şekilde nasıl yapabilirim.
Row olan yeri column yaptım ancak olmadı. A5 dosya ismini girdiğimizde verileri B5 C5 e değilde
A6 ve A7 ye yazdırmak istiyorum bu şekildede ikinci bir listeyi otomatik oluşturmam gerekiyor.
 
Merhaba
Dosyanızda nasıl işlem yapacağınızı manuel yazın. Yükleyin. Makro yazılacağı için sürekli değişiklik yapılmaz bir seferde neler istediğinizi yazın bakalım oluru var ise yazar gönderirim.
Ayrıca alt satıra kayıt yapmak istediğinizi söylemişsiniz.
Kodun ilgili kısımlarını bununla değiştirim. Yalnız hata verecektir. A sütununda dosya ismi yazılacağı için.
Kod: 
Cells(Target.Row + 1, "B") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]PROFİL'!R11C11")
Cells(Target.Row + 2, "C") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]PROFİL'!R12C11")
 
Yapmak istediklerimle ilgili örnek dosyayı yükledim. Teşekkürler.
 

Ekli dosyalar

Sorularınıza tek tek yanıt vereyim.
1 - Makro olduğu için hata oluşuyor sebebi ise o satırdaki bilgiye göre çalıştığı için siz o satırı sildiğinizde aradığı değer olmadığı için bulamayıp hata veriyor. Bunu bir şekilde yok ederiz yalnız bu sizin için pek iyi olmaz diye düşünüyorum.
2 - Sayfanızın kod bölümündeki kodu silin ve bunu ekleyin.
İstediğiniz bilgi satıra tıkladığınızda bir mesaj ( msgbox ) şeklinde çıkacaktır.
Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim YOL As String
If Intersect(Target, Range("A5:A999")) Is Nothing Then Exit Sub
YOL = ThisWorkbook.Path & "\"
Cells(Target.Row, "B") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R1C2")
Cells(Target.Row, "C") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R2C2")
Cells(Target.Row, "D") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R3C2")
Cells(Target.Row, "E") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R4C2")
Cells(Target.Row, "F") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R5C2")
Cells(Target.Row, "G") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R6C2")
Cells(Target.Row, "H") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R7C2")
Cells(Target.Row, "I") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R8C2")
Cells(Target.Row, "J") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R9C2")
Cells(Target.Row, "K") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R10C2")
Cells(Target.Row, "L") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R11C2")
Cells(Target.Row, "M") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R12C2")
Cells(Target.Row, "N") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R13C2")
Cells(Target.Row, "O") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R14C2")
Cells(Target.Row, "P") = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]DATA'!R15C2")
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim YOL As String
If Target.Column = 1 Then
If Intersect(Target, Range("A5:A999")) Is Nothing Then Exit Sub
YOL = ThisWorkbook.Path & "\"
Workbooks.Open (YOL & Target.Text & ".xlsx")
End If
If Target.Column = 15 And Target <> "" Then
If Intersect(Target, Range("O5:O999")) Is Nothing Then Exit Sub
MsgBox WorksheetFunction.VLookup(Target, Sayfa2.Range("A:B"), 2, 0)
End If
If Target.Column = 16 And Target <> "" Then
If Intersect(Target, Range("P5:P999")) Is Nothing Then Exit Sub
MsgBox WorksheetFunction.VLookup(Target, Sayfa2.Range("A:B"), 2, 0)
End If
End Sub

3. Sorununuz için ise = buradaki bilgilere bağlı olarak diğer kitaplardan bilgi çekecek sanırım. Bunun bir standardı var mı ?
Yoksa karışık olabilir mi ?
Kodu ona göre düzenleyeyim.
 
ardakose' Alıntı:
Belirli bir standart yok. Aynı sırada olması yeterli.
Genişletmek için tıkla ...

Bu kodu sayfanın kod bölümüne ekleyin ve deneyin.
Aynı sırada olmasına ve aynı uzunlukta olmasına dikkat edin.
Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim YOL As String, STR As Long
Application.ScreenUpdating = False
YOL = ThisWorkbook.Path & "\"
If Target.Column = 13 Then
If Intersect(Target, Range("M13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 13) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 14) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 18 Then
If Intersect(Target, Range("R13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 18) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 19) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 23 Then
If Intersect(Target, Range("W13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 23) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 24) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 28 Then
If Intersect(Target, Range("AB13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 28) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 29) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
Application.ScreenUpdating = True
End Sub
'Cells(Target.Row, "B") = Application.ExecuteExcel4Macro("'" & YOL _
& "[" & Target & "]DATA'!R1C2")
 
Teşekkür ederim istediğim gibi oldu. Bir yeri belirtmeyi unutmuşum. Ana dosyadan malzeme cinsini en boyunu da Sayı hücresinin sağına yazılan 2016_072 ye göre çekmem gerekiyordu. Gönderdiğiniz kodlara göre kendim uyarlamayı denicem. Tekrar teşekkürler.
 
Aşağıdaki kodu denedim ama çalışmadı. Yanlış nerde acaba.

Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim YOL As String, STR As Long
Application.ScreenUpdating = False
YOL = ThisWorkbook.Path & "\"
If Target.Column = 4 Then
If Intersect(Target, Range("D11")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "C").End(xlUp).Row
Cells(STR, 4) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C4")
Cells(STR, 5) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5")
Cells(STR, 6) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6")
Cells(STR, 7) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C7")
Cells(STR, 8) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C8")
Cells(STR, 9) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9")
Next
End If
If Target.Column = 13 Then
If Intersect(Target, Range("M13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 13) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 14) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 18 Then
If Intersect(Target, Range("R13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 18) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 19) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 23 Then
If Intersect(Target, Range("W13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 23) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 24) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 28 Then
If Intersect(Target, Range("AB13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 28) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 29) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
Application.ScreenUpdating = True
End Sub
'Cells(Target.Row, "B") = Application.ExecuteExcel4Macro("'" & YOL _
& "[" & Target & "]DATA'!R1C2")
 
Son düzenleme:
ardakose' Alıntı:
Teşekkür ederim istediğim gibi oldu. Bir yeri belirtmeyi unutmuşum. Ana dosyadan malzeme cinsini en boyunu da Sayı hücresinin sağına yazılan 2016_072 ye göre çekmem gerekiyordu. Gönderdiğiniz kodlara göre kendim uyarlamayı denicem. Tekrar teşekkürler.
Genişletmek için tıkla ...

Bunu anlamadım.
 
ardakose' Alıntı:
Aşağıdaki kodu denedim ama çalışmadı. Yanlış nerde acaba.

Kod: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim YOL As String, STR As Long
Application.ScreenUpdating = False
YOL = ThisWorkbook.Path & "\"
If Target.Column = 4 Then
If Intersect(Target, Range("D11")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "C").End(xlUp).Row
Cells(STR, 4) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C4")
Cells(STR, 5) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5")
Cells(STR, 6) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6")
Cells(STR, 7) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C7")
Cells(STR, 8) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C8")
Cells(STR, 9) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9")
Next
End If
If Target.Column = 13 Then
If Intersect(Target, Range("M13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 13) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 14) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 18 Then
If Intersect(Target, Range("R13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 18) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 19) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 23 Then
If Intersect(Target, Range("W13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 23) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 24) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
If Target.Column = 28 Then
If Intersect(Target, Range("AB13")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "D").End(xlUp).Row
Cells(STR, 28) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C10")
Cells(STR, 29) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C11")
Next
End If
Application.ScreenUpdating = True
End Sub
'Cells(Target.Row, "B") = Application.ExecuteExcel4Macro("'" & YOL _
& "[" & Target & "]DATA'!R1C2")
Genişletmek için tıkla ...

Ben deniyorum çalışıyor. O5 veya P5'e tıkladığınızda bilgiler mesaj kutusunda çıkıyor dosya ekte.
 

Ekli dosyalar

Mesaj ve diğer sizin eklediğiniz kodlar çalışıyor.
Ben kendim ilave olarak aşağıdaki kodları ekledim ama çalışmadı.
Kod: 
If Target.Column = 4 Then
If Intersect(Target, Range("D11")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "C").End(xlUp).Row
Cells(STR, 4) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C4")
Cells(STR, 5) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5")
Cells(STR, 6) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6")
Cells(STR, 7) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C7")
Cells(STR, 8) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C8")
Cells(STR, 9) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9")
Next
End If
 
ardakose' Alıntı:
Mesaj ve diğer sizin eklediğiniz kodlar çalışıyor.
Ben kendim ilave olarak aşağıdaki kodları ekledim ama çalışmadı.
Kod: 
If Target.Column = 4 Then
If Intersect(Target, Range("D11")) Is Nothing Then _
Application.ScreenUpdating = True: Exit Sub
For STR = 16 To Cells(40, "C").End(xlUp).Row
Cells(STR, 4) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C4")
Cells(STR, 5) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C5")
Cells(STR, 6) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C6")
Cells(STR, 7) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C7")
Cells(STR, 8) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C8")
Cells(STR, 9) = Application.ExecuteExcel4Macro("'" & YOL & "[" & Target & "]FORM'!R" & STR & "C9")
Next
End If
Genişletmek için tıkla ...

Burada ne yapmak istiyorsunuz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst