Hücre bilgisi aynı olan değerleri tek satırda toplama

gezin23 · 27 Mart 2015

Herkese selamlar.
Eklediğim dosyada ilk satıda T.C. numarası ikinci sütunda Veri Tipi Diğer sütunlarda ise gün sayıları yer almakta. T.C nosu ve veri tipi aynı olan hücrelerin gün sütunlarındaki değerleri toplayıp tek satırda göstermesini istiyorum.
Yardımlarınızı bekliyorum.

Ömer BARAN · 27 Mart 2015

Merhabalar.
Yanlış anlamadıysam, ekli belgenin AH:AJ hücre aralığında istediğiniz sonuç elde edilmiştir.
İyi günler dilerim.

gezin23 · 27 Mart 2015

İyi akşamlar Ömer Baran Bey; TCKN ve Veri Tip aynı olan satırları tek satırda toplamasını istiyorum. Yani Gün1 den gün 31 e kadar olan her iki satırın değerlerini toplayıp tek satırda göstersin.

Ömer · 28 Mart 2015

Merhaba,

Bu şekilde deneyin. Listelemeyi Sayfa2 de yapar.

Kod:

Sub Topla_Aktar()
 
    Dim d As Object, i As Long, sat As Long, j As Byte, s, a1, a3, deg

    Set d = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select

    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        deg = Cells(i, "A") & "|" & Cells(i, "B")
        If Not d.exists(deg) Then
            ReDim s(1 To 33)
            For j = 1 To 33
                s(j) = Cells(i, j)
            Next j
            d.Add deg, s
        Else
            s = d.Item(deg)
            For j = 3 To 33
                a3 = Cells(i, j)
                If a3 = "" Then a3 = 0
                s(j) = s(j) + a3
            Next j
            d.Item(deg) = s
        End If
    Next i

    Sheets("Sayfa2").Select
    Range("A:AG").ClearContents
    
    a1 = d.items: sat = 1
    For i = 0 To d.Count - 1
        s = a1(i)
        For j = 1 To 33
            Cells(sat + i, j) = s(j)
        Next j
    Next i
    
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True

End Sub

.

halit3 · 28 Mart 2015

Alternatif kod

Kod dosyanızdaki sayfa1 deki verileri sayfa2 ye toplayarak aktarır.

Kod:

Sub Gruplandir1()

ZBasla = TimeValue(Now)
zaman = Timer

Set s1 = Sheets("Sayfa1") ' veri sayfası
Set s2 = Sheets("Sayfa2") 'aktarılan sayfa

s2.Range("a1:ag" & Rows.Count).Clear
son1 = s1.Cells(Rows.Count, "a").End(3).Row
son2 = 65000
ReDim ara1(son2): ReDim ara2(son2): ReDim ara3(son2):

For j = 2 To son1
ara1(j) = WorksheetFunction.Trim(s1.Cells(j, "a")) & WorksheetFunction.Trim(s1.Cells(j, "b"))
ara2(j) = 1
Next j

sat1 = 2

For m = 1 To 33
s2.Cells(1, m).Value = s1.Cells(1, m).Value 'baslık
Next m


For r = 2 To son1
aranan1 = ara1(r)

sut2 = 0
If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
ara2(i) = 0
For t = 2 To 33
If IsNumeric(s1.Cells(i, t).Value) = True And s1.Cells(i, t).Value > 0 Then

ara3(t) = ara3(t) + CDbl(s1.Cells(i, t).Value)
End If
Next
End If
Next i

s2.Cells(sat1, 1).Value = s1.Cells(r, 1).Value
s2.Cells(sat1, 2).Value = s1.Cells(r, 2).Value

For t = 2 To 33
s2.Cells(sat1, t).Value = ara3(t)
ara3(t) = 0
Next t

sat1 = sat1 + 1

End If
Next r

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

gezin23 · 30 Mart 2015

Halit Bey ve Ömer Bey, çok teşekkür ederim...

tahsinanarat · 5 Nisan 2015

Sn. Ömer ve Halit hocam sütunları ardaşık değilde yani 3. sutundan sonra 31 sutuna kadar değilde bunların arasından belirtiğimiz sütunları toplatıp aktarmak isteseydik kodlarda nasıl bir değişiklik olurdu, örneğin d, e, k, m .. gibi sütunların toplamını almak isteseydik. Teşekkürler.

Ömer · 5 Nisan 2015

Bu şekilde deneyin.

Kod:

Sub Topla_Aktar()
 
    Dim d As Object, i As Long, sat As Long, j As Byte
    Dim s, a1, a3, deg, toplam(), t As Integer

    Set d = CreateObject("Scripting.Dictionary")
    [COLOR="Blue"]toplam = Array("D", "E", "K", "M"[/COLOR]) [COLOR="DarkGreen"]'toplam sütunları[/COLOR]

    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select

    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        deg = Cells(i, "A") & "|" & Cells(i, "B")
        If Not d.exists(deg) Then
            ReDim s(1 To 33)
            For j = 1 To 33
                s(j) = Cells(i, j)
            Next j
            d.Add deg, s
        Else
            s = d.Item(deg)
            For j = [COLOR="blue"]1[/COLOR] To 33
[COLOR="Blue"]                For t = 0 To UBound(toplam)
                    If j = Range(toplam(t) & 1).Column Then[/COLOR]
                        a3 = Cells(i, j)
                        If a3 = "" Then a3 = 0
                        s(j) = s(j) + a3
[COLOR="blue"]                    End If
                Next t[/COLOR]
            Next j
            d.Item(deg) = s
        End If
    Next i

    Sheets("Sayfa2").Select
    Range("A:AG").ClearContents
    
    a1 = d.items: sat = 1
    For i = 0 To d.Count - 1
        s = a1(i)
        For j = 1 To 33
            Cells(sat + i, j) = s(j)
        Next j
    Next i
    
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True

End Sub

.

halit3 · 5 Nisan 2015

Alternatif kod

Kod:

Sub Gruplandir2()

ZBasla = TimeValue(Now)
zaman = Timer

Set s1 = Sheets("Sayfa1") ' veri sayfası
Set s2 = Sheets("Sayfa2") 'aktarılan sayfa

s2.Range("a1:ag" & Rows.Count).Clear
son1 = s1.Cells(Rows.Count, "a").End(3).Row
son2 = 65000

ReDim ara1(son2): ReDim ara2(son2): ReDim ara3(son2):

[COLOR="Red"]
son3 = 4
ReDim ara4(son3):

ara4(1) = 4  'd
ara4(2) = 5  'e
ara4(3) = 11 'k
ara4(4) = 13 'm


s2.Cells(1, 1).Value = s1.Cells(1, 1).Value
s2.Cells(1, 2).Value = s1.Cells(1, 2).Value
For t = 1 To son3
s2.Cells(1, t + 2) = s1.Cells(1, ara4(t) + 2).Value
Next t[/COLOR]


For j = 2 To son1
ara1(j) = WorksheetFunction.Trim(s1.Cells(j, "a")) & WorksheetFunction.Trim(s1.Cells(j, "b"))
ara2(j) = 1
Next j

sat1 = 2

For r = 2 To son1
aranan1 = ara1(r)

If ara2(r) = 1 Then


For i = r To son1
If ara1(i) = aranan1 Then
ara2(i) = 0
For m = 1 To [COLOR="red"]son3[/COLOR]
If IsNumeric(s1.Cells(i, [COLOR="red"]ara4(m) + 2[/COLOR])) = True And s1.Cells(i, [COLOR="red"]ara4(m) + 2[/COLOR]) > 0 Then
ara3(m) = ara3(m) + CDbl(s1.Cells(i, [COLOR="red"]ara4(m) + 2[/COLOR]).Value)
End If
Next m
End If
Next i


s2.Cells(sat1, 1).Value = s1.Cells(r, 1).Value
s2.Cells(sat1, 2).Value = s1.Cells(r, 2).Value

For t = 1 To [COLOR="red"]son3[/COLOR]
s2.Cells(sat1, t + 2).Value = ara3(t)
ara3(t) = 0
Next t

sat1 = sat1 + 1

End If
Next r

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

tahsinanarat · 5 Nisan 2015

Sn. hocalarım her ikinizi de ayrı ayrı teşekkür ederim, ileride bu kodlar işime yarayacak, tabii ki başkalarının da işine yarayacağından eminim. Elinize sağlık. Saygılar.

halit3 · 5 Nisan 2015

Bu kod da farklı

Kod:

Sub Gruplandir4()

ZBasla = TimeValue(Now)
zaman = Timer

Set s1 = Sheets("Sayfa1") ' veri sayfası
Set s2 = Sheets("Sayfa2") 'aktarılan sayfa

s2.Range("a1:ag" & Rows.Count).Clear
son1 = s1.Cells(Rows.Count, "a").End(3).Row
son2 = 65000

ReDim ara1(son2): ReDim ara2(son2): ReDim ara3(son2):

[COLOR="Red"]son3 = 4
ReDim ara4(son3):

ara4(1) = "d"
ara4(2) = "e"
ara4(3) = "k"
ara4(4) = "m"
[/COLOR]

For t = 1 To 33
s2.Cells(1, t) = s1.Cells(1, t).Value
Next t


For j = 2 To son1
ara1(j) = WorksheetFunction.Trim(s1.Cells(j, "a")) & WorksheetFunction.Trim(s1.Cells(j, "b"))
ara2(j) = 1
Next j

sat1 = 2

For r = 2 To son1
aranan1 = ara1(r)

    If ara2(r) = 1 Then
    
    
        For i = r To son1
        If ara1(i) = aranan1 Then
        ara2(i) = 0
        
            For m = 3 To 33
                For k = 1 To [COLOR="red"]son3[/COLOR]
                    If m = [COLOR="red"]Cells(1, ara4(k)).Column [/COLOR]Then
                        If IsNumeric(s1.Cells(i, m)) = True And s1.Cells(i, m) > 0 Then
                        ara3(m) = ara3(m) + CDbl(s1.Cells(i, m).Value)
                        End If
                    End If
                Next k
            Next m
        
        End If
        Next i
    
    
        s2.Cells(sat1, 1).Value = s1.Cells(r, 1).Value
        s2.Cells(sat1, 2).Value = s1.Cells(r, 2).Value
        
        For t = 3 To 33
            If ara3(t) > 0 Then
            s2.Cells(sat1, t).Value = ara3(t)
            End If
            ara3(t) = 0
        Next t
    
    sat1 = sat1 + 1
    
    End If
Next r

zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

Hücre bilgisi aynı olan değerleri tek satırda toplama

gezin23

Ekli dosyalar

Ömer BARAN

Uzman

Ekli dosyalar

gezin23

Ömer

Moderatör

halit3

Uzman

gezin23

tahsinanarat

Ömer

Moderatör

halit3

Uzman

tahsinanarat

halit3

Uzman