"A-B_KATSAYILARI" Sayfasındaki Şarta Uyan Verilerin Süzülerek "DTL" Sayfasına Aktarılması

[TURANNET]

Merhabalar,
Ekte gönderdiğim Excel proje dosyamı ve amacımı kısaca açıklamak istiyorum.
Projede, Sonuçların elde edileceği "DTL" ve kaynak verilerin bulunduğu "A-B_KATSAYILARI" adında iki tane sayfa mevcuttur.
Projenin amacı; her iki sayfada ortak veriler barındıran DİREK TİPİ ve BÖLGE sütunlarındaki veriler eşleştirilerek (her ikiside aynı anda sağlanmalıdır) "A-B_KATSAYILARI" sayfasındaki "(A) KATSAYISI", "(B) KATSAYISI ve "PROJE KAREKTERİSTİĞİ" bilgilerinin "DTL" sayfasında aynı başlıklar altında yer alan "??? işareti ile belirtilen" alanlara aktarılmasıdır.
Her iki sayfada ortak olan ve eşleştirmede dikkate alınacak veriler kırmızı renkli yazı tipinde, aktarılacak veriler ise yeşil renkte taralı olarak belirtilmiştir.
"DTL" sayfasında 1-300 arası satır sayısı olabilmektedir.
"A-B_KATSAYILARI" sayfasında mevcutta 89. satıra kadar veri girilmiştir. Yeni veriler ile proje tamamlandığında toplam satır sayısı tahminen 500 olabilecektir.
Şimdiden çok çok teşekkür ediyorum yardımcı olabilecek arakadaşlarıma.

Örnek Proje linki:

Transfer not found - TransferNow

Click to download the files for this transfer with TransferNow

www.transfernow.net

 

[Haluk]

Az önce bir dosya eklemiştim ama doğru sonuçları getirmiyordu, o yüzden silmiştim.

Ekli dosyayı kontrol edersiniz, umarım beklediğiniz sonuçları getiriyordur.

Ornek_Proje.xlsm - 53 KB







.

 

[TURANNET]

Az önce bir dosya eklemiştim ama doğru sonuçları getirmiyordu, o yüzden silmiştim.

Ekli dosyayı kontrol edersiniz, umarım beklediğiniz sonuçları getiriyordur.

Ornek_Proje.xlsm - 52 KB



.

Çok teşekkür ediyorum Haluk bey.
Test ettim ve sanırım sorun yok gibi.
Katsayılar sayfasına veri girişlerim devam ediyor. Yeni veriler ile birlikte belki bir kaç krtiter daha girecek dikkate alınması gereken.Onaları da ben çözmeye çalışırım.
Tekrar elinize sağlık, teşekkür ediyorum.

 

[TURANNET]

Çok teşekkür ediyorum Haluk bey.
Test ettim ve sanırım sorun yok gibi.
Katsayılar sayfasına veri girişlerim devam ediyor. Yeni veriler ile birlikte belki bir kaç krtiter daha girecek dikkate alınması gereken.Onaları da ben çözmeye çalışırım.
Tekrar elinize sağlık, teşekkür ediyorum.

Haluk bey tekrar merhabalar,
Tablolarıma veri girişini büyük oranda tamamladığımda DTL sayfasına aktarılması gereken 2 tane daha veri başlığımız olduğunu farkettim. Bunlar, KONSOL BOYU ve AÇIKLAMALAR-2 bilgileridir.
Ayrıca, ilk gönderdiğim örnek proje taslak olduğu için son gönderdiğim dosyada tabloları da daha kullanışlı bir hale getirdiğim için sanırım kodlarda buna göre revize olucaktır.
Zahmet olucak biliyorum ama sizden ricam müsait olduğunuz bir zamanda son duruma göre kodları revize edebilirmisiniz
Tekrar çok teşekkür ediyorum.

Transfer not found - TransferNow

Click to download the files for this transfer with TransferNow

www.transfernow.net

 

[Haluk]

Aşağıdaki kodu kullanın;

Sub Test2()
'   Haluk 21/04/2023
'
    Dim adoCN As Object, TargetFile As String, strSQL As String, tStart As Double, xRng As Range
  
    tStart = Timer
   
    Sheets("DTL").Range("P2:T" & Rows.Count).ClearContents
   
    Set adoCN = CreateObject("ADODB.Connection")
   
    TargetFile = ThisWorkbook.FullName
   
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = TargetFile
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCN.Open
       
    strSQL = " Update [DTL$] As DTL " & _
             " Left Join " & _
             " [A-B_KATSAYILARI$] As KATSAYI " & _
             " On (DTL.F4 = KATSAYI.F4 And DTL.F5 = KATSAYI.F5) " & _
             " Set DTL.F16 = KATSAYI.F6, DTL.F17 = KATSAYI.F7, DTL.F18 = KATSAYI.F8, DTL.F19 = KATSAYI.F9, DTL.F20 = KATSAYI.F10 " & _
             " Where DTL.F2 Is Not Null"
  
    adoCN.Execute (strSQL)
   
    For Each xRng In Sheets("DTL").Range("P2:R" & Sheets("DTL").Range("A" & Rows.Count).End(xlUp).Row)
        xRng.NumberFormat = "0.000000"
        xRng = IIf(xRng <> "", xRng + 0, "")
    Next
       
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - tStart, "0.00") & " Saniye", vbInformation
          
    adoCN.Close
    Set adoCN = Nothing
End Sub

.

 

[tamer42]

Aşağıdaki kodu kullanın;

Sub Test2()
'   Haluk 21/04/2023
'
    Dim adoCN As Object, TargetFile As String, strSQL As String, tStart As Double, xRng As Range
 
    tStart = Timer
  
    Sheets("DTL").Range("P2:T" & Rows.Count).ClearContents
  
    Set adoCN = CreateObject("ADODB.Connection")
  
    TargetFile = ThisWorkbook.FullName
  
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = TargetFile
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCN.Open
      
    strSQL = " Update [DTL$] As DTL " & _
             " Left Join " & _
             " [A-B_KATSAYILARI$] As KATSAYI " & _
             " On (DTL.F4 = KATSAYI.F4 And DTL.F5 = KATSAYI.F5) " & _
             " Set DTL.F16 = KATSAYI.F6, DTL.F17 = KATSAYI.F7, DTL.F18 = KATSAYI.F8, DTL.F19 = KATSAYI.F9, DTL.F20 = KATSAYI.F10 " & _
             " Where DTL.F2 Is Not Null"
 
    adoCN.Execute (strSQL)
  
    For Each xRng In Sheets("DTL").Range("P2:R" & Sheets("DTL").Range("A" & Rows.Count).End(xlUp).Row)
        xRng.NumberFormat = "0.000000"
        xRng = IIf(xRng <> "", xRng + 0, "")
    Next
      
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - tStart, "0.00") & " Saniye", vbInformation
         
    adoCN.Close
    Set adoCN = Nothing
End Sub

Haluk Hocam emeğinize sağlık,
Bu kodu 2 ve daha fazla kriterli "DÜŞEYARA" fonksiyonu için rahatlıkla kullanabiliriz sanırım;
Hem de for ... next dögüsüne hiç gerek kalmadan
teşekkür eder,
iyi bayramalar dilerim.