• DİKKAT

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

Birleştirilmiş hücrelerin makro ile toplanması

  • Konbuyu başlatan Konbuyu başlatan izcik
  • Başlangıç tarihi Başlangıç tarihi
I

izcik

Katılım
18 Mayıs 2009
Mesajlar
1,184
Excel Vers. ve Dili
Excel 2016 Türkçe
Günaydın uzmanlarım. Sayfa 1 deki miktarları,
Sayfa 2 de olduğu gibi hem birleştirip hem de toplayacak kodu yazabilir misiniz.

Çözüm aynı sayfada da olabilir, (Mesela 1. sayfada E ve F sütunlarına dökebilir.)

Ya da 2. sayfada olabilir.

Fakat ikisinin de kodunu verebilirseniz çok daha iyi olur. İkisini de öğrenmiş ve denemiş olurum.


Teşekkür ederim kolay gelsin herkese.
 

Ekli dosyalar

Sorunumla ilgili öneriniz varmı değerli uzmanım
 
Değerli uzmanlarım sorunumu çözecek gerekli kodu merakla bekliyorum :)
 
Uzmanamele uzmanım mesajımı farketmediğinizi düşündüğümden aynı mesajın tekrarını yazmak durumunda kaldım, rica etsem gerekli kodları verebilir misiniz?
 
Dosyanız ektedir.:cool:
Kod: 
Sub toplamlar()
Dim i As Long, sat As Long, son As Long
Sheets("Sayfa2 BÖYLE OLMALI").Select
Application.ScreenUpdating = False
Range("A2:B65536").ClearContents
sat = 2
With Sheets("Sayfa1 BU SAYFA")
    son = .Cells(65536, "A").End(xlUp).Row
    For i = 2 To son
        If WorksheetFunction.CountIf(.Range("A2:A" & i) _
        , .Cells(i, "A").Value) = 1 Then
            Cells(sat, "A").Value = .Cells(i, "A").Value
            Cells(sat, "B").Value = WorksheetFunction.SumIf(.Range("A" & _
            i & ":A" & son), .Cells(i, "A").Value, .Range("B" & i & ":B" & son))
            sat = sat + 1
        End If
    Next i
End With
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır." & vbLf & vbLf & _
"evrengizlenqhotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
 

Ekli dosyalar

Evren Gizlen uzmanım teşekkür ederim. Stresten patlayacaktım.

Fakat hücreler birleşmiş haliyle kalmalı. Çünkü yanındaki sütunlarda başka bilgiler mevcut.

Size zahmet olacak ama.. Tıpkı örnekteki gibi yapabilir misiniz?
 
izcik' Alıntı:
Evren Gizlen uzmanım teşekkür ederim. Stresten patlayacaktım.

Fakat hücreler birleşmiş haliyle kalmalı. Çünkü yanındaki sütunlarda başka bilgiler mevcut.

Size zahmet olacak ama.. Tıpkı örnekteki gibi yapabilir misiniz?
Genişletmek için tıkla ...
En illet kaptığım şey şu hücre birleştirmeleri,biçimlendirmeler falan.Bunlar VBA'ya ters geliyor.Bu işlere ben girmek istemiyorum.Bu yüzden burdan sonrası için ben yokum.:cool:
 
Yani aynı kodlu ürünler birleşecek (exceldeki birleştir ve ortala düğmesinin yaptığı gibi)

Ve bu ürünlere ait miktarlar toplanıp, aynı büyüklükte birleşmiş olan hücrenin içine aktarılacak
 
Canınız sağolsun.

Teşekkürler tekrar ilgilendiğiniz için Evren Uzmanım.
 
Selamlar,

Aşağıdaki kodu denermisiniz. Sayfa isimlerinizi koddaki isimlere göre düzenlemeyi unutmayın.

Kod: 
Option Explicit
 
