Karmaşık verileri düzenle hale getirme

[arrow3441]

Merhaba ustadlar ekteki dosyada açıklamayı ve nasıl olması gerektigi ile ilgili çalışmayı örnek olarak yaptım yardımlarınızı istiyorum sizlerden teşekkür ederim şimdiden.

 

[Haluk]

Ekli dosyada VBA/ADO ile bir alternatif hazırladım. "Rapor" isimli sayfadaki butona tıklayıp, duruma bir bakın..... ben kontrol etmedim.

.

 

[arrow3441]

Hocam çok teşekkür ederim süpersiniz istediğim gibi olmuş fakat çekmek istedipim depoyu değiştirince mesela AYDIN bu satırda hata veriyor

strSQL = "Select '" & arrBelgeNo(0, i) & "' As [BELGENO], '" & Sheets("Rapor").Range("C1") & "' As [DEPO], Sum([TOPLAM]) As [TOPLAM], Sum([NETTUTAR]) As [NETTUTAR]From [Sayfa1$] Where [BELGENO]= '" & arrBelgeNo(0, i) & "'"

Birde ek olarak PRIMTUTARI kısmında toplamı altında gösterebilirmi

 

[Haluk]

Evet .... "KIZILAY" ve "AKTUEL"de sorun yok ama, "AYDIN" seçince bir cinslik var. Muhtemelen "Sayfa1" içinde veri uyuşmazlığı falan, bir cinslik var.

Bulursam haber veririm.

Edit: "Sayfa1" "BELGENO" sütunundaki verilerin kimisi sayısal, kimisi de metin olarak görünüyor. Sorun burdan kaynaklanıyor.

.

 

[arrow3441]

Çözülebilcekmi peki hocam

 

[Haluk]

Sorun galiba şurdan kaynaklanıyor....

Belge No: "211261248376" hem KIZILAY deposunda, hem de AYDIN deposunda var. Bu doğru olabilir mi, yoksa veri yanlış mı girilmiş?

Bence olmaması gerekir mantıken, ama sizin değerlendirmeniz önemli....


.

 

[Haluk]

Uğraştırdı ama sorun çözüldü, şimdi oldu ....


.

 

[arrow3441]

Çok teşekkür ederim hocam bilginize emeğinize sağlık.

 

[arrow3441]

@Haluk hocam sorun aynı belgeno olmasımıymış peki

 

[Haluk]

Hayir, kodla ilgili bir problem vardi

.

 

[arrow3441]

Teşekkür ederim hocam tekrardan

 

[Haluk]

Tablolarda hücrelere kenarlık eklenmesi ve başlık hücrelerinin renklendirilmesini sağlayan revize kod aşağıdadır;

