Verileri diğer sayfaya aynı olanları toplayarak aktarma

yolcu50 · 18 Kasım 2007

selam.... benim isteğim veri sayfasında bulunan listede aynı kişiye ait aynı özelliğe sahip malzemeyi tek tek değil toplayıp bir satırda özelliği ile birlikte vermesini makro kod yardımı ile yapmak istiyorum

yolcu50 · 18 Kasım 2007

ustalarım o kadar zor bir soru sormadım herhalde yardımcı olacak kimse yokmu

yolcu50 · 18 Kasım 2007

ustalarım o kadar zor bir soru sormadım herhalde yardımcı olacak kimse yokmu

yolcu50 · 18 Kasım 2007

ustalar lütfen yardımınızı bekliyorum

irfancantr · 19 Kasım 2007

http://www.excel.web.tr/showthread.php?t=40066 bu sayfadaki çalışma kitabını incelemenizi tavsiye ederim,belki işinize yarayabilir...

Recep İpek · 19 Kasım 2007

Aşağıdaki kodları deneyiniz.

Kod:

[COLOR=blue]Sub[/COLOR] AktarSay()
Dim a, i, n, k, b(), z
Set s1 = Sheets("VER&#304;")
Set s2 = Sheets("RAPOR")
'*******************************************
a = s1.Range("a2:d" & s1.[a65536].End(3).Row).Value
ReDim b(1 To [COLOR=blue]UBound[/COLOR](a, 1), 1 To 5)
With CreateObject("[COLOR=blue]Scripting.Dictionary[/COLOR]")
    .CompareMode = [COLOR=blue]vbTextCompare[/COLOR]
    For i = 1 To [COLOR=blue]UBound[/COLOR](a, 1)
           If [COLOR=blue]Not IsEmpty[/COLOR](a(i, 2)) Then
                z = a(i, 2) & ":" & a(i, 3) & ":" & a(i, 4)
                If [COLOR=blue]Not .exists[/COLOR](z) Then
                    n = n + 1
                    b(n, 1) = n
                    b(n, 2) = a(i, 2)
                    b(n, 3) = a(i, 3)
                    b(n, 4) = a(i, 4)
                    .[COLOR=blue]Add [/COLOR]z, n
                End If
                    b(.Item(z), 5) = b(.Item(z), 5) + 1
            End If
    Next
End With
s2.Range("a2:e500").ClearContents
s2.[a2].Resize(n, 5).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = [COLOR=blue]Nothing[/COLOR]
Set s2 = [COLOR=blue]Nothing[/COLOR]
[COLOR=blue]End Sub[/COLOR]

yolcu50 · 19 Kasım 2007

Ripek' Alıntı:

Aşağıdaki kodları deneyiniz.

Kod:

[COLOR=blue]Sub[/COLOR] AktarSay()
Dim a, i, n, k, b(), z
Set s1 = Sheets("VERİ")
Set s2 = Sheets("RAPOR")
'*******************************************
a = s1.Range("a2:d" & s1.[a65536].End(3).Row).Value
ReDim b(1 To [COLOR=blue]UBound[/COLOR](a, 1), 1 To 5)
With CreateObject("[COLOR=blue]Scripting.Dictionary[/COLOR]")
    .CompareMode = [COLOR=blue]vbTextCompare[/COLOR]
    For i = 1 To [COLOR=blue]UBound[/COLOR](a, 1)
           If [COLOR=blue]Not IsEmpty[/COLOR](a(i, 2)) Then
                z = a(i, 2) & ":" & a(i, 3) & ":" & a(i, 4)
                If [COLOR=blue]Not .exists[/COLOR](z) Then
                    n = n + 1
                    b(n, 1) = n
                    b(n, 2) = a(i, 2)
                    b(n, 3) = a(i, 3)
                    b(n, 4) = a(i, 4)
                    .[COLOR=blue]Add [/COLOR]z, n
                End If
                    b(.Item(z), 5) = b(.Item(z), 5) + 1
            End If
    Next
End With
s2.Range("a2:e500").ClearContents
s2.[a2].Resize(n, 5).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = [COLOR=blue]Nothing[/COLOR]
Set s2 = [COLOR=blue]Nothing[/COLOR]
[COLOR=blue]End Sub[/COLOR]

TEŞEKKÜR EDERİM ÇALIŞIYOR.

