Tetkik karşılaştırma,raporlama ve aktarma

[POLARIS]

Sayın fedeal,
Hocam bu haliyle oldu teşekkür ederim.

Yanlız her iki kuruluştaki arkadaşların dosya no,istenen tetkik adı,yapılan tetkik adlarında çok hatalar yaptığını gördüm.Bu yüzden kontrolü genişletmek için yeni bir sütun ilave ettim.
Eklediğim dosyada açıkladım.İlgilenebilirseniz sevinirim.Birde kodları doğru yazmışmıyım bakarmısınız.

 

[fedeal]

şimdi bir şey sormam lazım sekreterler idare-istenen tetkik kısmını dolduruyor yüklenici, gelen dosyadan kopyalanıyor sanırım.

 

[fedeal]

Data sayfası oluşturdum,bu sayfaya mr türlerini karşılarına rasgele numara girdim.istenen tetkik (f sütununa) açılan listeden veri alınacak (data sayfasında 200 satır olarak listeledim yetermi) alınan veriye göre numara otamatik gelecek deneyin uygunmu? öteki dosyano ve tetkik koduna göre sorgulamayı eve gidince yaparım.saygılar.

 

[POLARIS]

Sayın fedeal,
Hocam yanlışlıklar da buradan kaynaklanıyor.İDARE sekreterleri DR.un istemine göre A:G sütunlarını alalacele dolduruyor.Belli bir sistemleri yok.Dosya formatı şimdilik bu.YÜKLENİCİ de
kendi kafasına göre dolduruyor.I:K sütunlarını.Sonra biz iki taraftan dosyaları alıp yapıştırıp karşılaştırıyoruz.Siz de gördünüz o kadar çok hata varki anlatamam.Sizin eklediğiniz dosya çok güzel çalıştı.Ancak tetkik kodu üreterek bir sorgulama daha yapmak sanki daha iyi olacak.Sizin fikriniz nedir?nasıl yapalım.
Teşekkür eder iyi çalışmalar dilerim.

 

[POLARIS]

Sayın fedeal,
Hocam aynen dediğiniz gibi.Ben dosyada data bölümüne tetkikleri girdim.
Teşekkür eder iyi akşamlar dilerim.

 

[POLARIS]

Dosya yenileme

Sayın fedeal iyi geceler,
Dosyayı yeniledim.Bilginiz olsun.

 

[fedeal]

Selam, dosyada hala çözülmemiş bir problemimiz var.yaptıgımız işlemi dediginiz gibi hem protokol no hem mr türüne göre sorgulamamız için öncelikle data sayfasındaki listenin aylık döküm sayfasındaki listeyle tutması gerekiyor.örnegin diffizyon mr yok.ayrıca yüklenici kayıtlarında aynı mr ların isimleri farklı girildigi için data sayfasında bunlarda bulunmalı (KAFA TABANI MR=17 ise (mr) KAFA TABANI =17 olarak girilmeli) bu bir kere yapıldımı giriş isimleri aynı ise sonuç hep dogru olacaktır.


yada yüklenici bu kayıtları hangi programla tutuyor idare hangi programla,eğer sekreter bunu excel olarak kayıt altına alıyorsa her ikisinin yanlış giremeyecegi (isim olarak) işlevsel bir çalışma yapalım.

çalışmanızda hata veren makronun sebebi aynı başlıklı iki makro olması

alttaki resimde elimizdeki listenin benzersiz listelenmiş hali ve numaralandırma örnegi var.

 

[POLARIS]

Sayın fedeal,
Söylediğiniz gibi tetkik kodlarını yaptım.Ama formülle.
26.mesajdaki dosyayı yeniledim.Bakabilirmisiniz...Teşekkürer.

 

[POLARIS]

Sayın fedeal,
Şimdi ekledim

 

[fedeal]

Data sayfasındaki listeydi lazım olan, aylık döküm sayfasına buton oluşturup altaki makroyla kayıt numaralaını data sayfasından alabilirsiniz,

