Veri Transferi

[umudaezgii]

Arkadaşlar merhaba ,
Excele yeni başlayan biriyim, ve takıldığım bir konu var, yardımınızı rica ediyorum.
Deneme 1 olarak bir dosyam var, 3 sayfadan oluşuyor. (Senetler, satırlar ve Sheet1 olarak)
Senetler sayfasında sarı renkle belirtilen (toplam konteyner, toplam kap, toplam brüt) genel toplam bilgilerinin dağılımını, Satırlar sayfasındaki ''Boşaltma Limanı'' bilgisine göre ilk Senetler sayfasına getirmesini istiyorum.
Satırlar sayfasındaki Senet Numarası, konteyner numarası toplam sayısı, kap adedi ve brüt ağırlık bilgilerinin, boşaltma limanına göre dağılımını ilk başta ki Senetler sayfasında çıkmasını istiyorum. Formül yada makroda olabilir. Örnek dosya ve olmasını isteyip te yapamadığım diğer dosyada ekte ki gibidir.
Yardımınızı rica ederim.
Teşekkürler

 

[yanginci34]

Denermisiniz.

 

[veyselemre]

Sub test()
    Set sSen = Sheets("Senetler")
    Set sSat = Sheets("Satırlar")
    veri = sSat.Range("B3:K" & sSat.Cells(Rows.Count, 2).End(3).Row).Value
    Dim ver()
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            ky = veri(i, 1)
            If Not .exists(ky) Then
                say = say + 1
                ReDim Preserve ver(1 To 4, 1 To say)
                .Item(ky) = say
                ver(1, say) = veri(i, 1)
                ver(2, say) = 1
                ver(3, say) = veri(i, 8)
                ver(4, say) = veri(i, 10)
            Else
                sira = .Item(ky)
                ver(2, sira) = ver(2, sira) + 1
                ver(3, sira) = ver(3, sira) + veri(i, 8)
                ver(4, sira) = ver(4, sira) + veri(i, 10)
            End If
        Next i
    End With
    sSen.Range("D3:IV6").ClearContents
    sSen.Range("D3").Resize(4, UBound(ver, 2)).Value = ver
End Sub

 

[umudaezgii]

