Skip to main content

AccessTr.neT


Listviewden Excele Aktarımda Sumıf Kullanımı

Listviewden Excele Aktarımda Sumıf Kullanımı

#31
(29/12/2020, 16:10)feraz yazdı: Soru listviewdeki veriler için değilmiydi.Ado ile yapılan Veritabanından veriye göre yapıyor.Normalde dictionary ile yaptığım olmalıydı.

Kod:
Dim dic As Object
    Dim say As Long
    Dim i As Long, sonLitview As Long
    Dim kriter, arr()
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    With ThisWorkbook.Sheets("RAPOR")
        .Range("A2:S" & Rows.Count).ClearContents
        With Me.ListView1
            sonLitview = .ListItems.Count
            If sonLitview = 0 Then GoTo var
            ReDim arr(1 To sonLitview, 1 To 24)
            
            For i = 1 To sonLitview
                kriter = .ListItems(i)
                If Not dic.Exists(kriter) Then
                    son = Sayfa1.Range("A65536").End(xlUp).Row + 1
                    say = say + 1
                    
                    dic.Add kriter, say
                    arr(say, 1) = .ListItems(i)
                    arr(say, 2) = .ListItems(i).ListSubItems(2)
                    arr(say, 3) = .ListItems(i).ListSubItems(4)
                    arr(say, 4) = .ListItems(i).ListSubItems(14)
                    arr(say, 8) = .ListItems(i).ListSubItems(23)
                    arr(say, 9) = .ListItems(i).ListSubItems(13)
                    arr(say, 10) = .ListItems(i).ListSubItems(15)
                    arr(say, 11) = .ListItems(i).ListSubItems(16)
                    arr(say, 12) = .ListItems(i).ListSubItems(17)
                    arr(say, 13) = Replace(.ListItems(i).ListSubItems(18), " ", "")
                    arr(say, 14) = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(.ListItems(i).ListSubItems(22), "A", ""), "B", ""), "C", ""), "Ç", ""), "D", ""), "E", ""), "F", ""), "G", ""), "H", ""), "I", ""), "İ", ""), "J", ""), "K", ""), "L", ""), "M", ""), "N", ""), "O", ""), "Ö", ""), "P", ""), "R", ""), "S", ""), "Ş", ""), "T", ""), "U", ""), "Ü", ""), "V", ""), "W", ""), "Y", ""), "Z", ""), "Q", ""), ":", "")
                    

                End If
                arr(dic(kriter), 5) = arr(dic(kriter), 5) + .ListItems(i).ListSubItems(11) + 0
                
            Next
        End With
      
        If say > 0 Then .Range("A2").Resize(say, UBound(arr, 2)).Value = arr
    End With
var:
    On Error Resume Next
    MsgBox "bitti"
    Set dic = Nothing
    Erase arr

@feraz hocam son hali bu, bunda karar kıldım. Ancak son dolu satırdan itibaren yazdırma işlemini beceremedim.

son=sayfa1.range("a65536").end (xlup).row+1 değişkeni tanımladım

arr(son,say, 2) = .ListItems(i).ListSubItems(2) olarak denedim hata verdi.

onu nasıl aşarım.
Cevapla
#32
(29/12/2020, 17:47)kanakan52 yazdı:
(29/12/2020, 16:10)feraz yazdı: Soru listviewdeki veriler için değilmiydi.Ado ile yapılan Veritabanından veriye göre yapıyor.Normalde dictionary ile yaptığım olmalıydı.

Kod:
Dim dic As Object
    Dim say As Long
    Dim i As Long, sonLitview As Long
    Dim kriter, arr()
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    With ThisWorkbook.Sheets("RAPOR")
        .Range("A2:S" & Rows.Count).ClearContents
        With Me.ListView1
            sonLitview = .ListItems.Count
            If sonLitview = 0 Then GoTo var
            ReDim arr(1 To sonLitview, 1 To 24)
           
            For i = 1 To sonLitview
                kriter = .ListItems(i)
                If Not dic.Exists(kriter) Then
                    son = Sayfa1.Range("A65536").End(xlUp).Row + 1
                    say = say + 1
                   
                    dic.Add kriter, say
                    arr(say, 1) = .ListItems(i)
                    arr(say, 2) = .ListItems(i).ListSubItems(2)
                    arr(say, 3) = .ListItems(i).ListSubItems(4)
                    arr(say, 4) = .ListItems(i).ListSubItems(14)
                    arr(say, 8) = .ListItems(i).ListSubItems(23)
                    arr(say, 9) = .ListItems(i).ListSubItems(13)
                    arr(say, 10) = .ListItems(i).ListSubItems(15)
                    arr(say, 11) = .ListItems(i).ListSubItems(16)
                    arr(say, 12) = .ListItems(i).ListSubItems(17)
                    arr(say, 13) = Replace(.ListItems(i).ListSubItems(18), " ", "")
                    arr(say, 14) = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(.ListItems(i).ListSubItems(22), "A", ""), "B", ""), "C", ""), "Ç", ""), "D", ""), "E", ""), "F", ""), "G", ""), "H", ""), "I", ""), "İ", ""), "J", ""), "K", ""), "L", ""), "M", ""), "N", ""), "O", ""), "Ö", ""), "P", ""), "R", ""), "S", ""), "Ş", ""), "T", ""), "U", ""), "Ü", ""), "V", ""), "W", ""), "Y", ""), "Z", ""), "Q", ""), ":", "")
                   

                End If
                arr(dic(kriter), 5) = arr(dic(kriter), 5) + .ListItems(i).ListSubItems(11) + 0
               
            Next
        End With
     
        If say > 0 Then .Range("A2").Resize(say, UBound(arr, 2)).Value = arr
    End With
