Diğer dosyadan makro ile veri almak

[expressoo]

Arkadaşlar ekteki dosyada sorunumu anlatmaya çalıştım.Değer tablosundan gün,motor,ebat parametrelerine bağlı olarak diğer dosyaya değer almaya çalışıyorum. bazı makro kalıplarını adapte etmeye çalıştım ama döngüleri karıştırıyorum.Yardımcı olabilirseniz sevinirim.

 

[Orion1]

Dosyanız ektedir.

Sub aktar_59()
Dim z As Object, n As Long, myarr(), i As Long, sat As Long
Dim sat2 As Long, strxl As String, deg As String, k As Byte
sat2 = Application.ExecuteExcel4Macro("COUNTA('" & ThisWorkbook.Path & "\[Kitap2.xls]Sayfa1'!C1)")
If sat2 < 2 Then
    MsgBox "Kitap1 de sayfa1 de veri yok." & vbLf & "İşlem İptal oldu", vbCritical, "UYARI"
    Exit Sub
End If
Application.ScreenUpdating = False
strxl = "'" & ThisWorkbook.Path & "\[Kitap2.xls]Sayfa1'!R"
Set z = CreateObject("Scripting.Dictionary")
ReDim myarr(1 To 9, 1 To sat2 - 1)
For i = 2 To sat2
    deg = Format(Application.ExecuteExcel4Macro(strxl & i & "C1"), "dd.mm.yyyy")
    For k = 2 To 5
        deg = deg & Application.ExecuteExcel4Macro(strxl & i & "C" & k)
    Next
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        deg = ""
        myarr(1, n) = Format(Application.ExecuteExcel4Macro(strxl & i & "C1"), "dd.mm.yyyy")
        For k = 2 To 9
            myarr(k, n) = Application.ExecuteExcel4Macro(strxl & i & "C" & k)
        Next
    End If
Next
sat = Cells(65536, "A").End(xlUp).Row
For i = 2 To sat
    deg = Format(Cells(i, "A").Value, "dd.mm.yyyy")
    For k = 2 To 5
        deg = deg & Cells(i, k).Value
    Next
    If z.exists(deg) Then
        For k = 6 To 9
            Cells(i, k).Value = myarr(k, z.Item(deg))
        Next
    End If
Next
Set z = Nothing: Erase myarr
Application.ScreenUpdating = True
MsgBox "Veriler Kapalı dosyadan aktarıldı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[expressoo]

Öncelikle çok işimi gördü teşekkür ederim . Bu işlemi tek parametreye bağlı olarak daha hızlandırmak adına söyle bir değişim yapabilirmiyiz? ekte anlatmaya çalıştım.Yardımlarınız için şimdiden tekrar teşekürler.

 

[Orion1]

Dosyanız ektedir.

Sub ado_veri_al_59()
'Tools==>reference'den microsoft activex dataobject library 2,8 seçildi
'Bu referans seçilmezse başka dosyalarda çalışmayacaktır,Bu kodlar.
'coder : evrengizlen@hotmail.com
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Range("A4:I65536").ClearContents
Set conn = New ADODB.Connection
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\Kitap2.xls;extended properties=""excel 8.0;hdr=yes"";"
Set rs = New ADODB.Recordset
rs.Open "select TARİH,MOTOR,A,B,C,D,J,M,Q from [Sayfa1$A1:R65536] where TARİH >=" & _
CLng(Range("B1").Value) & " and TARİH <=" & CLng(Range("B2").Value) & " order by TARİH,MOTOR", _
conn, adOpenKeyset, adLockReadOnly
If rs.RecordCount > 0 Then
    Range("A4").CopyFromRecordset rs
    Application.ScreenUpdating = True
    Range("A4").Select
    MsgBox "Veriler ADO ile kapalı dosyadan alındı" & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
    GoTo son2
End If
son:
Application.ScreenUpdating = True
MsgBox "Kitap1 de uyan şartlara ait veri bulunmadı", vbCritical, "UYARI"
son2:
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
End Sub

 

[expressoo]