Denermisiniz.[/QUOT
Merhaba,
Öncelikle yardımınız için teşekkür ederim. Gönderdiğiniz dosyayı açtığımda farklı bir şey göremedim .
Tekrar kontrol edebilmeniz mümkün mü ?
Teşekkürler

 

[umudaezgii]

Sub test()
    Set sSen = Sheets("Senetler")
    Set sSat = Sheets("Satırlar")
    veri = sSat.Range("B3:K" & sSat.Cells(Rows.Count, 2).End(3).Row).Value
    Dim ver()
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            ky = veri(i, 1)
            If Not .exists(ky) Then
                say = say + 1
                ReDim Preserve ver(1 To 4, 1 To say)
                .Item(ky) = say
                ver(1, say) = veri(i, 1)
                ver(2, say) = 1
                ver(3, say) = veri(i, 8)
                ver(4, say) = veri(i, 10)
            Else
                sira = .Item(ky)
                ver(2, sira) = ver(2, sira) + 1
                ver(3, sira) = ver(3, sira) + veri(i, 8)
                ver(4, sira) = ver(4, sira) + veri(i, 10)
            End If
        Next i
    End With
    sSen.Range("D3:IV6").ClearContents
    sSen.Range("D3").Resize(4, UBound(ver, 2)).Value = ver
End Sub

Veysel bey merhaba ,

Desteğiniz için teşekkürler. Yalnız ufak bir problem ile karşılaştım.
Farklı bir dosyada gönderdiğiniz makroyu denediğimde, ilk sayfaya aktardığınız toplam kap kilo bilgileri doğru gelmiş, fakat boşaltma limanına göre konteyner adetleri yanlış görünüyor.
Denemiş olduğum örnek dosya ekte ki gibidir. Getirmesi gereken doğru konteyner adetlerini de en üst satıra yazdım. Mümkünse kontrolünü rica ederim.
Tekrar teşekkürler .

 

[umudaezgii]

Veysel bey merhaba ,

Desteğiniz için teşekkürler. Yalnız ufak bir problem ile karşılaştım.
Farklı bir dosyada gönderdiğiniz makroyu denediğimde, ilk sayfaya aktardığınız toplam kap kilo bilgileri doğru gelmiş, fakat boşaltma limanına göre konteyner adetleri yanlış görünüyor.
Denemiş olduğum örnek dosya ekte ki gibidir. Getirmesi gereken doğru konteyner adetlerini de en üst satıra yazdım. Mümkünse kontrolünü rica ederim.
Tekrar teşekkürler .

Veysel bey ufak bir detayı atladım kusura bakmayın ltf.
Satırlar sayfasındaki konteyner numaralarında mükerrer bilgiler var mal cinslerinin farklılığından dolayı. Bunları o sayfadan silmemem gerekiyor. Bu yüzden ben 3. sayfa olan sheet1 sayfasına mükerrerleri silip konteyner toplamları çıkarmıştım.
Konteyner adedini 3. sayfadaki Sheet1 isimli sayfadan çekilebilir mi ?

 

[veyselemre]

Sub test()
    Set sSen = Sheets("Senetler")
    Set sSat = Sheets("Satırlar")
    veri = sSat.Range("B3:K" & sSat.Cells(Rows.Count, 2).End(3).Row).Value
    Dim ver()
    Dim dics() As Object
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            ky = veri(i, 1)
            If Not .exists(ky) Then
                say = say + 1
                ReDim Preserve ver(1 To 4, 1 To say)
                ReDim Preserve dics(1 To say)
                Set dics(say) = CreateObject("Scripting.Dictionary")
                .Item(ky) = say
                ver(1, say) = veri(i, 1)
            End If
            sira = .Item(ky)
            dics(sira).Item(veri(i, 5)) = Null
            ver(2, sira) = dics(sira).Count
            ver(3, sira) = ver(3, sira) + veri(i, 8)
            ver(4, sira) = ver(4, sira) + veri(i, 10)
        Next i
    End With
    sSen.Range("D3:IV6").ClearContents
    sSen.Range("D3").Resize(4, UBound(ver, 2)).Value = ver
    Erase dics, ver
End Sub

 

[umudaezgii]

Sub test()
    Set sSen = Sheets("Senetler")
    Set sSat = Sheets("Satırlar")
    veri = sSat.Range("B3:K" & sSat.Cells(Rows.Count, 2).End(3).Row).Value
    Dim ver()
    Dim dics() As Object
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            ky = veri(i, 1)
            If Not .exists(ky) Then
                say = say + 1
                ReDim Preserve ver(1 To 4, 1 To say)
                ReDim Preserve dics(1 To say)
                Set dics(say) = CreateObject("Scripting.Dictionary")
                .Item(ky) = say
                ver(1, say) = veri(i, 1)
            End If
            sira = .Item(ky)
            dics(sira).Item(veri(i, 5)) = Null
            ver(2, sira) = dics(sira).Count
            ver(3, sira) = ver(3, sira) + veri(i, 8)
            ver(4, sira) = ver(4, sira) + veri(i, 10)
        Next i
    End With
    sSen.Range("D3:IV6").ClearContents
    sSen.Range("D3").Resize(4, UBound(ver, 2)).Value = ver
    Erase dics, ver
End Sub

Veysel bey merhaba ,
Şimdi oldu, ilginiz ve desteğiniz için çok teşekkür ederim.
İyi akşamlar

 

[veyselemre]

Sub adoOzetle()
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & ThisWorkbook.FullName & _
             "';Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"

    strSql = "SELECT Liman, Count(SayKont), Sum(ToplaKap), Sum(ToplaAg) " & _
             "FROM " & _
             "( " & _
             "SELECT [BOŞALTMA LİMANI] as Liman, Count([KONTEYNER NUMARASI] ) AS SayKont, " & _
             "     Sum([BRÜT AĞIRLIK]) AS ToplaAg, Sum([Kap Adedi]) AS ToplaKap " & _
             "FROM [Satırlar$A2:K" & Sheets("Satırlar").Cells(Rows.Count, 1).End(3).Row & "] " & _
             "GROUP BY [BOŞALTMA LİMANI], [KONTEYNER NUMARASI] " & _
             ") " & _
             "GROUP BY Liman"

    With CreateObject("Adodb.RecordSet")
        .Open strSql, strCon
        ver = .Getrows
        .Close
    End With
    Sheets("Senetler").Range("D3:IV6").ClearContents
    Sheets("Senetler").Range("D3").Resize(4, UBound(ver, 2) + 1).Value = ver
End Sub

 

[umudaezgii]

Veysel bey merhaba ,
Son gönderdiğiniz kodlarda farklılık varmıydı ? Bir önceki sorunumuzu çözmüştü.