Hücreleri numaralara göre bölme

[siranel]

excelde toplam 50.000 hücreli 2 sütunlu yazım var

1 excelsutunu1
1 excelsutunu2
2 sorusu1
2 cevabı2
3 ayşe1
4 ayşe2

gibi solda id var sağda içerik id numaralarına göre bunların arasına en azından bir boşluk verebilmek yada aynı id numarasının karşısındaki sütunları bir arada toplamak istiyorum

örnek 1
1 excelsutunu1
1 excelsutunu2

2 sorusu1
2 cevabı2

3 ayşe1
3 ayşe2

yada örnek 2
1 excelsutunu1 - excelsutunu2
2 sorusu1 - sorusu 2

50.000 içerik olması çok büyük sıkıntı oluyor
ben bunları ufak ufak hücrelere de bölebilirim ama 50.000 hücreyi tek tek elden geçirmek zor oluyor

excel sayfamda 50.000 sütun 21.000 benzersiz id var
bu 21 bin id nin arasına en azından bir boşluk ekleyebilmem gerekiyor yardımcı olmak isteyen istemeyn herkese teşekkür ederim, hayırlı ramazanlar..

 

[Korhan Ayhan]

Merhaba,

Dosyanızı paylaşım sitelerine yükleyip forumda paylaşırsanız daha hızlı yanıt alabilirsiniz.

Nasıl bir sonuç görmek istiyorsanız dosyanızda belirtiniz.

 

[siranel]

https://turkiyemobilyalari.com/excel-sutun-listeleme.xlsx
hocam linkte örnek bir dosya var kısa olması açısından demo içerik yaptım,
asıl dosya 50.000 hücreden oluşuyor.
sayfa1 orjinal hali
sayfa2 yada sayfa3 istediğim hali önemli olan şekillerdeki gibi id'ye göre ayıklanabilir hale getirmek.

 

[Ömer BARAN]

Merhaba.

Sanırım Sayın AYHAN müsait değil.
Aşağıdaki kod'u kullanabilirsiniz.
-- Verilerin alınacağı sayfa kaynak,
-- İşlem sonuçlarının yazılacağı sayfa hedef

İlave not: Makronun, belgeye nasıl uygulanacağı ve
nasıl çalıştırılacağına ilişkin açıklama 6 numaralı cevapta mevcuttur.
.

[B]Sub DUZENLE()[/B]
Set [B][COLOR="Red"]k[/COLOR][/B] = Sheets("[B][COLOR="Red"]kaynak[/COLOR][/B]"): Set h = Sheets("[B][COLOR="Blue"]hedef[/COLOR][/B]")
If [B][COLOR="Blue"]h.[/COLOR][/B]Cells(Rows.Count, 1).End(3).Row > 1 Then _
    [B][COLOR="Blue"]h.[/COLOR][/B]Range([B][COLOR="Blue"]h.[/COLOR][/B]Cells(2, 1), [B][COLOR="Blue"]h.[/COLOR][/B]Cells(Rows.Count, Columns.Count)).ClearContents
[B][COLOR="red"]k.[/COLOR][/B]Range("A2:B" & Rows.Count).Sort [B][COLOR="red"]k.[/COLOR][/B][A1], 1
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For sat = 2 To [B][COLOR="red"]k.[/COLOR][/B]Cells(Rows.Count, 1).End(3).Row
    sonk = sat - 1 + WorksheetFunction.CountIf([B][COLOR="red"]k.[/COLOR][/B][A:A], [B][COLOR="red"]k.[/COLOR][/B]Cells(sat, 1))
    hsat = [B][COLOR="Blue"]h.[/COLOR][/B]Cells(Rows.Count, 1).End(3).Row + 1
    For satt = sat To sonk
        [B][COLOR="Blue"]h.[/COLOR][/B]Cells(hsat, 1) = [B][COLOR="red"]k.[/COLOR][/B]Cells(satt, 1)
        hsut = [B][COLOR="Blue"]h.[/COLOR][/B]Cells(hsat, Columns.Count).End(xlToLeft).Column + 1
        [B][COLOR="Blue"]h.[/COLOR][/B]Cells(hsat, hsut) = [B][COLOR="red"]k.[/COLOR][/B]Cells(satt, 2)
    Next: sat = sonk
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
[B][COLOR="Blue"]h.[/COLOR][/B]Activate: MsgBox "İşlem tamamlandı..."
[B]End Sub[/B]

 

[siranel]

makro kullanmayı bilmiyorum ama her şeyin bir ilki var deneyimlerimi test eder etmez aktaracağım, çok teşekkürler sayın hocam..

 

[Ömer BARAN]