Sub datadanal()
For i = 3 To Sheets("AYLIK DÖKÜM").Range("f2000").End(xlUp).Row
If Cells(i, 1).Value = "" Then GoTo ATLA
Set B = Sheets("DATA").Range("A2:A300").Find(Cells(i, "f").Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not B Is Nothing Then
Cells(i, "e").Value = Sheets("DATA").Cells(B.Row, 2).Value
Else
Cells(i, "e").Value = "yok"
End If
Next
ATLA:
For i = 3 To Sheets("AYLIK DÖKÜM").Range("M2000").End(xlUp).Row
If Cells(i, "J").Value = "" Then GoTo atla1
Set B = Sheets("DATA").Range("A2:A300").Find(Cells(i, "M").Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not B Is Nothing Then
Cells(i, "L").Value = Sheets("DATA").Cells(B.Row, 2).Value
Else
Cells(i, "L").Value = "yok"
End If
Next
atla1:
End Sub

altaki kodlarıda kontrol butonuna atayın,

Sub KONTROL()
For i = 3 To Sheets("AYLIK DÖKÜM").Range("f2000").End(xlUp).Row
For K = 3 To Sheets("AYLIK DÖKÜM").Range("J2000").End(xlUp).Row
If Cells(i, 1).Value = "" Then GoTo ATLA
If Cells(i, "D").Value = Cells(i, "K").Value And Cells(i, "E").Value = Cells(i, "L").Value Then
fd = Sheets("HAKEDİŞ").Range("A2000").End(xlUp).Row + 1
For f = 1 To 9
Sheets("HAKEDİŞ").Cells(fd, f).Value = Cells(i, f).Value
Next
Range("a" & i & ":I" & i).Delete Shift:=xlUp
Range("J" & K & ":N" & K).Delete Shift:=xlUp
i = i - 1
Else
Cells(i, "I").Value = "KONTROL EDİN"
End If
Next
Next
ATLA:
End Sub

umarım bu sefer olmuştur hata varsa tekrar bakarız,saygılar.

 

[POLARIS]

Sayın fedeal iyi akşamlar,
Birde siz kontrol edermisiniz.
Tetkik kodları geliyor o tamam.Aktarımda tamam.
Yanlız silmede bir sorunmu var?
İDARE tarafında aktarımdan sonra 72 hastadan 52 hasta kaydı kalırken YÜKLENİCİ tarafında 75 kayıt aynen kalıyor.
Yada ben kodları yanlış atamış olabilirim.

 

[fedeal]

şimdi kontrol ettim kontrol butonuna atalı makro kontrol makrosu degil daha önceki n makrosu düzeltip tekrar deneyin n makrosunu silebilirsiniz işlevi kalmadı.

 

[POLARIS]

Sayın fedeal Merhaba,
Hocam ben sıcaktan dağıldım.Kodları yanlış atamış ta olabilirim.
Tetkik kodları ve özellikle KONTROL çok çok yavaş.
Kontrol edebilirmisiniz?
Teşekkürler iyi çalışmalar...

 

[POLARIS]

Eşleşen verileri aktarmak

Sayın fedeal iyi geceler,
Balık malık derken aç kalıcaz.
Saatlerdir uğraşıyorum ancak yapamadım.
Siz bakabildinizmi?

 

[fedeal]

Baktım, bir deneme daha yaptım hızlı olması için find fonksiyonuyla yapmalıyız genede bir döngü kullanıyoruz 500 tane veri olunca en az 5 dakika gibi bir süre tutuyor. dükkanda yarın onuda ekleyim. sonuç iyi ama 5-6 dakika sürüyor aslında elle yapmayı düşünürsek fena bir süre sayılmaz

 

[POLARIS]

Arkadaşlar merhaba,
Günlerdir sorunuma tam bir çözüm bulamadım.
Forumda aradım ama maalesef tam çözüm olmadı.
34.mesajda ekli dosyada açıklamalarım var.
İlgilerinize şimdiden teşekkür ederim.

 

[POLARIS]

Arkadaşlar tekrar merhaba,
Uğraşıyorum ancak hala bir çözüm bulamadım.
Üstatlar,musait olunca bakabilirmisiniz?
34.mesajda ekli dosyada açıklamalarım var.
İlgilerinize şimdiden teşekkür eder iyi çalışmalar dilerim.

 

[POLARIS]

Sayın modalı iyi akşamlar,
*400 hatası ne demek.
teşekkürler...

 

[POLARIS]

İyi akşamlar arkadaşlar,
Konuyu sonuçlandırabilmek için makro konusunda yardımlarınızı bekliyorum.
Teşekkür eder iyi çalışmalar dilerim.

 

[Orion1]

Find komutunu kullandım.Sizin meccut dosyanız için yapılabilecek en hızlı kodları kullandım.
Ama döngüye mecburen giriliyor,ve esas problem silme olayında oluyor.
Satırları silmek çok uzun işlem alıyor.Kodların yavaşlamasının asıl sebebi satır silemk oluyor.
Benim makinede 3-5 dakikada olay sonuçlandı.
Dosya ektedir.

Sub KONTROL()
Dim k As Range, adr As String, sat As Long, sh As Worksheet
Dim myarr1(), myarr2()
Dim a As Long, b As Long
ReDim myarr1(1 To 1, 1 To 1)
ReDim myarr2(1 To 1, 1 To 1)
Application.ScreenUpdating = False
Set sh = Sheets("HAKEDİŞ")
sat = sh.Cells(65536, "A").End(xlUp).Row + 1
With Sheets("AYLIK DÖKÜM")
    For i = .Cells(65536, "A").End(xlUp).Row To 3 Step -1
        If .Cells(i, "A").Value = "" Then GoTo atla
        Set k = .Range("K2:K65536").Find(.Cells(i, "D").Value, , xlValues, xlWhole)
        If Not k Is Nothing Then
            adr = k.Address
            If k.Value = "" Then GoTo atla3
            If .Cells(i, "E").Value = .Cells(k.Row, "L").Value Then
             If sat >= 65533 Then
                MsgBox "Sayfada satır doldu.Sayfaya Başka kayıt Aktarılmadı.İşlem tamamlanmadı.", vbCritical, "UYARI"
                GoTo atlason
             End If
             
                sh.Range("A" & sat & ":I" & sat).Value = _
                .Range("A" & i & ":I" & i).Value
                sat = sat + 1
                a = a + 1
                ReDim Preserve myarr1(1 To 1, 1 To a)
                myarr1(1, a) = i
            End If
            Do
                If k.Value = "" Then GoTo atla3
                If .Cells(i, "E").Value = .Cells(k.Row, "L").Value Then
                    b = b + 1
                     ReDim Preserve myarr2(1 To 1, 1 To b)
                     myarr2(1, b) = k.Row
                End If
atla3:
                Set k = .Range("K2:K65536").FindNext(k)
            Loop While Not k Is Nothing And k.Address <> adr
        End If
atla:
    Next i
atlason:
    If b = 0 Then GoTo atla2
    For i = LBound(myarr2, 2) To UBound(myarr2, 2) - 1
    For j = i + 1 To UBound(myarr2, 2)
        If CLng(myarr2(1, i)) < CLng(myarr2(1, j)) Then
            x = myarr2(1, i)
            myarr2(1, i) = myarr2(1, j)
            myarr2(1, j) = x
        End If
    Next j
Next i
For i = LBound(myarr2, 2) To UBound(myarr2, 2)
    .Range("J" & myarr2(1, i) & ":N" & myarr2(1, i)).Delete (xlUp)
Next i
atla2:
If a = 0 Then GoTo son
For i = LBound(myarr1, 2) To UBound(myarr1, 2) - 1
    For j = i + 1 To UBound(myarr1, 2)
        If CLng(myarr1(1, i)) < CLng(myarr1(1, j)) Then
            x = myarr1(1, i)
            myarr1(1, i) = myarr1(1, j)
            myarr1(1, j) = x
        End If
    Next j
Next i
For i = LBound(myarr1, 2) To UBound(myarr1, 2)
    .Range("A" & myarr1(1, i) & ":I" & myarr1(1, i)).Delete (xlUp)
Next i
son:
End With
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı."
Erase myarr1: Erase myarr2
End Sub