Bağlantılı excellerde koşullu veri çekmek

[bordo6181]

Merhabalar

Öncelikle forumda çok yardımsever insan var herkese teşekkür ederim ve @hmtstc 'nin sayesinde mükemmel bir excel programına sahip oldum.

Ancak exceli hem kendim öğrenmek için hemde bazı yerlerini değiştirmek amacıyla kurcalarken bozdum.

Mantık olarak şöyle çalışan 5 excelim var. Hepsi ortak ağ üzerinde aynı klasör içinde birkaç farklı kişinin erişebileceği farklı şifrelerde olacak.

Kayıt Exceli
Lab Exceli ( 3 adet )
Rapor Exceli

Kayıt exceline girdiğim bazı verileri Lab Excelinde sorgula tuşuna basınca o excelden çekecek, Rapor exceli de sorgula tuşuna basınca diğer iki excelden çekecek. tabi farklı kişiler çalıştığından program karşı tarafta açık olabilir o konuda nasıl bir kontrol yapılabilir bilmiyorum.

Kayıt Exceli - Lab Exceli arasındaki veri aktarım Kriterimiz
Lab Adı a lab ise gerekli bilgileri Kayıt Excelinden A Lab exceline at
Lab adı b lab ise gerekli bilgileri Kayıt Excelinden B Lab exceline at

Rapor Exceli Kriterimiz örneğin A lab excelinde satırda herhangi bir deneyde Test Durumu : Tamamlandı yazarsa o deneyin tüm verilerini
Kayıt Exceli - Lab Excelinden al Rapor exceline at şeklinde çalışacak

Örnek exceller ektedir.
Teşekkürler.

 

[bordo6181]

Benim soru gözden kaçmış

 

[bordo6181]

Konu güncel

 

[bordo6181]

Sub sorgulamayeni()
Dim son As Long, Dosya_Acikmi As Workbook
Dim target1 As String
eski = WorksheetFunction.Max(3, Cells(Rows.Count, "F").End(3).Row)
ActiveSheet.Unprotect "excelwebtr*"
yol = ThisWorkbook.Path
targeta = "* LAB"
hedefkitap = "*.xlsm"

On Error Resume Next
Set Dosya_Acikmi = Workbooks(hedefkitap)
On Error GoTo 0
If Not Dosya_Acikmi Is Nothing Then Application.Run "'*.xlsm'!cıkısyap"
tümü = yol & "\" & hedefkitap
son = "1048576"
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & tümü & ";extended properties=""Excel 12.0;hdr=No"""

sondeger = Cells(Cells(Rows.Count, 1).End(3).Row, 1)
If sondeger = "Kayıt No" Then
sonkulsatır = 3
GoTo 44765
End If

sut = 1
For f = 4 To 50000
satırcık = Application.ExecuteExcel4Macro("'" & yol & "\" & "[" & hedefkitap & "]anasayfa'!R" & f & "C" & sut)
If sondeger = satırcık Then
sonkulsatır = f
GoTo 577
End If
Next f
577
44765
k = Cells(Rows.Count, 1).End(3).Row
    sorgu = "select F1,F3,F7,F8,F9,F10,F17,F18 " & _
      "from[anasayfa$A" & sonkulsatır + 1 & ":V" & son & "] where F2 ='" & targeta & "'"
    Set rs = con.Execute(sorgu)
    Range("A" & k + 1).CopyFromRecordset rs
'
    Sheets("liste").Protect "excelwebtr*", _
    DrawingObjects:=True, _
    Contents:=True, _
    Scenarios:=True

Orjinal dosyamdaki kod bu bu kodu kullandığımda sorgula tuşuna basınca son satırdaki deneyleri sürekli kopyalıyor.

 

[bordo6181]

Konu güncel

 

[bordo6181]

Konu @hmtstc tarafından çözülmüştür