• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Veri aktarma Aynı isimleri teke düşürerek ve toplayarak aktarma

A

Ahmet Sami

Katılım
10 Kasım 2006
Mesajlar
399
Excel Vers. ve Dili
microsoft office 2007-2010-2013-2019-2021
Arkadaşlar, ekte gönderdiğim dosyada görüldüğü üzere bir tablom var, buradaki işlemlerimi B sütununda bulunan yaka numaralarına göre yapıyorum. Yani buraya veri girdiğim zaman Bazen aynı veriler tekrar girilebiliyor, sizden istediğim yardım, bu girilmiş verileri ÖDEME sayfasına B3:P sütunlarının aynen aktarılması ancak burada önemli olan iki veya üç defa aynı girilmiş verilerim var bunları aktarılırken TEKE DÜŞÜREREK aktarması ve üçününde M sütunundaki para miktarlarının TOPLAMINI alarak aktarması dır. VERİ ve ÖDEME sayfalarına bakmak sureti ile ne demek istediğimi daha iyi anlayacağınızı umut ediyor ve yardımlarınızı bekliyoruz inşallah.
 

Ekli dosyalar

Sayfa üzerine düğme ekleyip kod bölümüne aşağıdaki kodu ekleyerek denermisin.
Kod: 
Sub Düğme5_Tıklat()
Application.ScreenUpdating = False
On Error Resume Next
Set S1 = ThisWorkbook.Worksheets("VERİ") 
Set S2 = ThisWorkbook.Worksheets("ÖDEME")
SON = S1.Range("A65536").End(xlUp).Row
A = 3: B = 1
For i = 2 To S2.Range("B65536").End(xlUp).Row 
     If S1.Cells(A, "B") >= S1.Range("B3:B" & SON) Then
       S2.Cells(i, "A") = B
       S2.Cells(i, "C") = S1.Cells(A, "C")
       S2.Cells(i, "D") = S1.Cells(A, "D")
       S2.Cells(i, "E") = S1.Cells(A, "E")
       S2.Cells(i, "F") = S1.Cells(A, "F")
       S2.Cells(i, "G") = S1.Cells(A, "G")
       S2.Cells(i, "H") = S1.Cells(A, "H")
       S2.Cells(i, "I") = S1.Cells(A, "I")
       S2.Cells(i, "J") = S1.Cells(A, "J")
       S2.Cells(i, "K") = S1.Cells(A, "K")
       S2.Cells(i, "L") = S1.Cells(A, "L")
       S2.Cells(i, "M") = WorksheetFunction.SumIf(S1.Range("B2:B" & SON), S2.Cells(i, "B").Value, S1.Range("M2:M" & SON))
       S2.Cells(i, "N") = WorksheetFunction.SumIf(S1.Range("B2:B" & SON), S2.Cells(i, "B").Value, S1.Range("N2:N" & SON))
       S2.Cells(i, "O") = WorksheetFunction.SumIf(S1.Range("B2:B" & SON), S2.Cells(i, "B").Value, S1.Range("O2:O" & SON))
       S2.Cells(i, "P") = S1.Cells(A, "P")
     End If
  A = A + 1: B = B + 1
Next i
End Sub
 
Son düzenleme:
Ahmet Sami' Alıntı:
Arkadaşlar, ekte gönderdiğim dosyada görüldüğü üzere bir tablom var, buradaki işlemlerimi B sütununda bulunan yaka numaralarına göre yapıyorum. Yani buraya veri girdiğim zaman Bazen aynı veriler tekrar girilebiliyor, sizden istediğim yardım, bu girilmiş verileri ÖDEME sayfasına B3:P sütunlarının aynen aktarılması ancak burada önemli olan iki veya üç defa aynı girilmiş verilerim var bunları aktarılırken TEKE DÜŞÜREREK aktarması ve üçününde M sütunundaki para miktarlarının TOPLAMINI alarak aktarması dır. VERİ ve ÖDEME sayfalarına bakmak sureti ile ne demek istediğimi daha iyi anlayacağınızı umut ediyor ve yardımlarınızı bekliyoruz inşallah.
Genişletmek için tıkla ...

