Farklı bir çalışma kitabından veri almak,hakkında...

[yesimgurol]

Merhabalar;

Ek te göndermiş olduğum dosyada iki farklı çalışma kitabım var ve yapmak istediğim ekte ki dosyada bulunan "Liste" adlı çalışma sayfasına,"ICP-MS HASTA KAYITT" adlı çalışma kitabından bilgi almak istiyorum.

Ekte bulunan "Liste" adlı çalışma kitabında da açıklama yapmaya çalıştım.

İlginize şimdiden teşekkür ederim.İYİ çalışmalar...

 

[yesimgurol]

:-( Sanırım benim açıklamam açıklayıcı olmadı:-(

 

[yesimgurol]

:-( olmuyor sanırım...

 

[Zeki Gürsoy]

"Düşeyara" fonksiyonu ile kolaylıkla yapılabilir. Makro olması şart mı?

 

[halit3]

Ekli liste.xlsm dosyasında J3-S3 aralığındaki bilgiler ile ICP-MS HASTA KAYITT.xls dosyasındaki A1-J1 aralığı aynı olmalı

not:
1-Bu yöntemin çalışması için veri alınacak dosyanın uzantısı .xls olmalı
2-her iki dosyadaki başlıklar aynı ve türkçe karekter ve boşluk içermemeli
3-hangi satıra ait veri alacaksanız imleç o satırdayken önceki sonuçları tara düğmesine tıklanacak
4-lazım olmayan ve gereksiz sütünlar gizlenmeli
5-veri dosyasındaki sayfa adı data olarak tanımlanmıştır.


uyarı:
buradaki çalışma .xlsm uzantılı bir dosyaya .xls uzantılı bir dosyadan veri alma işlemi yapılmıştır.

kod:

Sub verial()
dosya = ThisWorkbook.Path & "\" & "ICP-MS HASTA KAYITT.xls"
Sayfa_adı = "data"
yaz1 = ""
'On Error Resume Next
For i = 10 To 19
m = m + 1
If m = 1 Then
yaz1 = Cells(3, i).Value
Else
yaz1 = yaz1 & ", " & Cells(3, i).Value
End If
Next i
Dim Baglan As ADODB.Connection
Dim Kayit As ADODB.Recordset
Dim sira As Long

sat = ActiveWindow.Selection.Row

adsoyad = Cells(sat, 2).Value '"08032012-001"
son = "HASTANO"
sorgu = "SELECT " & yaz1 & " FROM [data$] where " & son & "=" & """" & adsoyad & """"
Set Baglan = New ADODB.Connection
'Baglan.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & dosya & ";Extended Properties=""Excel 8.0;HDR=yes""" 'ofis 2003
Baglan.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & dosya & ";Extended Properties=""Excel 12.0;HDR=yes""" 'ofis 2007
Set Kayit = New ADODB.Recordset
Kayit.Open sorgu, Baglan, adOpenKeyset, adLockOptimistic
If Not Kayit.EOF Then
For j = 1 To 10
Cells(sat, j + 9).Value = ""
'MsgBox Kayit.Fields(j)   '(Cells(i, j).Value)
Cells(sat, j + 9).Value = Kayit.Fields(j - 1)
Next j
End If
Kayit.Update
Kayit.Close
Set Kayit = Nothing
Baglan.Close
Set Baglan = Nothing
sira = Empty
 
End Sub

 

[halit3]

Buda .xlsb uzantılı dosyadan veri alıyor.

 

[yesimgurol]

Sayın Zeki Gürsoy Hocam; ilginize, fikrinize teşekkür ederim."Düşeyara" formülü ile yapılabilse dahi inanın pek bilgim yok o konuda:-( ama yinede teşekkür ederim gerçekten...

Sizden sonra Saolsun Halit3 hocam ilgilenmiş kod yazmış nasıl sevindim bilemezsiniz çok da güzel olmuş,benim için önemi büyük inanın büyük bir yükten kurtulacağım inşaallah sayesinde..
Yalnız bir isteğim olacak; Sayın Halit3 hocam "5" nolu mesajında not kısmındaki "3"nolu maddesinde,

"3-hangi satıra ait veri alacaksanız imleç o satırdayken önceki sonuçları tara düğmesine tıklanacak"

..şeklinde açıklama yapmışsınız,evet denedim çok güzel bir şekilde çalışıyor kodlar..
liste de yaklaşık 200 e yakın hasta ismi olacak."ÖNCEKİ SONUÇLARI TARA" butonuna tıkladığımda imlecin olduğu satırı değil de listede ki tüm bilgileri tarasa olmaz mı acaba?

 

[halit3]

Sayın Zeki Gürsoy Hocam; ilginize, fikrinize teşekkür ederim."Düşeyara" formülü ile yapılabilse dahi inanın pek bilgim yok o konuda:-( ama yinede teşekkür ederim gerçekten...

Sizden sonra Saolsun Halit3 hocam ilgilenmiş kod yazmış nasıl sevindim bilemezsiniz çok da güzel olmuş,benim için önemi büyük inanın büyük bir yükten kurtulacağım inşaallah sayesinde..
Yalnız bir isteğim olacak; Sayın Halit3 hocam "5" nolu mesajında not kısmındaki "3"nolu maddesinde,

"3-hangi satıra ait veri alacaksanız imleç o satırdayken önceki sonuçları tara düğmesine tıklanacak"

..şeklinde açıklama yapmışsınız,evet denedim çok güzel bir şekilde çalışıyor kodlar..
liste de yaklaşık 200 e yakın hasta ismi olacak."ÖNCEKİ SONUÇLARI TARA" butonuna tıkladığımda imlecin olduğu satırı değil de listede ki tüm bilgileri tarasa olmaz mı acaba?

Bunu birinci mesajınızda belirtseydiniz kodu revize etmeye gerek kalmazdı.
Ben sorunuzdan anladığım kadarı ile kodları yazmaya çalışıyorum.

not:Ana dosyada J3-S3 hücrelerindeki bilgilere gerek kalmadı.

kod:

Sub verial()
On Error Resume Next
yaz1 = ""
klasörünadi = ThisWorkbook.Path
Dosya = klasörünadi & "\" & "ICP-MS HASTA KAYITT.xlsb"
dosyaninadi = "ICP-MS HASTA KAYITT.xlsb"
Sayfa_adı = "data"
sut = Application.ExecuteExcel4Macro("COUNTA('" & klasörünadi & "\[" & dosyaninadi & "]data'!R1)")
deg = "'" & klasörünadi & "\" & "[" & dosyaninadi & "]" & Sayfa_adı & "'!R"
For m = 1 To sut
r = r + 1
If r = 1 Then
yaz1 = ExecuteExcel4Macro(deg & 1 & "C" & m)
Else
yaz1 = yaz1 & ", " & ExecuteExcel4Macro(deg & 1 & "C" & m)
End If
Next m
Dim Baglan As ADODB.Connection
Dim Kayit As ADODB.Recordset
For i = 4 To Cells(Rows.Count, "B").End(3).Row
adsoyad = Cells(i, 2).Value
son = "HASTANO"
sorgu = "SELECT " & yaz1 & " FROM [data$] where " & son & "=" & """" & adsoyad & """"
Set Baglan = New ADODB.Connection
'Baglan.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & dosya & ";Extended Properties=""Excel 8.0;HDR=yes""" 'ofis 2003
Baglan.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & Dosya & ";Extended Properties=""Excel 12.0;HDR=yes""" 'ofis 2007
Set Kayit = New ADODB.Recordset
Kayit.Open sorgu, Baglan, adOpenKeyset, adLockOptimistic
If Not Kayit.EOF Then
For j = 1 To 10
Cells(i, j + 9).Value = ""
Cells(i, j + 9).Value = Kayit.Fields(j - 1)
Next j
End If
Next i
Kayit.Update
Kayit.Close
Set Kayit = Nothing
Baglan.Close
Set Baglan = Nothing

MsgBox "işlem tamam"
End Sub

 

[yesimgurol]

Sayın Halit3 Hocam , cevabınızı bu kadar çabuk beklemiyordum..Çok teşekkür ederim..Evet Sanırım eksik anlattım ben ilk mesajımda..
Bu arada "8" nolu mesajınızdaki kodları ben "5" nolu mesajınızdaki liste.xls çalışma kitabına yapıştırmaya çalıştım ama başaramadım sanırım:-( Butona tıkladığımda güncelleştirilecek dosya seçmem için pencere açılıyor ve o pencereyi kapatamıyorum bir türlü yanlış yapıyorum o yüzden...
Biliyorum çok oluyorum ama acaba vaktiniz varsa tabı ki,5 nolu mesajınızdaki dosyayı son yazdığınız kodla güncelleyebilirmisiniz:-(

 

[halit3]

Sayın Halit3 Hocam , cevabınızı bu kadar çabuk beklemiyordum..Çok teşekkür ederim..Evet Sanırım eksik anlattım ben ilk mesajımda..
Bu arada "8" nolu mesajınızdaki kodları ben "5" nolu mesajınızdaki liste.xls çalışma kitabına yapıştırmaya çalıştım ama başaramadım sanırım:-( Butona tıkladığımda güncelleştirilecek dosya seçmem için pencere açılıyor ve o pencereyi kapatamıyorum bir türlü yanlış yapıyorum o yüzden...
Biliyorum çok oluyorum ama acaba vaktiniz varsa tabı ki,5 nolu mesajınızdaki dosyayı son yazdığınız kodla güncelleyebilirmisiniz:-(

6 nolu mesajdaki dosya içindi kodlar. yani .xlsb uzantılı dosya içindi
Dosya ekte

 

[yesimgurol]

Sayın Halit3 Hocam,inanın çoook teşekkür ederim.Gerçekten güzel olmuş..
Bu arada ".xlsb" uzantılı dosyanın excel sayfasından farkı nedir? Yani o dosyaya ben hasta bilgilerini gireceğimden normal excel sayfasından farkını öğrenmek adına sormuştum..Benim için dezavantıjı olur mu?

 

[halit3]

Sayın Halit3 Hocam,inanın çoook teşekkür ederim.Gerçekten güzel olmuş..
Bu arada ".xlsb" uzantılı dosyanın excel sayfasından farkı nedir? Yani o dosyaya ben hasta bilgilerini gireceğimden normal excel sayfasından farkını öğrenmek adına sormuştum..Benim için dezavantıjı olur mu?

Buraya eklemiş olduğun ICP-MS HASTA KAYITT.xlsx dosya ofis 2007 ve üstünde çalışan dosya bu dosyada okuma işlemi yapılamıyor bende bu dosyayı açtım ve farklı kayıt seçeneklerinden excel ikili çalışma kitabı olarak kayıt yaptım. ve uzantısı .xlsb oldu.

Bunu tıpkı şöyle düşünün .xlsx dosya içinde makro varsa bu dosyayı kayıt yapamazsınız kayıt yaptığınızda makrolar silinecektir ama farklı kayıt yaparak .xlsm ye çevrilirse işlem görecektir.

diğer taraftan kodun içine girip bakarsanız kodun bir bölümü yeşil olarak gözüküyor o bölümü aktif edip alttaki bölümü pasif ederseniz ve en yukarıdada dosya adına ait .xlsb bu uzantıyı .xls olarak değiştirirseniz ofis 2003 formatında çalışacaktır.

Sözün kısası ofis 2007 ve üzeri için durum böyle

Buda ofis 2003 için:

Sub verial()
On Error Resume Next
yaz1 = ""
klasörünadi = ThisWorkbook.Path
dosyaninadi = "ICP-MS HASTA KAYITT.xls"
dosya = klasörünadi & "\" & dosyaninadi
Sayfa_adı = "data"
sut = Application.ExecuteExcel4Macro("COUNTA('" & klasörünadi & "\[" & dosyaninadi & "]data'!R1)")
deg = "'" & klasörünadi & "\" & "[" & dosyaninadi & "]" & Sayfa_adı & "'!R"
For m = 1 To sut
r = r + 1
If r = 1 Then
yaz1 = ExecuteExcel4Macro(deg & 1 & "C" & m)
Else
yaz1 = yaz1 & ", " & ExecuteExcel4Macro(deg & 1 & "C" & m)
End If
Next m
Dim Baglan As ADODB.Connection
Dim Kayit As ADODB.Recordset
For i = 4 To Cells(Rows.Count, "B").End(3).Row
adsoyad = Cells(i, 2).Value
son = "HASTANO"
sorgu = "SELECT " & yaz1 & " FROM [data$] where " & son & "=" & """" & adsoyad & """"
Set Baglan = New ADODB.Connection
Baglan.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & dosya & ";Extended Properties=""Excel 8.0;HDR=yes""" 'ofis 2003
'Baglan.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & dosya & ";Extended Properties=""Excel 12.0;HDR=yes""" 'ofis 2007
Set Kayit = New ADODB.Recordset
Kayit.Open sorgu, Baglan, adOpenKeyset, adLockOptimistic
If Not Kayit.EOF Then
For j = 1 To 10
Cells(i, j + 9).Value = ""
Cells(i, j + 9).Value = Kayit.Fields(j - 1)
Next j
End If
Next i
Kayit.Update
Kayit.Close
Set Kayit = Nothing
Baglan.Close
Set Baglan = Nothing
 
MsgBox "işlem tamam"
End Sub

 

[yesimgurol]

Çok teşekkür ederim Sayın Halit3 Hocam..İnanın çok yardımcı oldunuz.İyi çalışmalar..