Benzer Kayıtların Üstüne Satır Ekle

[hsayar]

Arkadaşlar soum şu c sütununda aynı kayıtalr bulundukça üstüne bir satır ekleyecek ve c sütunundaki ilk benzersiz değeri b sütunda eklenen satıra kopyalayacak ve diğer benzersiz kayıtları silecek mümkünmüdür.

örnek dosya eklendi.....

 

[hsayar]

Güncel yardımlarınız için teşekkürler....
Biraz daha açıklama ekleyeyim amacım tam anlaşılmadığı için soruma cevap gelmedi herhalde;
C Sütununda Ana Başlıklarımız var
Mesala
C2:C7 Aralığında yer alan Kira başlığımız için;
2. satırın üstüne yeni satır eklenecek ve verilerin olduğu aralık otomatik olarak c3:c8 olacak.
C3 teki değer b2 olacak ve C3:C8 içeriği temizlenecek.

bu işlem c sütununda her Anabaşlık için uygulanacak.

Daha sonra D sütununda yer alan Alt başlıklarımıza bakacak (mesela A)
Şu an D24 te gözüken ama kaydırma sonucu ile D35 aralığına kayan verilerimiz için
3. satırın üstüne yeni bir satır eklenecek ve verilerimiz doğal olarak D46 ya kayacak
3. satırımızın c sütununa d4 teki değer eşitlenecek.
ve bu böyle devam edewcek.

 

[hsayar]

Güncel yardımlarınız için teşekkürler....

 

[hsayar]

Güncel yardımlarınız için teşekkürler....

 

[Ferhat Pazarçevirdi]

Merhabalar

Aşağıdaki kodları, standart bir modül sayfasına kopyalayıp, çalıştırınız.

Sub Tablola()
Dim sh1 As Worksheet, shT As Worksheet
Dim i%, j%, son%
Dim giderTuru As String
Set sh1 = Sheets("Sayfa1")
Set shT = Sheets("TABLOM")
shT.Range("A2:F" & shT.UsedRange.Rows.Count).ClearContents
For i = 2 To sh1.Cells(65536, 4).End(xlUp).Row
    If IsNumeric(sh1.Cells(i, 2)) = False And IsEmpty(sh1.Cells(i, 2)) = False Then: giderTuru = sh1.Cells(i, 2)
    If sh1.Cells(i, 4) <> Empty Then
       son = shT.Cells(65536, 1).End(xlUp).Row + 1
       For j = 1 To 6
           shT.Cells(son, j) = sh1.Cells(i, j)
       Next j
       shT.Cells(son, 3) = giderTuru
    End If
Next i
Set sh1 = Nothing
Set shT = Nothing
End Sub

 

[hsayar]

hocam teşekkür ederim ancak tamamen yanlış anlatmışım

İlk resim ham halimiz,
Şimdi eklediğim boş bir sayfa1 de oluşturulacak görüntü (Tercihen Yeni sayfada) dür

Kırmızı başlıklar eskiden C sütununda tekrar edilen başlıklar; b Sütununda Grup başlığı olarak eklenmiş.

yeni C sütununda D Sütununda Tekrar edilen başlıklar Katagori sonu olarak c sütununda yer almakta.
d üstununda vereiler korunuyor.

Not: WinXp ye Ekran alıntısı aracı eklenmiyormu.

 

[Ferhat Pazarçevirdi]

Nasıl yani ?

TABLOM sayfasındaki veriler mi, Sayfa1 formatına çekilecek ?

 

[hsayar]

evet. doğrudur

 

[Ferhat Pazarçevirdi]

İyi de Hüseyin bey kardeşim

Siz msn'de tarif etmediniz mi bunu bana ..

Neyse ...

 

[hsayar]

İyi de Hüseyin bey kardeşim

Siz msn'de tarif etmediniz mi bunu bana ..

Neyse ...

Zaten resmi eklerkede hatanın bende olduğunu kabul ettim.

 

[hsayar]

bu şekilde olan tabloyu

bu şekle getirmenin bir yolu varmıdır?

 

[Zeki Gürsoy]

Özet tablo sihirbazı işinize yarayabilir.

 

[hsayar]

hocam daha evvel hiç kullanmadım bunu makro ile halledebilmek benim için daha kolay olacaktır...
sizin daha evvel veritabanından ado ile almam için hazırladığınız kodların sonuna eklemem için lazım.

alakadar olabilirseniz gerçekten sevinirim.

 

[hsayar]

Değerli Hocalarım Bu sorumu makro ile çözebilirmiyim. saygılarımla

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodu kullanınız.

Sub Tabloya_Gecir()
Dim shT As Worksheet
Dim sh1 As Worksheet
Dim y%, z%, i%, j%, x%, n%
Dim arrGd()
Dim arrMm()
Set shT = Sheets("TABLOM")
Set sh1 = Sheets("Sayfa1")
y = 1: z = 1
ReDim Preserve arrGd(1 To y)
arrGd(y) = shT.Cells(2, 3)
ReDim Preserve arrMm(1 To 2, 1 To z)
arrMm(1, z) = shT.Cells(2, 3)
arrMm(2, z) = shT.Cells(2, 4)
For i = 2 To shT.Cells(65536, 3).End(xlUp).Row
    For j = 1 To UBound(arrGd)
        If shT.Cells(i, 3) = arrGd(j) Then: x = x + 1
    Next j
    If x = 0 Then
       y = y + 1
       ReDim Preserve arrGd(1 To y)
       arrGd(y) = shT.Cells(i, 3)
    End If
    x = 0
        
    For j = 1 To UBound(arrMm, 2)
        If shT.Cells(i, 3) & shT.Cells(i, 4) = arrMm(1, j) & arrMm(2, j) Then: x = x + 1
    Next j
    If x = 0 Then
       z = z + 1
       ReDim Preserve arrMm(1 To 2, 1 To z)
       arrMm(1, z) = shT.Cells(i, 3)
       arrMm(2, z) = shT.Cells(i, 4)
    End If
    x = 0
Next i
x = 1
For i = 1 To UBound(arrGd)
    x = x + 1
    sh1.Cells(x, 2) = arrGd(i)
    For j = 1 To UBound(arrMm, 2)
        If arrGd(i) = arrMm(1, j) Then
           x = x + 1
           sh1.Cells(x, 3) = arrMm(2, j)
           For n = 2 To shT.Cells(65536, 2).End(xlUp)
               If shT.Cells(n, 3) = arrMm(1, j) And shT.Cells(n, 4) = arrMm(2, j) Then
                  x = x + 1
                  sh1.Cells(x, 1) = shT.Cells(n, 1)
                  sh1.Cells(x, 2) = shT.Cells(n, 2)
                  sh1.Cells(x, 4) = shT.Cells(n, 4)
                  sh1.Cells(x, 5) = shT.Cells(n, 5)
                  sh1.Cells(x, 6) = shT.Cells(n, 6)
               End If
           Next n
           arrMm(1, j) = ""
           arrMm(2, j) = ""
        End If
    Next j
Next i
Set shT = Nothing
Set sh1 = Nothing
End Sub

 

[hsayar]

Ferhat Hocam çok teşekkür ederim, kendim tabloma uyarlama yaparım artık...

 

[hsayar]

sn ferhat hocam size birşey daha danışsam

resminde
Alt grupların toplamını F sütununa,
Ana grubun toplamınıda g sütununa yazdırmak mümkünmüdür.

Yani
g2= topla(e4:e12)
f3=topla(e4:e6)
f7=e8
f9=e10
f11=e12

değer olarak yazsada olur, formul gözükmesin yada hangisi daha kolay ise.

 

[hsayar]

Hocam Kodlarınızı Tabloma uyarladım gibi birşey...
İsteklerimi kodun içine yazdım, kod çalıştıktan sonra nerde ne istediğim belli... tekrar yardım ederseniz sevinirim.

Sub Tabloya_Gecir_Hsr()
Dim shT As Worksheet
Dim sh1 As Worksheet
Dim y%, z%, i%, j%, x%, n%, noAna%, noAlt%
Dim arrGd()
Dim arrMm()
Set shT = Sheets("TABLOM")
Set sh1 = Sheets("Sayfa1")

y = 1: z = 1
ReDim Preserve arrGd(1 To y)
    arrGd(y) = shT.Cells(2, 3)
    
ReDim Preserve arrMm(1 To 2, 1 To z)
    arrMm(1, z) = shT.Cells(2, 3)
    arrMm(2, z) = shT.Cells(2, 4)

For i = 2 To shT.Cells(65536, 3).End(xlUp).Row
    For j = 1 To UBound(arrGd)
        If shT.Cells(i, 3) = arrGd(j) Then: x = x + 1
    Next j
    If x = 0 Then
       y = y + 1
       ReDim Preserve arrGd(1 To y)
       arrGd(y) = shT.Cells(i, 3)
    End If
    x = 0
        
    For j = 1 To UBound(arrMm, 2)
        If shT.Cells(i, 3) & shT.Cells(i, 4) = arrMm(1, j) & arrMm(2, j) Then: x = x + 1
    Next j
    If x = 0 Then
       z = z + 1
       ReDim Preserve arrMm(1 To 2, 1 To z)
       arrMm(1, z) = shT.Cells(i, 3)
       arrMm(2, z) = shT.Cells(i, 4)
    End If
    x = 0
Next i

'Diziye alınanları sayfaya aktar
With sh1
    .Cells.Clear
    .Columns(1).ColumnWidth = 5.14
    '.Columns(1).HorizontalAlignment = xlRight
    .Columns("B:I").ColumnWidth = 5
    .Columns("J").ColumnWidth = 8
    .Columns("K:M").ColumnWidth = 10
    .Columns("N").ColumnWidth = 5
    With .Cells(3, 1)
        .Value = shT.Cells(2, 2)            'Bütçe Yılı
        .Font.Bold = True
    End With
    With .Cells(3, 2)
         .Value = "Bütçe Yılı Tablosudur"
         .Font.Bold = True
    End With
    With .Cells(4, 1)
         .Value = "Çeltik Üretim Maliyetine Etki Eden Faktörler"
         .Font.Bold = True
         .HorizontalAlignment = xlLeft
         .Select
    End With
End With

x = 5: noAna = 1                              'Başlangıç Satır nosu
For i = 1 To UBound(arrGd)
    x = x + 1
    With sh1
        With .Cells(x, "A")
                            .Value = noAna & " )[Kodun Soldan Uzunluğun İki eksik Kısmı burada yazsın]"
                            .Font.ColorIndex = 3
                            .Font.Bold = True
        End With
        With .Cells(x, "M")
                           .Value = "Ana Grup Toplamı(Mesala;Sadece Kiralar)"
                           .Font.ColorIndex = 3
                           .Font.Bold = True
        End With
    End With
    '=(PARÇAAL(F15;1;UZUNLUK(F15)-2))*1 yani formulü ile elde edilen kısım
    '1504 için 15, 105 için 1 gibi
    sh1.Cells(x, 2) = arrGd(i)                  'Gider Ana Başlığının Yazılacağı Sütun: E
   noAlt = 1
    For j = 1 To UBound(arrMm, 2)
        If arrGd(i) = arrMm(1, j) Then
           x = x + 1
'           sh1.Cells(x, 2) = noAna & "-" & noAlt & " )"
           With sh1
               With .Cells(x, "B")
                                  .Value = "Kodun Tamamı 101,102,105,1601 vs"
                                  .Font.ColorIndex = 3
                                  .Font.Bold = True
               End With
                    .Cells(x, "C").Value = arrMm(2, j)          'Masraf Merk.nin Yazılacağı Sütun: F
               With .Cells(x, "L")
                                  .Value = "Alt Grup Toplamı(Mesala;Sadece Kira-Kumdereler)"
                                  .Font.ColorIndex = 3
                                  .Font.Bold = True
               End With
           End With
           For n = 2 To shT.Cells(65536, 2).End(xlUp)
                'sh1.Cells(x, 2) = noAna & "-" & noAlt & " )"

               If shT.Cells(n, 3) = arrMm(1, j) And shT.Cells(n, 4) = arrMm(2, j) Then
                  x = x + 1

'                  sh1.Cells(4, 1) = shT.Cells(n, 2)            'Bütçe Yılı
                  With sh1
                     With .Cells(x, "C")
                                       .Value = "Sırano 1,2,3 gibi"
                                       .Font.ColorIndex = 3
                                       .Font.Bold = True
                    End With
                          .Cells(x, "D").Value = shT.Cells(n, 4)            'Masraf Merkezi
                          .Cells(x, "I").Value = shT.Cells(n, 1)            'Maliyet Yılı
                          .Cells(x, "J").Value = "Bütçesinden"              'Açıklaması
                      With Cells(x, "K")
                                        .Value = shT.Cells(n, 5)           'Tutarı
                                        .NumberFormat = "#,##0.00"
                      End With
                  End With
                  'kod = shT.Cells(n, 6)
                  'sh1.Cells(x, 12) = shT.Cells(n, 6)           'Kodu
               End If
           Next n
           arrMm(1, j) = ""
           arrMm(2, j) = ""
        End If
        noAlt = noAlt + 1
    Next j
    noAna = noAna + 1
Next i



Set shT = Nothing: Set sh1 = Nothing
End Sub