Kitaplar arası veri paylaşımı veri çekimi

[onurcan1979]

Merhaba arkadaşlar kitaplar arası veri paylaşımı ve veri çekimi ile ilgili yarıma ihtiyacım var formdaki bilgileri inceledim ama işime yarayanı bulamadım.

iistediğim

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("M5:M65536")) Is Nothing Then Exit Sub
Dim ts, kaplan
kaplan = 5
For ts = 5 To Cells(65536, "M").End(xlUp).Row
If Cells(ts, "M") = "OK" Then
Sheets("Archive").Cells(kaplan, "A") = Cells(ts, "A")
Sheets("Archive").Cells(kaplan, "B") = Cells(ts, "B")
Sheets("Archive").Cells(kaplan, "C") = Cells(ts, "C")
Sheets("Archive").Cells(kaplan, "D") = Cells(ts, "D")
Sheets("Archive").Cells(kaplan, "E") = Cells(ts, "E")
Sheets("Archive").Cells(kaplan, "F") = Cells(ts, "F")
Sheets("Archive").Cells(kaplan, "G") = Cells(ts, "G")
Sheets("Archive").Cells(kaplan, "H") = Cells(ts, "H")
Sheets("Archive").Cells(kaplan, "I") = Cells(ts, "I")
Sheets("Archive").Cells(kaplan, "J") = Cells(ts, "J")
Sheets("Archive").Cells(kaplan, "K") = Cells(ts, "K")
Sheets("Archive").Cells(kaplan, "L") = Cells(ts, "L")
Sheets("Archive").Cells(kaplan, "M") = Cells(ts, "M")
kaplan = kaplan + 1
End If
Next
End Sub
bunun gibi ama kitaplar arası yapacak sayfalar arası değil. benim belirleyeceğim sütundaki verileri aktaracak sadece bu kısım If Cells(ts, "M") = "OK" Then
olmayacak belirlenen hücredeki veriyi süzerek aktaracak bu konuda yardım ederseniz

 

[Orion1]

Dosyanız ektedir.

Sub veri_al_ado_59()
'TOOLS referenceden microsoft data object activeX 2.x Library seçildi.
'Coder : evrengizlen@hotmail.com
'29.12.2011
Dim conn  As ADODB.Connection, rs As ADODB.Recordset
Application.ScreenUpdating = False
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
ThisWorkbook.Activate
Range("A2:I" & Rows.Count).ClearContents
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\PERSONEL VERI.xls;extended properties=""excel 8.0;hdr=no;imex=1"";"
rs.Open "select * from [Sayfa1$A2:I65536];", conn, adOpenKeyset, adLockReadOnly
Range("A2").CopyFromRecordset rs
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler Alındı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[onurcan1979]

evren bey elinizie sağlık
bu veri alışını mesela A,C,E,F,Z sütunları gibi sınırlama şansımız varmı?

Dosyanız ektedir.

Sub veri_al_ado_59()
'TOOLS referenceden microsoft data object activeX 2.x Library seçildi.
'Coder : evrengizlen@hotmail.com
'29.12.2011
Dim conn  As ADODB.Connection, rs As ADODB.Recordset
Application.ScreenUpdating = False
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
ThisWorkbook.Activate
Range("A2:I" & Rows.Count).ClearContents
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\PERSONEL VERI.xls;extended properties=""excel 8.0;hdr=no;imex=1"";"
rs.Open "select * from [Sayfa1$A2:I65536];", conn, adOpenKeyset, adLockReadOnly
Range("A2").CopyFromRecordset rs
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler Alındı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[onurcan1979]

evren bey elinizie sağlık
bu veri alışını mesela A,C,E,F,Z sütunları gibi sınırlama şansımız varmı?

ve F sutunundaki veriye göre süzüp aktarması gerek

 

[Orion1]

ve F sutunundaki veriye göre süzüp aktarması gerek

Dosyanız ektedir.
F sütununda neye göre sorgulanacak?

Sub veri_al_ado_59()
'TOOLS referenceden microsoft data object activeX 2.x Library seçildi.
'Coder : evrengizlen@hotmail.com
'29.12.2011
Dim conn  As ADODB.Connection, rs As ADODB.Recordset
Application.ScreenUpdating = False
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
ThisWorkbook.Activate
Range("A2:I" & Rows.Count).ClearContents
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\PERSONEL VERI.xls;extended properties=""excel 8.0;hdr=no;imex=1"";"
rs.Open "select F1,F3,F5,F6,F26 from [Sayfa1$A2:Z65536];", conn, adOpenKeyset, adLockReadOnly
Range("A2").CopyFromRecordset rs
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler Alındı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[onurcan1979]