Alternatif kod
Kod:

Kod: 
Sub Gruplandir()

ZBasla = TimeValue(Now)
zaman = Timer

Application.Calculation = xlManual


Set S1 = Sheets("VERİ") ' veri sayfası
Set S2 = Sheets("ÖDEME") 'aktarılan sayfa

S2.Range("a2:p" & Rows.Count).ClearContents 'Clear
son1 = S1.Cells(Rows.Count, "b").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 3 To son1
ara1(j) = WorksheetFunction.Trim(S1.Cells(j, "b")) ' & WorksheetFunction.Trim(s1.Cells(j, "c"))
ara2(j) = 1
Next j

sat1 = 2

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

sut2 = 0
If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
sut2 = sut2 + CDbl(S1.Cells(i, "m").Value)
ara2(i) = 0
End If
Next i


S2.Cells(sat1, 1).Value = sat1 - 1
For t = 2 To 16
S2.Cells(sat1, t).Value = S1.Cells(r, t).Value
Next t
S2.Cells(sat1, "m").Value = sut2

sat1 = sat1 + 1

End If
Next r

Application.Calculation = xlAutomatic


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
 
Halit Üstadım teşekkür ederim emeğinize sağlık, yalnız N ve O sütunları da toplanacaktı onu unutmuşum, Hakkınızı helal edin zamanınızı alıyorum, göndermiş olduğunuz kodu o şekilde değiştirebilir misiniz. Yani M, N ve O sütunları toplanacak aynı M sütunu gibi.
 
Son düzenleme:
Sayın Vardar, kodu denedim ama hata vermiyor fakat herhangi bir işlem de yapmıyor, yani aktarma işlemi yapmıyor.
 
2 nolu mesajdaki kodlar değiştirildi.Deneme amaçlı sayfa3 e kayıt ediyordu.
 
Sayın Vardar, Kodu denedim dediğim gibi hata vermiyor ama aktarmada yapmıyor, nerede hata yaptığımı bilemiyorum.
 
Dosyanız ekte. Neyi nasıl yaptığınızı bilmiyorum. Yaptığınız ile dosyayı karşılaştırıp hatayı bulabilirsiniz. Ayrıca halit beyin kodunuda ayrı bir düğmeye ekledim ikisinide denersiniz.
 

Ekli dosyalar

Sayın Vardar, hatayı buldum, ÖDEME sayfasında ki B sütununda yaka no olmayınca sizin yazmış olduğunuz kod çalışmıyor. Ancak orada yaka no olursa aktarma yapıyor. Onu düzeltirseniz güzel olacak inşallah.

Ayrıca İdris bey size de teşekkür ediyorum. Ancak sayfa3' ü kullanmamam gerekiyor.
 
Ahmet Sami' Alıntı:
Halit Üstadım teşekkür ederim emeğinize sağlık, yalnız N ve O sütunları da toplanacaktı onu unutmuşum, Hakkınızı helal edin zamanınızı alıyorum, göndermiş olduğunuz kodu o şekilde değiştirebilir misiniz. Yani M, N ve O sütunları toplanacak aynı M sütunu gibi.
Genişletmek için tıkla ...

kod:

Kod: 
Sub Gruplandir()

ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual


Set S1 = Sheets("VERİ") ' veri sayfası
Set S2 = Sheets("ÖDEME") 'aktarılan sayfa

S2.Range("a2:p" & Rows.Count).ClearContents 'Clear
son1 = S1.Cells(Rows.Count, "b").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 3 To son1
ara1(j) = WorksheetFunction.Trim(S1.Cells(j, "b")) ' & WorksheetFunction.Trim(s1.Cells(j, "c"))
ara2(j) = 1
Next j

sat1 = 2

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

