• DİKKAT

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

Aynı olanı yan yana yazdırma

ALTINYAYLA

ALTINYAYLA

Altın Üye
Katılım
26 Nisan 2005
Mesajlar
289
Excel Vers. ve Dili
Office 2016 Türkçe
Merhabalar işlem acil oldugundan ve mobil olduğumdan dosya ekleyemedim
A ve b sütununda verilerim var 150 bin satır civarı a sütünunda aynı veriler de olduğundan
B sütünundakileri a sütünunda arayıp c sütünunda yan yana virgülle ayırıp yazdırmak istiyorum. Makro hızlı çalışmalı benim pc çok verimli değil
İlgi ve dönüşleriniz için şimdiden teşekkürler
 
Yardımcı olabilecek varsa sevinirim
 
Hâlâ mı mobilsiniz?

Lütfen örnek dosya paylaşın ve dosyada nasıl bir sonuç istediğinizi gösterin.
 
Yusuf bey merhabalar
Ekte dosyayı ekledim bu sekilde
İstedigim şey ise E sütünuna karşılık gelen C sütunundakileri f1 hücresine yan yana virgülle yazdırmak
www.dosyaupload.com

Hata

Hata
www.dosyaupload.com www.dosyaupload.com
 
E1 e karşılık gelen c sütunundakileri f1 e
E2 ye karşılık gelenleri f2 ye yazdırmam gerekli alt alta tüm e deki isimler için
 
Dosyanızın küçük bir örneğini, ikinci bir sayfada nasıl bir sonuç istediğinizi göstererek paylaşabilir misiniz?
 
Buna benim vereceğim çözüm klasik döngü yöntemi olacaktır ki bu yöntem sizin "hızlı olması" isteğinize uymaz. 150 bin satırlık veride sonuç almak epey uzun sürer.

Tahminim sayın Ziynettin'in dizi yöntemiyle ve diğer tecrübeli arkadaşların daha etkili yöntemleriyle hızlı sonuçlar alınabilir.
 
Altın üyesiniz. Site üzerinden de dosya ekleyebilirsiniz.
 
YUSUF44' Alıntı:
Buna benim vereceğim çözüm klasik döngü yöntemi olacaktır ki bu yöntem sizin "hızlı olması" isteğinize uymaz. 150 bin satırlık veride sonuç almak epey uzun sürer.

Tahminim sayın Ziynettin'in dizi yöntemiyle ve diğer tecrübeli arkadaşların daha etkili yöntemleriyle hızlı sonuçlar alınabilir. @Ziynettin
Genişletmek için tıkla ...
Yusuf bey ilgi ve alakanıza teşekkür ederim normal makro ile dediğiniz gibi 3 gün pc açık bıraktım yine bitmedi ve elektirik gitti yalan oldu kısa sürede bir şekilde çözebilecek arkadaşlar, abiler varsa minnettar kalırım. @Ziynettin
 
Son düzenleme:
Bahsettiğim makro şu şekilde:

PHP: 
Sub birlestir()
son = Cells(Rows.Count, "C").End(3).Row
For i = 1 To son
    If WorksheetFunction.CountIf(Range("E1:E" & i), Cells(i, "E")) = 1 Then
        For j = i To son
            If Cells(i, "E") = Cells(j, "E") Then
                If Cells(i, "F") = "" Then
                    Cells(i, "F") = Cells(j, "C")
                Else
                    Cells(i, "F") = Cells(i, "F") & ", " & Cells(j, "C")
                End If
            End If
        Next
    End If
Next

End Sub
 
YUSUF44' Alıntı:
Bahsettiğim makro şu şekilde:

PHP: 
Sub birlestir()
son = Cells(Rows.Count, "C").End(3).Row
For i = 1 To son
    If WorksheetFunction.CountIf(Range("E1:E" & i), Cells(i, "E")) = 1 Then
        For j = i To son
            If Cells(i, "E") = Cells(j, "E") Then
                If Cells(i, "F") = "" Then
                    Cells(i, "F") = Cells(j, "C")
                Else
                    Cells(i, "F") = Cells(i, "F") & ", " & Cells(j, "C")
                End If
            End If
        Next
    End If