Dosyanız ektedir.
F sütununda neye göre sorgulanacak?

Sub veri_al_ado_59()
'TOOLS referenceden microsoft data object activeX 2.x Library seçildi.
'Coder : evrengizlen@hotmail.com
'29.12.2011
Dim conn  As ADODB.Connection, rs As ADODB.Recordset
Application.ScreenUpdating = False
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
ThisWorkbook.Activate
Range("A2:I" & Rows.Count).ClearContents
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\PERSONEL VERI.xls;extended properties=""excel 8.0;hdr=no;imex=1"";"
rs.Open "select F1,F3,F5,F6,F26 from [Sayfa1$A2:Z65536];", conn, adOpenKeyset, adLockReadOnly
Range("A2").CopyFromRecordset rs
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler Alındı." & vbLf & "evrengizlen@hotmail.com"
End Sub

bulunduğu projeye göre süzülecek ve ve belirlenen sütunlardaki verileri aktaracak

 

[Orion1]

bulunduğu projeye göre süzülecek ve ve belirlenen sütunlardaki verileri aktaracak

Bunu açıklamanız lazım.
Bulunduğu proje 1 den çok.
Hangi projeyi seçecek.
Belediyemi yoksa diğerlerinden birimi?

 

[Orion1]

Böylemi olacak.

Sub veri_al_ado_59()
'TOOLS referenceden microsoft data object activeX 2.x Library seçildi.
'Coder : evrengizlen@hotmail.com
'29.12.2011
Dim conn  As ADODB.Connection, rs As ADODB.Recordset
Application.ScreenUpdating = False
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
ThisWorkbook.Activate
Range("A2:G" & Rows.Count).ClearContents
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\PERSONEL VERI.xls;extended properties=""excel 8.0;hdr=no;imex=1"";"
rs.Open "select first(F1),first(F3),first(F5),F6,count(F6),first(F26) from [Sayfa1$A2:Z65536] group by F6;", conn, adOpenKeyset, adLockReadOnly
Range("A2").CopyFromRecordset rs
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler Alındı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[onurcan1979]

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("M5:M65536")) Is Nothing Then Exit Sub
Dim ts, kaplan
kaplan = 5
For ts = 5 To Cells(65536, "M").End(xlUp).Row
If Cells(ts, "M") = "OK" Then
Sheets("Archive").Cells(kaplan, "A") = Cells(ts, "A")
Sheets("Archive").Cells(kaplan, "B") = Cells(ts, "B")
Sheets("Archive").Cells(kaplan, "C") = Cells(ts, "C")
Sheets("Archive").Cells(kaplan, "D") = Cells(ts, "D")
Sheets("Archive").Cells(kaplan, "E") = Cells(ts, "E")
Sheets("Archive").Cells(kaplan, "F") = Cells(ts, "F")
Sheets("Archive").Cells(kaplan, "G") = Cells(ts, "G")
Sheets("Archive").Cells(kaplan, "H") = Cells(ts, "H")
Sheets("Archive").Cells(kaplan, "I") = Cells(ts, "I")
Sheets("Archive").Cells(kaplan, "J") = Cells(ts, "J")
Sheets("Archive").Cells(kaplan, "K") = Cells(ts, "K")
Sheets("Archive").Cells(kaplan, "L") = Cells(ts, "L")
Sheets("Archive").Cells(kaplan, "M") = Cells(ts, "M")
kaplan = kaplan + 1
End If
Next
End Sub

eren bey; yukardaki gibi benim belirleyeceğim sürunda süzsün fakat aşağıda belirttiğim süzülecek olanın hücre içinde yazacağım veriyi süzsün

For ts = 5 To Cells(65536, "M").End(xlUp).Row
If Cells(ts, "M") = "OK" Then

Böylemi olacak.

Sub veri_al_ado_59()
'TOOLS referenceden microsoft data object activeX 2.x Library seçildi.
'Coder : evrengizlen@hotmail.com
'29.12.2011
Dim conn  As ADODB.Connection, rs As ADODB.Recordset
Application.ScreenUpdating = False
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
ThisWorkbook.Activate
Range("A2:G" & Rows.Count).ClearContents
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\PERSONEL VERI.xls;extended properties=""excel 8.0;hdr=no;imex=1"";"
rs.Open "select first(F1),first(F3),first(F5),F6,count(F6),first(F26) from [Sayfa1$A2:Z65536] group by F6;", conn, adOpenKeyset, adLockReadOnly
Range("A2").CopyFromRecordset rs
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler Alındı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[Orion1]

Dosyanız ektedir.
Bakın benim yazdığım kodlar sizin bana verdiğiniz kodlardan 10 kat-20 kat hızlı çalışır.
Belki 1000 -2000 satırda anlamazsınız ama 40 bin - 50 bin satırda çok net farkedilir durum.
Siz baştan bana M sütununda OK varsa onları süzelim deseydiniz bu kdar boş yere kürek çekmezdik.
Şimdi söyled,ğinize göre M sütunda OK olanlar süzülecek.bende ona göre yaptım.
Sakın yine başka olacak demeyin.BU yaptığım sondur.Başka yapmam.
Dosyanız ektedir.

Sub veri_al_ado_59()
'TOOLS referenceden microsoft data object activeX 2.x Library seçildi.
'Coder : evrengizlen@hotmail.com
'29.12.2011
Dim conn  As ADODB.Connection, rs As ADODB.Recordset
Application.ScreenUpdating = False
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
ThisWorkbook.Activate
Range("A2:G" & Rows.Count).ClearContents
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\PERSONEL VERI.xls;extended properties=""excel 8.0;hdr=no;imex=1"";"
rs.Open "select F1,F3,F5,F6,F13,F26 from [Sayfa1$A2:Z65536] where UCASE(F13)='OK';", conn, adOpenKeyset, adLockReadOnly
Range("A2").CopyFromRecordset rs
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler Alındı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[onurcan1979]

arkadaşlar orionu kızdırdım ama ben sanırım ne istediğimi anlatamadım. ben bir kitabta bulunan verileri macro ile süzüp başka kitaba kaydetmesi bunu yaparken a sütununda a sütununa değilde. yani personel veri dosyasının içindeki sayfa1 deki "a" sütununu proje işlemin içindeki sayfa1 deki "b" sütununa aktarsın gibi ve hangi sütunların nereye aktaracağını belirleye bileceğim ve süzülmesi gerekeni mesela proje işlem dosyasındaki sayfa1 in içindeki 'f1' hücresine gireceğim bir veriden yapmasını istiyorum. umarım bu sefer anlata bilmişimdir. çünkü bu işleme çok acil ihtiyacımvar eğer mümkünse yardımcı olmanız dileğiyle. şimdiden teşekkürler yeni yılınız kutlu olsun

 

[onurcan1979]

iyi çalışmalar

 

[onurcan1979]

İyi günler arkadaşlar yardım edecek bir arkadaş yokmu bana bu konuda

 

[onurcan1979]

iyi akşamlar

 

[Esteban34]

Sayın Orion,

ADO ile klasör içinde 1 den fazla (100-200 ) dosyadan istenilen hücreleri çekme imkanı varmıdır.Tek dosya için İşlem çok hızlı valla.

 

[Orion1]

Sayın Orion,

ADO ile klasör içinde 1 den fazla (100-200 ) dosyadan istenilen hücreleri çekme imkanı varmıdır.Tek dosya için İşlem çok hızlı valla.

excelde vt yerleşimi uygunsa ado ile olur,değilse dağınık ise excel makro4 ile olur.

 

[.ayaz.]

İki excel sayfasını karşılaştırma

Merhaba,

iki çalışma sayfam var taşeron firmalarla ilgili 1.excel sayfasındaki ad ve soyadlarla 2.excel dosyasındaki ad soyadlar eşitse 3. excel sayfasına ad soyad ve ek olarak tc kimlik numalarının eklenmesini istiyorum nasıl bir yol izleyebilirim.
Dosyalarım ektedir.

Yardımcı olursanız çok memnun olurum.

 

[Orion1]

Merhaba,

iki çalışma sayfam var taşeron firmalarla ilgili 1.excel sayfasındaki ad ve soyadlarla 2.excel dosyasındaki ad soyadlar eşitse 3. excel sayfasına ad soyad ve ek olarak tc kimlik numalarının eklenmesini istiyorum nasıl bir yol izleyebilirim.
Dosyalarım ektedir.

Yardımcı olursanız çok memnun olurum.

Bu başlıktaki soru çözüldü.
Siz yeni bir başlık açarak sorunuzu sorarsanız karmaşıklık olmayacaktır.
Kolay gelsin.

 

[.ayaz.]

peki teşekkürler yeni konu açtım

 

[Esteban34]

excelde vt yerleşimi uygunsa ado ile olur,değilse dağınık ise excel makro4 ile olur.

Üstat uygulaman çok hızlı bu konuda makro ile yaklaşık 900 dosyadan herbirisinden yerleri aynı olacak şekilde 90 a yakın veri çekiyorum. ancak süre çok uzun oluyor. Bazen 15 dk yı bile buluyor.
Bu konuda yardımın olabilir mi.*


Excel vt yerleşimi ne demek?