yolcu50 · 19 Kasım 2007

ripek ustam benim veri sayfamda verilerin başında numara yok onun için hata veriyor. aktarma işlemini a sütunundan nasıl başlatırız

Recep İpek · 19 Kasım 2007

Kodları aşağıdaki şekilde değiştiriniz.

Kod:

Sub AktarSay()
Dim a, i, n, k, b(), z
Set s1 = Sheets("VER&#304;")
Set s2 = Sheets("RAPOR")
'*******************************************
a = s1.Range("a2:c" & s1.[a65536].End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 5)
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) = n
                    b(n, 2) = a(i, 1)
                    b(n, 3) = a(i, 2)
                    b(n, 4) = a(i, 3)
                    .Add z, n
                End If
                    b(.Item(z), 5) = b(.Item(z), 5) + 1
            End If
    Next
End With
s2.Range("a2:e500").ClearContents
s2.[a2].Resize(n, 5).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

yolcu50 · 19 Kasım 2007

tşk ederim ilgin için ama sayısız bilgileri süzüyor ancam raporu sayılı veriyor, birde raporu hangi sütunlara vereceğini nasıl ayarlıyoruz. bende raporu a, e, f, g sütunlarına yazmasını diğer sütunların boş olması gerekiyor.

Recep İpek · 19 Kasım 2007

O zaman bu şekilde deneyiniz.

Kod:

Sub AktarSay()
Dim a, i, n, k, b(), z
Set s1 = Sheets("VER&#304;")
Set s2 = Sheets("RAPOR")
'*******************************************
a = s1.Range("a2:c" & s1.[a65536].End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 7)
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), 7) = b(.Item(z), 7) + 1
            End If
    Next
End With
s2.Range("a2:g500").ClearContents
s2.[a2].Resize(n, 7).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

yolcu50 · 19 Kasım 2007

teşekkür ederim bu sefer oldu

yolcu50 · 19 Kasım 2007

program güzel çalışıyor ancak raporu a, e, f, g sütunlarına oluştururken bu rapordan bağımsız olarak c ve d sütunlarına yazdığım yazıyı her rapor almamda siliyor bunu önleyebilirmiyiz

yolcu50 · 20 Kasım 2007

ustalarım bu sorunumun çaresi yokmudur

Recep İpek · 20 Kasım 2007

Biraz acele etmiyormusunuz?

Kodlarını alt kısmını aşağıdaki şekilde değiştiriniz.

Kod:

s2.Range("a2:a500").ClearContents
s2.Range("e2:g500").ClearContents
s2.[a2].Resize(n, 1).Value = b
For x = 1 To UBound(b)
    For j = 5 To 7
        Cells(x + 1, j) = b(x, j)
    Next j
Next

yolcu50 · 20 Kasım 2007

ustam teşekkür ederim kusursuz çalışıyor

yolcu50 · 20 Kasım 2007

lütfen yardım

yolcu50 · 20 Kasım 2007

ustam aşağıdaki programı dosyamın birinde kullanıyorum. diğer bir dosyamda bunu kullanmak istiyorum ve bu kod yardımı ile rapor verirken g sütununda mevcut yazıları silmemesi gerekiyor düzenlemeniz mümkünmü saygılarımla..... şimdiden teşekkür ederim.

Sub AktarSay()
Dim a, i, n, k, b(), z
Set s1 = Sheets("EL TELSİZİ")
Set s2 = Sheets("SARJ CİHAZI")
'*******************************************
a = s1.Range("a2:h" & 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, 4) & ":" & a(i, 5)
If Not .exists(z) Then
n = n + 1
b(n, 1) = a(i, 1)
b(n, 5) = a(i, 5)
b(n, 6) = a(i, 6)
.Add z, n
End If
b(.Item(z), 8) = b(.Item(z), 8) + 1
End If
Next
End With
s2.Range("a2:a500").ClearContents
s2.Range("e2:g500").ClearContents
s2.[a2].Resize(n, 1).Value = b
For x = 1 To UBound(b)
For j = 5 To 8
Cells(x + 1, j) = b(x, j)
Next j
Next
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

yolcu50 · 21 Kasım 2007

ustalarım lütfen yardım o kadar zor bir soru değil kanısındayım

yolcu50 · 21 Kasım 2007

lÜtfen Yardim