Sizi çok uğraştırdığımın farkındayım.Öncelikle çok teşekkürler. verdiğiniz kodları aşağıdaki gibi uyarladığımda hata alıyorum "Gerekli bir veya daha fazla parametre için girilen değer yok" diyor.Sizce nereden kaynalanıyor olabilir?ikinci olarakta veriler verdiğiniz program ile çok güzel gelmekte ama kaynak dosyadan alınan sıralamalar ikinci stunda karışmakta bunun önüne geçebilir miyiz?

not: Değiştirdiğim kısımları renklendirdim.motor ölçüm sayfası xls dosyamın 3.cü sayfası,kaynak dosyasını ekte gönderiyorum.Acil yardımınıza ihtiyacım var.Şimdiden tekrar teşekkürler.

Sub ado_veri_al_59()
'Tools==>reference'den microsoft activex dataobject library 2,8 seçildi
'Bu referans seçilmezse başka dosyalarda çalışmayacaktır,Bu kodlar.
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Sheets("MOTOR ÖLÇÜM").Select
Application.ScreenUpdating = False
Range("A4:I65536").ClearContents
Set conn = New ADODB.Connection
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\motor.xls;extended properties=""excel 8.0;hdr=yes"";"
Set rs = New ADODB.Recordset
rs.Open "select Tarihi,No,Genel,Ölçümler,Kalınlığı,Devri,MotorGücü,TAHVİL,MERKEZİ from [Ü3 Dolu Ölçümler$B7:S65536] where Tarihi>=" & _
CLng(Range("B1").Value) & " and Tarihi <=" & CLng(Range("B2").Value) & " order by Tarihi,No", _
conn, adOpenKeyset, adLockReadOnly
If rs.RecordCount > 0 Then
Range("A4").CopyFromRecordset rs
Application.ScreenUpdating = True
Range("A4").Select
MsgBox "Ölçüm Değerleri Alındı" & vbLf & _
"", vbOKOnly + vbInformation, "S O N"
GoTo son2
End If
son:
Application.ScreenUpdating = True
MsgBox "İstenen Tarihlerde Ölçüm Verieri Mevcut Değil!", vbCritical, "UYARI"
son2:
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
End Sub

 

[Orion1]

Her 2 kaynak dosya farklı.
Bana başka dosya yoladınız.Kodları pna göre yaptım.
Oysa şimdi ise başka dosya yollamışsınız.
Bu durumda o kodlar bunda çaşışmaz.
Yani bir boksör müsabakasında sağ gösterip sol vurursunuz ya işte ayni onun gibi oldu bu durum.
Bir anda abondone oldum.Ama nakavt olmadım.
Sıralama yapmadım.
Verileri aldığı sıra ile getiriyor.
Dosyanız ektedir.

Sub ado_veri_al_59()
'Tools==>reference'den microsoft activex dataobject library 2,8 seçildi
'Bu referans seçilmezse başka dosyalarda çalışmayacaktır,Bu kodlar.
'coder : evrengizlen@hotmail.com
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Sheets("MOTOR ÖLÇÜM").Select
Application.ScreenUpdating = False
Range("A4:I65536").ClearContents
Set conn = New ADODB.Connection
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\Motor.xls;extended properties=""excel 8.0;hdr=No"";"
Set rs = New ADODB.Recordset
rs.Open "select F1,F2,F3,F4,F5,F6,F7,F11 from [Ü3 Dolu Ölçümler$B10:L65536] where F1 >=" & _
CLng(Range("B1").Value) & " and F11 <=" & CLng(Range("B2").Value), _
conn, adOpenKeyset, adLockReadOnly
If rs.RecordCount > 0 Then
    Range("A4").CopyFromRecordset rs
    Application.ScreenUpdating = True
    Range("A4").Select
    MsgBox "Veriler ADO ile kapalı dosyadan alındı" & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
    GoTo son2
End If
son:
Application.ScreenUpdating = True
MsgBox "Kitap1 de uyan şartlara ait veri bulunmadı", vbCritical, "UYARI"
son2:
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
End Sub

 

[expressoo]

havlu attım eline sağlık.