Aşağıdaki sırayla, belirttiğim işlemleri yapmanız yeterli olur.
-- Alt taraftan kaynak adlı sayfanın adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
-- Karşınıza gelecek makro (VBA) ekranında, sağdaki boş alana verdiğim kod'u yapıştırın ve VBA ekranını kapatın,
-- kaynak isimli sayfaya bir şekil/metin kutusu ekleyin,
-- eklediğiniz şekil/metin kutusuna fareyle sağ tıklayıp MAKRO ATAyı seçin,
-- açılacak küçük ekranda DUZENLE isimli makronun adını seçerek işlemi onaylayın,
-- eklediğiniz şekile/metin kutusuna fareyle tıkladığınızda kod işlemi yapacaktır.
.

 

[siranel]

hocam gerçekten harika işçilik dedikleri bu olsa gerek, elin kolun dert görmesin, derdine koşanın bol olsun, tüm excel.web.tr ailesine teşekkür ederim.

 

[siranel]

Hocam ellerin kolların dert görmesin, her şey için teşekkür ediyorum.

 

[Ömer BARAN]

Verdiğim kod'un sağlıklı çalışması bakımından orijinal sayfadaki verilerin A sütununa göre artan sıralanmış olması gerektiğinden;
önceki kod cevabıma bir satır ekledim, sayfayı yenileyerek önceki cevabımı kontrol edin ve
kod'un yeni halini kullanın.
.

 

[siranel]

Ömer hocam, orjinal, ve yada sayfa adlarını sayfa1 sayfa2 olarak değiştirseniz konudan faydalanacak başka bir arkadaş çelişkiye düşmemiş olur, daha pratik anlar. benim işimi gördü çok teşekkür ederim bu faydalı paylaşımınız için. hele makro kullanmayı anlatışınız bir harika oldu [Makro penceresinde oynat tuşuna bastığımızda da makronun aktif hale geldiğini öğrendim]

ayrıca bence bunu tek bir mesajda düzenlemeniz daha faydalı olacaktır. vaktiniz yoksa yerinize bende yapabilirim.

 

[Ömer BARAN]

Gerekli düzenlemeler yapıldı, eklenen renklendirmeler ile de anlaşılır olması sağlandı.

 

[siranel]

Hocam bildiklerinizi bizimle üşenmeden, bana ne demeden paylaştığınız için tekrar tekrar teşekkür ederim.

 

[Ömer BARAN]

Estağfurullah, ihtiyaç görüldüyse mesele yok.
Kolay gelsin.
.

 

[Korhan Ayhan]

Merhaba,

Sağolsun Ömer bey döngülerle çözüm önermiş.

Bende yüksek satırlı verilerde daha hızlı sonuç veren dizi yöntemiyle çözümü sunmak istedim.

Çok hızlı sonuç verecektir.

Deneyiniz.

Kodu listenizin olduğu sayfa aktif durumdayken çalıştırın.

Yeni liste aynı sayfanın G-H sütunlarında oluşacaktır. Bu durumu isteğinize göre kod içinden revize edebilirsiniz.

Option Explicit

Sub Verileri_Düzenle()
    Dim Son As Long, Liste As Variant, Yeni_Liste As Variant
    Dim X As Long, Y As Long, Say As Long, Zaman As Double
    
    Application.ScreenUpdating = False
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    Range("A2:B" & Son).Sort Range("A2"), xlAscending
    
    Liste = Range("A2:B" & Son).Value
    
    ReDim Yeni_Liste(1 To UBound(Liste) * 2, 1 To 2)
    
    For X = 1 To UBound(Liste)
        If X = UBound(Liste) Then
            Say = Say + 1
            Yeni_Liste(Say, 1) = Liste(X, 1)
            Yeni_Liste(Say, 2) = Liste(X, 2)
        End If
        For Y = X + 1 To UBound(Liste)
            If Liste(X, 1) <> Liste(Y, 1) Then
                Say = Say + 1
                Yeni_Liste(Say, 1) = Liste(X, 1)
                Yeni_Liste(Say, 2) = Liste(X, 2)
                Say = Say + 1
                Yeni_Liste(Say, 1) = ""
                Yeni_Liste(Say, 2) = ""
                GoTo 10
            Else
                Say = Say + 1
                Yeni_Liste(Say, 1) = Liste(X, 1)
                Yeni_Liste(Say, 2) = Liste(X, 2)
                GoTo 10
            End If
        Next
10  Next
    
    Range("G:H").ClearContents
    Range("G1:H1") = Array("product_id", "image")
    Range("G2:H" & UBound(Yeni_Liste)) = Yeni_Liste

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye"
End Sub