RE: Listviewden Excele Aktarımda Sumıf Kullanımı - kanakan52 - 29/12/2020
(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.
RE: Listviewden Excele Aktarımda Sumıf Kullanımı - feraz - 29/12/2020
(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
RE: Listviewden Excele Aktarımda Sumıf Kullanımı - feraz - 29/12/2020
(29/12/2020, 17:47)kanakan52 yazdı: arr(son,say, 2) = .ListItems(i).ListSubItems(2) Burda tam olarak ne yapmak istediniz abey?
RE: Listviewden Excele Aktarımda Sumıf Kullanımı - feraz - 30/12/2020
Berduş hocam içinize karışmak gibi olmasında alttaki yazdığını kodlarda
gibi yerlerde deneme olanlar fazlalık bence yani kodu uzatıyor.
From deneme dendiği için zaten
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
RE: Listviewden Excele Aktarımda Sumıf Kullanımı - berduş - 30/12/2020
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.
Re: Listviewden Excele Aktarımda Sumıf Kullanımı - feraz - 30/12/2020
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
|