Next

End Sub
Genişletmek için tıkla ...
Bu şekilde baya uzun sürüyor ve işlem tamamlanmıyor yusuf hocam
 
Aşağıdaki şekilde biraz daha hızlanır ama sonuçlanır mı bilmiyorum, ben denemedim:

PHP: 
Sub birlestir()
son = Cells(Rows.Count, "C").End(3).Row
Application.ScreenUpdating = False
For i = 1 To son
    If WorksheetFunction.CountIf(Range("E1:E" & i), Cells(i, "E")) = 1 Then
        For j = i To son
            If Cells(i, "E") = Cells(j, "E") Then
                If Cells(i, "F") = "" Then
                    Cells(i, "F") = Cells(j, "C")
                Else
                    Cells(i, "F") = Cells(i, "F") & ", " & Cells(j, "C")
                End If
            End If
        Next
    End If
Next
Application.ScreenUpdating = True
End Sub

İşi hızlandırmak için şöyle yapılabilir. Dosyanız E sütununa göre sıralanır. Daha sonra döngüde E sütunu değiştiğinde sonlandırma yapılır:

PHP: 
Sub birlestir()
son = Cells(Rows.Count, "C").End(3).Row
Application.ScreenUpdating = False
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add Key:=Range( _
        "E1:E" & son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add Key:=Range( _
        "C1:C" & son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sayfa1").Sort
        .SetRange Range("A1:Q" & son)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

For i = 1 To son
    If WorksheetFunction.CountIf(Range("E1:E" & i), Cells(i, "E")) = 1 Then
        For j = i To son
            If Cells(i, "E") = Cells(j, "E") Then
                If Cells(i, "F") = "" Then
                    Cells(i, "F") = Cells(j, "C")
                Else
                    Cells(i, "F") = Cells(i, "F") & ", " & Cells(j, "C")
                End If
            Else
                i = j - 1
                j = son
            End If
        Next
    End If
Next
Application.ScreenUpdating = True
End Sub
 
YUSUF44' Alıntı:
Aşağıdaki şekilde biraz daha hızlanır ama sonuçlanır mı bilmiyorum, ben denemedim:

PHP: 
Sub birlestir()
son = Cells(Rows.Count, "C").End(3).Row
Application.ScreenUpdating = False
For i = 1 To son
    If WorksheetFunction.CountIf(Range("E1:E" & i), Cells(i, "E")) = 1 Then
        For j = i To son
            If Cells(i, "E") = Cells(j, "E") Then
                If Cells(i, "F") = "" Then
                    Cells(i, "F") = Cells(j, "C")
                Else
                    Cells(i, "F") = Cells(i, "F") & ", " & Cells(j, "C")
                End If
            End If
        Next
    End If
Next
Application.ScreenUpdating = True
End Sub

İşi hızlandırmak için şöyle yapılabilir. Dosyanız E sütununa göre sıralanır. Daha sonra döngüde E sütunu değiştiğinde sonlandırma yapılır:

PHP: 
Sub birlestir()
son = Cells(Rows.Count, "C").End(3).Row
Application.ScreenUpdating = False
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add Key:=Range( _
        "E1:E" & son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Sayfa1").Sort.SortFields.Add Key:=Range( _
        "C1:C" & son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sayfa1").Sort
        .SetRange Range("A1:Q" & son)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

For i = 1 To son
    If WorksheetFunction.CountIf(Range("E1:E" & i), Cells(i, "E")) = 1 Then
        For j = i To son
            If Cells(i, "E") = Cells(j, "E") Then
                If Cells(i, "F") = "" Then
                    Cells(i, "F") = Cells(j, "C")
                Else
                    Cells(i, "F") = Cells(i, "F") & ", " & Cells(j, "C")
                End If
            Else
                i = j - 1
                j = son
            End If
        Next
    End If
Next
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Deneyim sonucu sizinle paylaşacağım yusuf bey
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst