Verileri diğer sayfaya aynı olanları toplayarak aktarma

[Recep İpek]

Daha önce G kolonuna istemiştiniz.Buna görede düzeltmede bulunmuştuk.

Şimdi ise son bilgiler hangi kolona aktarılacak?

 

[yolcu50]

ripek ustam gösterdiğin ilgi için öncelikle teşekkür ederim.
en son verdiğim kod a göre çalışmamı yapıyorum. a - e - f - h sütunlarına rapor oluşturuyor. c - d sütunlarındaki bağımsız verileri silmesini istememiştim ve silmiyor buna ilave olarak benim istediğim g sütununda bulunan yazılarıda silmemesi mümkünse cevaplarmısınız.
a - e - f - h sütunlarına rapor oluştururken c - d - g sütunlarını silmeyecek
sorunumun bu kadarının çözülmesi yeterli ancak oluyormu bilmiyorum h sütununa verilerin toplamını verdiği için sayının yanına Adet kelimesi sayı ile birlikte gelirmi ?

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Sub AktarSay()
Dim a, i, n, k, b(), z
Set s1 = Sheets("VERİ")
Set s2 = Sheets("RAPOR")
'*******************************************
a = s1.Range("a2:c" & s1.[a65536].End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 8)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
           If Not IsEmpty(a(i, 1)) Then
                z = a(i, 1) & ":" & a(i, 2) & ":" & a(i, 3)
                If Not .exists(z) Then
                    n = n + 1
                    b(n, 1) = a(i, 1)
                    b(n, 5) = a(i, 2)
                    b(n, 6) = a(i, 3)
                    .Add z, n
                End If
                    b(.Item(z), 8) = b(.Item(z), 8) + 1
            End If
    Next
End With
'*******************************************
son = [a65536].End(3).Row
s2.Range(Cells(2, "a"), Cells(son, "a")).ClearContents
s2.Range(Cells(2, "e"), Cells(son, "f")).ClearContents
s2.Range(Cells(2, "h"), Cells(son, "h")).ClearContents
For x = 1 To UBound(b)
    For j = 1 To 1
        If Not IsEmpty(b(x, j)) Then Cells(x + 1, j) = b(x, j)
    Next j
Next x
For x = 1 To UBound(b)
    For j = 5 To 6
         If Not IsEmpty(b(x, j)) Then Cells(x + 1, j) = b(x, j)
    Next j
Next x
For x = 1 To UBound(b)
    For j = 8 To 8
         If Not IsEmpty(b(x, j)) Then Cells(x + 1, j) = b(x, j) & " Adet"
    Next j
Next x
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[yolcu50]

ustam çok teşekkür ederim. sana bayağı zahmet verdim

 

[Recep İpek]

Önemli değil.Faydalı olabildiysem benim için mutluluk...