Option Explicit
'
Sub Test()
'   Haluk - 29/09/2023
'   sa4truss@gmail.com
'
    Dim objADO As ADODB.Connection
    Dim strFile As String, strSQL As String
    Dim objRS As ADODB.Recordset
    Dim arrBelgeNo As Variant
    Dim i As Integer, j As Integer, NoA As Integer, dataCount As Long
   
    NoA = Sheets("Sayfa1").Range("A" & Rows.Count).End(xlUp).Row
   
    For i = 2 To NoA
        Sheets("Sayfa1").Range("A" & i).Value = Sheets("Sayfa1").Range("A" & i).Value
    Next
   
    Sheets("Sayfa1").Range("A2:A" & NoA).NumberFormat = "0"
   
    Sheets("Rapor").Range("A2:K" & Rows.Count).Clear
     
    Set objADO = New ADODB.Connection
    objADO.CursorLocation = adUseClient
   
    strFile = ThisWorkbook.FullName
   
    With objADO
        If Val(Application.Version) < 14 Then
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .Properties("Extended Properties") = "Excel 8.0; HDR=Yes;IMEX=1;"
        Else
            .Provider = "Microsoft.Ace.OLEDB.12.0"
            .Properties("Extended Properties") = "Excel 12.0; HDR=Yes;IMEX=1;"
        End If
       .ConnectionString = strFile
       .Open
    End With
   
    Set objRS = New ADODB.Recordset
    strSQL = " Select Distinct [BELGENO] From [Sayfa1$] Where [DEPO]= '" & Sheets("Rapor").Range("C1") & "'"
   
    Set objRS = objADO.Execute(strSQL)
    dataCount = objRS.RecordCount
       
    arrBelgeNo = objRS.GetRows(, , "BELGENO")
   
    For i = 0 To dataCount - 1
        NoA = Sheets("Rapor").Range("A" & Rows.Count).End(xlUp).Row + 1

        strSQL = "Select '" & arrBelgeNo(0, i) & "' As [BELGENO], '" & Sheets("Rapor").Range("C1") & "' As [DEPO], Sum([TOPLAM]) As [TOPLAM], Sum([NETTUTAR]) As [NETTUTAR]From [Sayfa1$] Where [BELGENO]= " & arrBelgeNo(0, i) & " And [DEPO]= '" & Sheets("Rapor").Range("C1") & "'"

        Set objRS = objADO.Execute(strSQL)
               
        For j = 0 To objRS.Fields.Count - 1
            Sheets("Rapor").Cells(NoA + 2, j + 1) = objRS.Fields(j).Name
            Sheets("Rapor").Cells(NoA + 2, j + 1).Font.Bold = True
        Next
               
        Sheets("Rapor").Range("A" & NoA + 3).CopyFromRecordset objRS
        Sheets("Rapor").Range("A" & NoA + 2 & ":D" & NoA + 2).Interior.Color = RGB(212, 212, 212)
        Sheets("Rapor").Range("A" & NoA + 2 & ":D" & NoA + 2 + objRS.RecordCount).Borders.LineStyle = xlContinuous
       
        strSQL = "Select [STOKKODU], [MALINCINSI], [MIKTAR], [SATISFIYATI], [ISK1], [DURUM], [PRIM], [TOPLAM], [NETTUTAR], [PRIMTUTARI], [PERKODU] " & _
                 "From [Sayfa1$] Where [BELGENO]= " & arrBelgeNo(0, i) & " And [DEPO]= '" & Sheets("Rapor").Range("C1") & "'"
       
        Set objRS = objADO.Execute(strSQL)
       
        For j = 0 To objRS.Fields.Count - 1
            Sheets("Rapor").Cells(NoA + 4, j + 1) = objRS.Fields(j).Name
            Sheets("Rapor").Range(Cells(NoA + 4, j + 1).Address).Font.Bold = True
        Next
       
        Sheets("Rapor").Range("A" & NoA + 5).CopyFromRecordset objRS
        Sheets("Rapor").Range("A" & NoA + 4 & ":K" & NoA + 4 + objRS.RecordCount).Borders.LineStyle = xlContinuous
        Sheets("Rapor").Range("A" & NoA + 4 & ":K" & NoA + 4).Interior.Color = RGB(212, 212, 212)
    Next
           
    If objRS.State = adStateOpen Then objRS.Close
    If objADO.State = adStateOpen Then objADO.Close
   
    Set objRS = Nothing
    Set objADO = Nothing
End Sub

.

 

[arrow3441]

Hocam çok teşekkür ederim şimdi daha mükemmel oldu

 

[Haluk]

......
....
Birde ek olarak PRIMTUTARI kısmında toplamı altında gösterebilirmi

Bu da gerekliyse, onu da halledelim ...

.

 

[arrow3441]

Eğer uğraştırmassa hocam sizi gerekli işlem

 

[Haluk]

SQL sorgusuna ilaveyle halledildi.....


.

 

[arrow3441]

Çok iyi olmuş hocam çok teşekkür ederim

 

[arrow3441]

@Haluk hocam 1000 satırlık veri olunca işlem süresi 70 saniye oluyor daha kısa sürede işlem yapılabilrmi acaba? Veriler 5000 satır olabilir oyuzden

 

[Haluk]

Pek sanmıyorum çünkü çok fazla işlem yapılıyor tabloları oluşturmak için....

Örneğin, en son yapılan revizyon (tabloların altında prim tutarlarının toplamının alınması) için SQL'de kullanılan UNION ayrı bir yük getirir. Muhtemelen 12 No'lu mesajdaki kod daha hızlı olur. Çünkü; son revizyonda UNION komutundan dolayı veriler metinsel olarak geldiği için onları nümerik hale getirmek üzere tüm hücrelerde çalışan ayrı bir For-Next döngüsü kullanıldı ki, bu yavaşlamaya sebep olur...

.

 

[arrow3441]

Teşekkür ederim hocam yapıcak birşey yok ozaman