var:
    On Error Resume Next
    MsgBox "bitti"
    Set dic = Nothing
    Erase arr

@feraz hocam son hali bu, bunda karar kıldım. Ancak son dolu satırdan itibaren yazdırma işlemini beceremedim.

son=sayfa1.range("a65536").end (xlup).row+1  değişkeni tanımladım

arr(son,say, 2) = .ListItems(i).ListSubItems(2) olarak denedim hata verdi.

onu nasıl aşarım.

.Range("A2").Resize(say, UBound(arr, 2)).Value = arr
Yerine alttaki gibi deneyin,mobilden yazdım bilmiyorum çalışır mı?

.Range("A" & rows.count).end(3)(2,1).Resize(say, UBound(arr, 2)).Value = arr
Cevapla
#33
(29/12/2020, 17:47)kanakan52 yazdı: arr(son,say, 2) = .ListItems(i).ListSubItems(2)
Burda tam olarak ne yapmak istediniz abey?
Cevapla
#34
Berduş hocam içinize karışmak gibi olmasında alttaki yazdığını kodlarda 
Kod:
deneme.Miktar
gibi yerlerde deneme olanlar fazlalık bence yani kodu uzatıyor.
From deneme dendiği için zaten
Kod:
Sum(Miktar)
olarak yazılsada olur.Access bildiğim kadarıyla otomatik yapıyor ordan yola çıkarak yapıyorsunuz galiba.
iki tablo ile sorgu yapılırken dediğiniz yöntem uygulanabilir bence.

Kod:
Sum(deneme.Miktar) AS ToplaMiktar, Sum(deneme.Tutar) AS ToplaTutar FROM deneme
Cevapla
#35
haklısınız onlara gerek yok
zaten kodları tek tek yazmıyorum, accesse yaptırıp olduğu gibi excele aktarıyorum gerisi ufak tefek düzenlemeler o kadar.
excelde kod çalışırsa gerisine pek dokunmuyorum. Yani o kısımların olup olmaması çok da önemli değil tek tablolu sorgularda, birden fazla tablo olduğunda önemli oluyor o kısımlar en azından 2 tabloda da aynı isimde alanlar varsa.
Cevapla
#36
Tamam abey.
Yapmışken birde collection ilede yapmış bulunayım örnek açısından.

Dim col As New Collection
Function Kolleksiyon_Varmi(ByVal deger As String) As Boolean
    On Error GoTo hata
    col.Add deger, deger
    Kolleksiyon_Varmi = False
    Exit Function
hata:
    Kolleksiyon_Varmi = True
End Function

Private Sub CommandButton1_Click()
    Dim say As Long
    Dim i As Long, sonLitview As Long
    Dim kriter, arr(), col2 As New Collection

    With ThisWorkbook.Sheets("Sheet1")
        .Range("A12:F" & Rows.Count).ClearContents
        With Me.ListView1
            sonLitview = .ListItems.Count
            If sonLitview = 0 Then GoTo var
            ReDim arr(1 To sonLitview, 1 To 6)
            For i = 1 To sonLitview
                kriter = .ListItems(i).ListSubItems(1)
                If Kolleksiyon_Varmi(kriter) = False Then
                    say = say + 1
                    col2.Add say, kriter
                    arr(say, 1) = .ListItems(i)
                    arr(say, 2) = .ListItems(i).ListSubItems(1)
                    arr(say, 3) = .ListItems(i).ListSubItems(2)
                    arr(say, 4) = .ListItems(i).ListSubItems(3)
                End If
                arr(col2(kriter), 5) = arr(col2(kriter), 5) + .ListItems(i).ListSubItems(4) + 0
                arr(col2(kriter), 6) = arr(col2(kriter), 6) + .ListItems(i).ListSubItems(5) + 0
            Next
        End With
        If say > 0 Then .Range("A12").Resize(say, UBound(arr, 2)).Value = arr
    End With
var:
    On Error Resume Next
    MsgBox "bitti"
    Set col = Nothing: Set col2 = Nothing
    Erase arr
End Sub

[Resim: do.php?img=10656]
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task