Sub VERİLERİ_DÜZENLE_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim SATIR As Long, X As Long, SAY As Integer, TOPLAM As Double
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S2.Range("A2:B65536").Clear
    SATIR = 2
    S2.Columns("A:B").HorizontalAlignment = xlCenter
    For X = 2 To S1.Range("A65536").End(3).Row
        SAY = WorksheetFunction.CountIf(S1.Range("A:A"), S1.Cells(X, 1))
        TOPLAM = WorksheetFunction.SumIf(S1.Range("A:A"), S1.Cells(X, 1), S1.Range("B:B"))
        
        If WorksheetFunction.CountIf(S2.Range("A:A"), S1.Cells(X, 1)) = 0 Then
            If SAY > 1 Then
                With S2.Range("A" & SATIR & ":A" & SATIR + SAY - 1)
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Value = S1.Cells(X, 1)
                End With
                With S2.Range("B" & SATIR & ":B" & SATIR + SAY - 1)
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Value = TOPLAM
                End With
            Else
                S2.Cells(SATIR, 1) = S1.Cells(X, 1)
                S2.Cells(SATIR, 2) = TOPLAM
            End If
            
            SATIR = SATIR + SAY
        End If
    Next
    S2.Select
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Değerli Uzmanım Korhan Ayhan. Elinize emeğinize sağlık. Tam istediğim gibi. Saygılar.
 
Selam arkadaşlar ve uzmanlarım. Örnekte açıkladığım gibi daha öncekinin tam tersi işi yapacak kod lazım.

Yani birleştirilmiş hücreleri normal hale getirecek.
 

Ekli dosyalar

Merhaba,

Aşağıdaki kodları dener misiniz?

Kod: 
Sub UnMerge()
Dim i As Long
Dim Deger As String
For i = 2 To [A65536].End(3).Row + 1
    If Range("A" & i).MergeArea.Count > 1 Then
        Cells(i, "A").UnMerge
        Deger = Cells(i, "A")
    Else
        Cells(i, "A") = Deger
    End If
Next i
End Sub
 

Ekli dosyalar

Teşekürler Necdet Yeşertener uzmanım. Bu değişikliği -eğer zor değilse- ikinci sayfada oluşacak şekilde yapabilir misiniz acaba?

Yani düğmeye basınca istenen sonuç ikinci sayfada oluşsun.

Saygılar
 
Merhaba,

Kod: 
Sub UnMerge()
Dim i       As Long
Dim Deger   As String
[COLOR=red]Dim s1 As Worksheet
Dim s2 As Worksheet[/COLOR]
[COLOR=red]Set s1 = Sheets("Sayfa1 BU SAYFA")
Set s2 = Sheets("Sayfa2 BÖYLE OLMALI")[/COLOR]
[COLOR=red]s1.Range("A:A").Copy s2.Range("A1")
s2.Select[/COLOR]
For i = 2 To [A65536].End(3).Row + 1
    If Range("A" & i).MergeArea.Count > 1 Then
        Cells(i, "A").UnMerge
        Deger = Cells(i, "A")
    Else
        Cells(i, "A") = Deger
    End If
Next i
End Sub
 
Elinize fikrinize sağlık Necdet Yeşertener uzmanım.

Yalnız bir hatayı farkettim. ÜRÜN 3 yazan hücre , bu kodda da (mesaj 19) bir öncekinde de (mesaj 17) çıkmıyor.

ÜRÜN KODU
ÜRÜN 1
ÜRÜN 1
ÜRÜN 1
ÜRÜN 1
ÜRÜN 2
ÜRÜN 2
ÜRÜN 2
ÜRÜN 2
ÜRÜN 2
ÜRÜN 3
ÜRÜN 4
ÜRÜN 4
ÜRÜN 4
ÜRÜN 5
ÜRÜN 5


böyle olmalı

.........
Oysa ÜRÜN 3


ÜRÜN 2 nin içine dahil oluyor.
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst