- Katılım
- 12 Ekim 2021
- Mesajlar
- 91
- Excel Vers. ve Dili
- Türkçe
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Hocam LIST sayfasında her satırda ürün bilgileri var. D sutununda ise o ürünün hangi kategoride olduğu yazıyor. Amacım D sutunundaki kategori isimlerini sayfalara aktarmasını istiyorum. Örneğin LIST sayfasındaki D sütununda "A KATEGORİSİ" yazan satırları A KATEGORİSİ sayfasına, "B KATEGORİSİ" yazanları B KATEGORİSİ sayfalarına aktarmasını istiyorum. İlginiz için teşekkür ederimMerhaba,
Aktar diye istekte bulunuyorsunuz ama A katorisi dediğiniz şey nedir? Veri içinde kategori diye bir seçenek göremedim.
Sub Aktar()
Dim Syf As Worksheet
Set Syf = Sheets(Application.Caller)
'Referanslardan Microsoft Activex Data Objects 6.1 (veya daha fazlası) Library Seçili olmalı
On Error Resume Next
Dim connection As New ADODB.connection
Dim filename As String
Dim query As String
Dim rs As New ADODB.Recordset
Dim Kol As Integer
Dim i As Integer
query = "SELECT * FROM [LIST$] WHERE [KATEGORİ ADI] = '" & Application.Caller & "'"
filename = ThisWorkbook.FullName
connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & filename & _
";Extended Properties=""Excel 12.0;HDR=Yes;"";"
rs.Open query, connection
Dim tbl As Range
Set tbl = Syf.Range("A1").CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).ClearContents
Syf.Range("A2").CopyFromRecordset rs
connection.Close
End Sub
Hocam elinize sağlık çok güzel olmuş teşekkür ederimMerhaba,
İdris Bey yol göstermiş.
ADO ile çözüm. Diktörtgen şekillerinin isimlerini inceleyiniz.
Kod:Sub Aktar() Dim Syf As Worksheet Set Syf = Sheets(Application.Caller) 'Referanslardan Microsoft Activex Data Objects 6.1 (veya daha fazlası) Library Seçili olmalı On Error Resume Next Dim connection As New ADODB.connection Dim filename As String Dim query As String Dim rs As New ADODB.Recordset Dim Kol As Integer Dim i As Integer query = "SELECT * FROM [LIST$] WHERE [KATEGORİ ADI] = '" & Application.Caller & "'" filename = ThisWorkbook.FullName connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & filename & _ ";Extended Properties=""Excel 12.0;HDR=Yes;"";" rs.Open query, connection Dim tbl As Range Set tbl = Syf.Range("A1").CurrentRegion tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).ClearContents Syf.Range("A2").CopyFromRecordset rs connection.Close End Sub
çok teşekkür ederim idris bey
Hocak bu kodun içerisinde dikdörtgen isimlerinin geçtiği yer neresidir bilgi verebilir misinizMerhaba,
İdris Bey yol göstermiş.
ADO ile çözüm. Diktörtgen şekillerinin isimlerini inceleyiniz.
Kod:Sub Aktar() Dim Syf As Worksheet Set Syf = Sheets(Application.Caller) 'Referanslardan Microsoft Activex Data Objects 6.1 (veya daha fazlası) Library Seçili olmalı On Error Resume Next Dim connection As New ADODB.connection Dim filename As String Dim query As String Dim rs As New ADODB.Recordset Dim Kol As Integer Dim i As Integer query = "SELECT * FROM [LIST$] WHERE [KATEGORİ ADI] = '" & Application.Caller & "'" filename = ThisWorkbook.FullName connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & filename & _ ";Extended Properties=""Excel 12.0;HDR=Yes;"";" rs.Open query, connection Dim tbl As Range Set tbl = Syf.Range("A1").CurrentRegion tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).ClearContents Syf.Range("A2").CopyFromRecordset rs connection.Close End Sub
Set Syf = Sheets(Application.Caller)
Hocam harika bir çalışma ayakta alkışlıyorum bu çalışmayı nasıl yaptığınıza dair bir video veya eğitim mevcut mudurMerhaba,
Tüm şekillere aynı makro atandı.
Hangi şekle tıklandığını :
Kod:Set Syf = Sheets(Application.Caller)
kod ile öğreniyoruz. Şeklin adı aynı zamanda istenen ve aynı zamanda sayfa adı oluyor.
Tavsiyeniz doğrultusunda çalışmalarıma devam edeceğim çok teşekkür emeğinizeMevcut değildir, biraz işin pratiğine kaçtım.
Aslında Ben olsam 3 tane buton yerine ya inputbox ile ya da form düzenleyerek combobox ile listelenecek sayfayı alırdım.
Sizin öneriniz doğrultusunda bu atraksiyonu yaptım.
hocam bi sorum olacak örneğin A kategorinde olanları tümüyle ( A sütunundan I sütünuna kadar) A KATEGORİSİ sayfasına atıyor. Ben sadece A Kategorisi nde olanları tümüyle değil de --> kategori adı (D), ürün ismi (G) ve gideceği yer (I) bilgilerini aktarmasını istersem nasıl yol izleyebilirimMevcut değildir, biraz işin pratiğine kaçtım.
Aslında Ben olsam 3 tane buton yerine ya inputbox ile ya da form düzenleyerek combobox ile listelenecek sayfayı alırdım.
Sizin öneriniz doğrultusunda bu atraksiyonu yaptım.
query = "SELECT * FROM [LIST$] WHERE [KATEGORİ ADI] = '" & Application.Caller & "'"
query = "SELECT [KATEGORİ ADI], [ÜRÜN İSMİ],[GİDECEĞİ YER] FROM [LIST$] WHERE [KATEGORİ ADI] = '" & Application.Caller & "'"
Çok teşekkür ediyorum hocam sayenizde öğreniyorumMerhaba,
Koddaki :
Kod:query = "SELECT * FROM [LIST$] WHERE [KATEGORİ ADI] = '" & Application.Caller & "'"
* tüm bilgiyi demektir.
Aşağıdaki gibi kullanın :
Kod:query = "SELECT [KATEGORİ ADI], [ÜRÜN İSMİ],[GİDECEĞİ YER] FROM [LIST$] WHERE [KATEGORİ ADI] = '" & Application.Caller & "'"
Yani hangi sütünu istiyorsak o sütun başlığını köşeli parantez içinde veriyoruz, çünkü arada boşluk karakteri olduğu için.
Örneğin sadece AD başlığı olsaydı bunu köşeli parantez içine almak gerekmezdi.
hocam son bi sorum olacak sadece projem bitiyor. Verdiğiniz kod doğrultusunda her şey sorunsuz çalışıyor. Kategori adı, Ürün ismi ve Gideceği yer sütunlarını Syf.Range("A2").CopyFromRecordset rs getiriyor. Kategori adı'nı G2 ye, Ürün İsmini D2 ye ve son olarak Gideceği yer' i I2 ye nasıl getirebilirim bir çok yol denedim ama başaramadım.Merhaba,
Koddaki :
Kod:query = "SELECT * FROM [LIST$] WHERE [KATEGORİ ADI] = '" & Application.Caller & "'"
* tüm bilgiyi demektir.
Aşağıdaki gibi kullanın :
Kod:query = "SELECT [KATEGORİ ADI], [ÜRÜN İSMİ],[GİDECEĞİ YER] FROM [LIST$] WHERE [KATEGORİ ADI] = '" & Application.Caller & "'"
Yani hangi sütünu istiyorsak o sütun başlığını köşeli parantez içinde veriyoruz, çünkü arada boşluk karakteri olduğu için.
Örneğin sadece AD başlığı olsaydı bunu köşeli parantez içine almak gerekmezdi.
Sub Aktar()
Dim Syf As Worksheet
Set Syf = Sheets(Application.Caller)
'Referanslardan Microsoft Activex Data Objects 6.1 (veya daha fazlası) Library Seçili olmalı
Dim connection As New ADODB.connection
Dim filename As String
Dim query As String
Dim rs As New ADODB.Recordset
Dim Kol As Integer
Dim i As Long
query = "SELECT [KATEGORİ ADI], [ÜRÜN İSMİ],[GİDECEĞİ YER] FROM [LIST$] WHERE [KATEGORİ ADI] = '" & Application.Caller & "'"
filename = ThisWorkbook.FullName
connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & filename & _
";Extended Properties=""Excel 12.0;HDR=Yes;"";"
rs.Open query, connection
' Syf.Range("A2").CopyFromRecordset rs.Fields(3)
i = 2
With rs
Do Until .EOF
Debug.Print rs.Fields(1) & " " & rs.Fields(0) & " " & rs.Fields(2)
Syf.Range("D" & i) = rs.Fields(1) 'Ürün İsmi
Syf.Range("G" & i) = rs.Fields(0) 'Kategori Adı
Syf.Range("I" & i) = rs.Fields(2) 'Gideceği Yer
.MoveNext
i = i + 1
Loop
End With
connection.Close
End Sub
hocam gerçekten siz bir dahisiniz ellerinize sağlık çok teşekkür ediyorum muhteşemsinizMerhaba,
RecordSet'in belirli sütunlarını almak hiç aklıma gelmemişti, araştırdık bulduk
Kod:Sub Aktar() Dim Syf As Worksheet Set Syf = Sheets(Application.Caller) 'Referanslardan Microsoft Activex Data Objects 6.1 (veya daha fazlası) Library Seçili olmalı Dim connection As New ADODB.connection Dim filename As String Dim query As String Dim rs As New ADODB.Recordset Dim Kol As Integer Dim i As Long query = "SELECT [KATEGORİ ADI], [ÜRÜN İSMİ],[GİDECEĞİ YER] FROM [LIST$] WHERE [KATEGORİ ADI] = '" & Application.Caller & "'" filename = ThisWorkbook.FullName connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & filename & _ ";Extended Properties=""Excel 12.0;HDR=Yes;"";" rs.Open query, connection ' Syf.Range("A2").CopyFromRecordset rs.Fields(3) i = 2 With rs Do Until .EOF Debug.Print rs.Fields(1) & " " & rs.Fields(0) & " " & rs.Fields(2) Syf.Range("D" & i) = rs.Fields(1) 'Ürün İsmi Syf.Range("G" & i) = rs.Fields(0) 'Kategori Adı Syf.Range("I" & i) = rs.Fields(2) 'Gideceği Yer .MoveNext i = i + 1 Loop End With connection.Close End Sub