sut13 = 0
sut14 = 0
sut15 = 0

If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
sut13 = sut13 + CDbl(S1.Cells(i, "m").Value)
sut14 = sut14 + CDbl(S1.Cells(i, "n").Value)
sut15 = sut15 + CDbl(S1.Cells(i, "o").Value)
ara2(i) = 0
End If
Next i


S2.Cells(sat1, 1).Value = sat1 - 1
For t = 2 To 16
If t = 13 Or t = 14 Or t = 15 Then
Else
S2.Cells(sat1, t).Value = S1.Cells(r, t).Value
End If
Next t

S2.Cells(sat1, "m").Value = sut13
S2.Cells(sat1, "n").Value = sut14
S2.Cells(sat1, "o").Value = sut15

sat1 = sat1 + 1

End If
Next r

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
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
 
Halit bey çok teşekkür ederim. Emeğinize ve elinize sağlık, Allah zihninizi açık etsin, ayrıca bize vaktini ayıran diğer Üstadlara da teşekkür ediyorum.
 
vardar07' Alıntı:
Dosyanız ekte. Neyi nasıl yaptığınızı bilmiyorum. Yaptığınız ile dosyayı karşılaştırıp hatayı bulabilirsiniz. Ayrıca halit beyin kodunuda ayrı bir düğmeye ekledim ikisinide denersiniz.
Genişletmek için tıkla ...

Merhaba

Ödeme sayfasındaki verileri silip kodunuzu o zaman çalıştırın verileri aktarmadığını göreceksiniz.
 
Ahmet Sami' Alıntı:
Sayın Vardar, hatayı buldum, ÖDEME sayfasında ki B sütununda yaka no olmayınca sizin yazmış olduğunuz kod çalışmıyor. Ancak orada yaka no olursa aktarma yapıyor. Onu düzeltirseniz güzel olacak inşallah.

Ayrıca İdris bey size de teşekkür ediyorum. Ancak sayfa3' ü kullanmamam gerekiyor.
Genişletmek için tıkla ...

.

Yaptığım dosyayı anladığınızı pek sanmıyorum. Çünkü beyan ettiğiniz mazeret geçerli değil.

Mevcut ÖDEME sayfasını silin. Sayfa3'ün adını ÖDEME diye değiştirin. Bu kadar basit.

Sayfa3'süz dosya ekte.
.



.
 

Ekli dosyalar

Halit bey, merhaba.

Bu tabloda AY kolonu olsaydı, yana doğru aylara göre toplamları nasıl yazardık.

Teşekkür.



halit3' Alıntı:
kod:

Kod: 
Sub Gruplandir()

ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual


Set S1 = Sheets("VERİ") ' veri sayfası
Set S2 = Sheets("ÖDEME") 'aktarılan sayfa

S2.Range("a2:p" & Rows.Count).ClearContents 'Clear
son1 = S1.Cells(Rows.Count, "b").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 3 To son1
ara1(j) = WorksheetFunction.Trim(S1.Cells(j, "b")) ' & WorksheetFunction.Trim(s1.Cells(j, "c"))
ara2(j) = 1
Next j

sat1 = 2

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

sut13 = 0
sut14 = 0
sut15 = 0

If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
sut13 = sut13 + CDbl(S1.Cells(i, "m").Value)
sut14 = sut14 + CDbl(S1.Cells(i, "n").Value)
sut15 = sut15 + CDbl(S1.Cells(i, "o").Value)
ara2(i) = 0
End If
Next i


S2.Cells(sat1, 1).Value = sat1 - 1
For t = 2 To 16
If t = 13 Or t = 14 Or t = 15 Then
Else
S2.Cells(sat1, t).Value = S1.Cells(r, t).Value
End If
Next t

S2.Cells(sat1, "m").Value = sut13
S2.Cells(sat1, "n").Value = sut14
S2.Cells(sat1, "o").Value = sut15

sat1 = sat1 + 1

End If
Next r

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
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
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst