A Sütunundaki ürün kodunun B Sütunundaki çoklu karşılığını alt alta değil yan yana yazma

Katılım
9 Ağustos 2022
Mesajlar
10
Excel Vers. ve Dili
2013 - Türkçe
Hocalarım merhaba,
Elimde ürün listesinin olduğu bir excel var ve listede A sütununda ürün kodları yazıyor B sütununda da bu kodların resim yolları var ama alt alta sıralanmış ben bunları yan yana sıralamak istiyorum. Örnek olarak;

Ürün resmi jpg olarak değil metin olarak düşünebiliriz.

A------------------------------B
Ürün Kodu 1----------------Ürün resmi 1
Ürün Kodu 1----------------Ürün resmi 2
Ürün Kodu 1----------------Ürün resmi 3
Ürün Kodu 1----------------Ürün resmi 4
Ürün Kodu 1----------------Ürün resmi 5

Şu şekilde olması tüm işimi çözecek

A --------------------------B--------------------------C--------------------------D--------------------------E--------------------------F
Ürün Kodu 1--------------Ürün resmi 1--------------Ürün resmi 2--------------Ürün resmi 3--------------Ürün resmi 4------------ Ürün resmi 5


Elle 50-60 tane yaptım ama işin içinden çıkılacak gibi değil 23,000 civarı ürün var. arama yaptığımda forumda benzer bir konu bulamadım. Yardımcı olursanız sevinirim. Dosyayı ekliyorum

 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
5,802
Excel Vers. ve Dili
2019 Türkçe
Merhaba.

Aşağıdaki kodu bir module kopyalayıp çalıştırın.

Kod:
Sub Test()
    Dim Bak As Long
    Dim Say As Integer
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Do
            Say = 1 + Say
            If Cells(Bak, "A") = Cells(Bak + Say, "A") Then
                Cells(Bak, Say + 2) = Cells(Bak + Say, "B")
                Cells(Bak + Say, "B") = ""
            Else
                Bak = Say + Bak - 1
                Say = 0
                Exit Do
            End If
        Loop
    Next
    MsgBox "Tamamlandı."
End Sub
İşlem biraz uzun sürebilir bitmesini bekleyin.
 
Son düzenleme:

İdris SERDAR

Moderatör
Yönetici
Katılım
21 Ekim 2005
Mesajlar
17,104
Excel Vers. ve Dili
Excel, 365 - İngilizce
.

23.609 ürün var.
2 sütun olacağını varsayarsak; 47.218 sütun yapar.

Oysa, Excel sayfasındaki sütun sayısı: 16.384 sütun.

Her iki durumda da nasıl sığacak? Merak ediyorum.

.
 
Son düzenleme:

AdemCan

Altın Üye
Destek Ekibi
Katılım
1 Eylül 2008
Mesajlar
1,346
Excel Vers. ve Dili
2019 TR
Alternatif bir örnek, yaklaşık 2 dk sürdü bitmesi.

Ürünlerin olduğu sayfa ismini Ürün olarak değiştirdim ve yeni bir sayfa açıp ismine Rapor yazdım.
Kod içinde sayfa isimlerini değiştirebilirsiniz.
238221

Bu kodu çalıştırdığınız zaman Rapor sayfasına ürünleri ve resim adreslerini sıralayacak.
Kod:
Sub test()
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet
Dim son1 As Long, son2 As Long
Set s1 = Sheets("Ürün"): Set s2 = Sheets("Rapor")
son1 = s1.Cells(Rows.Count, 1).End(3).Row
s2.Cells.Clear

With CreateObject("Scripting.Dictionary")
    For i = 2 To son1
        a = s1.Cells(i, 1).Value
            If Not .exists(a) Then
            .Add a, s1.Cells(i, 1).Value
            End If
    Next i
    
s2.Range("A1") = "Ürün Kodu"
dizi = .Keys
s2.Range("A2").Resize(UBound(dizi) + 1, 1) = Application.Transpose(dizi)
End With

son2 = s2.Cells(Rows.Count, 1).End(3).Row

r = 2
For s2a = 2 To son2
k = WorksheetFunction.CountIf(s1.Range("A2:A" & son1), s2.Cells(s2a, 1))
    s = 2
    For s1a = r To son1
        If s1.Cells(s1a, 1) = s2.Cells(s2a, 1) Then
            s2.Cells(s2a, s) = s1.Cells(s1a, 2)
            s = s + 1
            If s > k + 1 Then
                r = s1a + 1
                GoTo gec
            End If
        End If
    Next s1a
gec:
Next s2a
Application.ScreenUpdating = True
End Sub
 
Katılım
9 Ağustos 2022
Mesajlar
10
Excel Vers. ve Dili
2013 - Türkçe
Merhaba.

Aşağıdaki kodu bir module kopyalayıp çalıştırın.

Kod:
Sub Test()
    Dim Bak As Long
    Dim Say As Integer
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Do
            Say = 1 + Say
            If Cells(Bak, "A") = Cells(Bak + Say, "A") Then
                Cells(Bak, Say + 2) = Cells(Bak + Say, "B")
                Cells(Bak + Say, "B") = ""
            Else
                Bak = Say + Bak - 1
                Say = 0
                Exit Do
            End If
        Loop
    Next
    MsgBox "Tamamlandı."
End Sub
İşlem biraz uzun sürebilir bitmesini bekleyin.
Hocam Allah sizden razı olsun. Beni 5-6 saatlik işkenceden kurtardınız. Allah kat kat ömrünüze eklesin sağolun varolun
 
Katılım
9 Ağustos 2022
Mesajlar
10
Excel Vers. ve Dili
2013 - Türkçe
Alternatif bir örnek, yaklaşık 2 dk sürdü bitmesi.

Ürünlerin olduğu sayfa ismini Ürün olarak değiştirdim ve yeni bir sayfa açıp ismine Rapor yazdım.
Kod içinde sayfa isimlerini değiştirebilirsiniz.
Ekli dosyayı görüntüle 238221

Bu kodu çalıştırdığınız zaman Rapor sayfasına ürünleri ve resim adreslerini sıralayacak.
Kod:
Sub test()
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet
Dim son1 As Long, son2 As Long
Set s1 = Sheets("Ürün"): Set s2 = Sheets("Rapor")
son1 = s1.Cells(Rows.Count, 1).End(3).Row
s2.Cells.Clear

With CreateObject("Scripting.Dictionary")
    For i = 2 To son1
        a = s1.Cells(i, 1).Value
            If Not .exists(a) Then
            .Add a, s1.Cells(i, 1).Value
            End If
    Next i
   
s2.Range("A1") = "Ürün Kodu"
dizi = .Keys
s2.Range("A2").Resize(UBound(dizi) + 1, 1) = Application.Transpose(dizi)
End With

son2 = s2.Cells(Rows.Count, 1).End(3).Row

r = 2
For s2a = 2 To son2
k = WorksheetFunction.CountIf(s1.Range("A2:A" & son1), s2.Cells(s2a, 1))
    s = 2
    For s1a = r To son1
        If s1.Cells(s1a, 1) = s2.Cells(s2a, 1) Then
            s2.Cells(s2a, s) = s1.Cells(s1a, 2)
            s = s + 1
            If s > k + 1 Then
                r = s1a + 1
                GoTo gec
            End If
        End If
    Next s1a
gec:
Next s2a
Application.ScreenUpdating = True
End Sub
Adem Hocam elinize emeğinize sağlık, yüklediğiniz dosyayı indiremiyorum fakat Muzaffer hocamızın yazdığı kod işimi fazlasıyla gördü. Değerli vaktinizi ayırdığınız için çok teşekkürler Saygılar
 
Katılım
9 Ağustos 2022
Mesajlar
10
Excel Vers. ve Dili
2013 - Türkçe
.

23.609 ürün var.
2 sütun olacağını varsayarsak; 47.218 sütun yapar.

Oysa, Excel sayfasındaki sütun sayısı: 16.384 sütun.

Her iki durumda da nasıl sığacak? Merak ediyorum.

.
İdris Hocam, sanırım konuyu yanlış anladınız doğru anlamış olsaydınız çözüm üreteceğinizden hiç şüphem yoktur vaktinize ilginize teşekkür ederim Saygılarımla
 

AdemCan

Altın Üye
Destek Ekibi
Katılım
1 Eylül 2008
Mesajlar
1,346
Excel Vers. ve Dili
2019 TR
Rica ederim. İndirilecek bir dosya yok mesajda. Sayfa isimleri için resim eklemiştim. :) Sorunun çözülmesi güzel. (y)
 
Katılım
31 Ekim 2020
Mesajlar
3
Excel Vers. ve Dili
2017 türkçe
Tekrardan Selamın Aleykum,
Hocalarım ben şimdi bu aylar önce istediğim işlemi yan yana değil alt alta yazmak istiyorum
Örneğin;
--------A---------------------B----------------------C------------------------D----------------------E-----------
--ÜRÜN KODU-----------RESİM1.jpg----------RESİM2.jpg--------------RESİM3.jpg----------RESİM4.jpg------
--ÜRÜN KODU-----------RESİM1.jpg----------RESİM2.jpg--------------RESİM3.jpg------
--ÜRÜN KODU-----------RESİM1.jpg----------RESİM2.jpg-------
--ÜRÜN KODU-----------RESİM1.jpg----------RESİM2.jpg--------------RESİM3.jpg----------RESİM4.jpg------

Bu Şekildeki 12,300 adet veriyi aşağıdaki şekle sokmak istiyorum ama resim sayısı belli değil kiminde resim1.jpg var kiminde 5 e kadar var kimisinde 10 a kadar var 10dan daha fazla yok.

--------A---------------------B----------------------C------------------------D----------------------E-----------
--ÜRÜN KODU-----------RESİM1.jpg
--ÜRÜN KODU-----------RESİM2.jpg
--ÜRÜN KODU-----------RESİM3.jpg
--ÜRÜN KODU-----------RESİM4.jpg

--ÜRÜN KODU-----------RESİM1.jpg
--ÜRÜN KODU-----------RESİM2.jpg
--ÜRÜN KODU-----------RESİM3.jpg

--ÜRÜN KODU-----------RESİM1.jpg
--ÜRÜN KODU-----------RESİM2.jpg

--ÜRÜN KODU-----------RESİM1.jpg
--ÜRÜN KODU-----------RESİM2.jpg
--ÜRÜN KODU-----------RESİM3.jpg
--ÜRÜN KODU-----------RESİM4.jpg

Yardımcı olabilirseniz eğer beni 1 günlük yoğun bir işten kurtaracaksınız. Şimdiden teşekkür ederim
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Kod:
Sub test()
    Dim veri, liste, say&, i&, ii As Byte
    veri = Sheets("Sheet1").Range("A1").CurrentRegion.Value
    ReDim liste(1 To UBound(veri) * UBound(veri, 2) - 1, 1 To 2)
    For i = 1 To UBound(veri)
        For ii = 2 To UBound(veri, 2)
            If veri(i, ii) <> "" Then
                say = say + 1
                liste(say, 1) = veri(i, 1)
                liste(say, 2) = veri(i, ii)
            End If
        Next ii
    Next i
    Sheets("Sheet2").Range("A2").Resize(say, 2).Value = liste
End Sub
 
Katılım
31 Ekim 2020
Mesajlar
3
Excel Vers. ve Dili
2017 türkçe
Kod:
Sub test()
    Dim veri, liste, say&, i&, ii As Byte
    veri = Sheets("Sheet1").Range("A1").CurrentRegion.Value
    ReDim liste(1 To UBound(veri) * UBound(veri, 2) - 1, 1 To 2)
    For i = 1 To UBound(veri)
        For ii = 2 To UBound(veri, 2)
            If veri(i, ii) <> "" Then
                say = say + 1
                liste(say, 1) = veri(i, 1)
                liste(say, 2) = veri(i, ii)
            End If
        Next ii
    Next i
    Sheets("Sheet2").Range("A2").Resize(say, 2).Value = liste
End Sub

Veysel Hocam değerli vaktiniz için teşekkürler ama beceremedim dediğinizi yaptığımda hiç bir işlem yapmadı. Örnek dosyayı eklemeyi unutmuşum
Buradan ulaşabilirsiniz.

https://we.tl/t-65aFrs5VZM

Tekrar teşekkürler
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Dosyanıza sonuc isimli bir sayfa ekleyin.
Alt + F11 le açtığınız vba editörüne insert menüsünden bir modül ekleyip, eklenen modüle aşağıdaki kodları ekleyip çalıştırın.
Kod:
Sub test()
    Dim veri, liste, say&, i&, ii As Byte
    veri = Sheets("KOD DENEME").Range("A1").CurrentRegion.Value
    ReDim liste(1 To UBound(veri) * UBound(veri, 2) - 1, 1 To 3)
    For i = 2 To UBound(veri)
        For ii = 3 To UBound(veri, 2)
            If veri(i, ii) <> "" Then
                say = say + 1
                liste(say, 1) = veri(i, 1)
                liste(say, 2) = veri(i, 2)
                liste(say, 3) = veri(i, ii)
            End If
        Next ii
    Next i
    With Sheets("sonuc")
        .Cells.Clear
        .Range("A2").Resize(say, 3).Value = liste
    End With
End Sub
 
Katılım
31 Ekim 2020
Mesajlar
3
Excel Vers. ve Dili
2017 türkçe
Dosyanıza sonuc isimli bir sayfa ekleyin.
Alt + F11 le açtığınız vba editörüne insert menüsünden bir modül ekleyip, eklenen modüle aşağıdaki kodları ekleyip çalıştırın.
Kod:
Sub test()
    Dim veri, liste, say&, i&, ii As Byte
    veri = Sheets("KOD DENEME").Range("A1").CurrentRegion.Value
    ReDim liste(1 To UBound(veri) * UBound(veri, 2) - 1, 1 To 3)
    For i = 2 To UBound(veri)
        For ii = 3 To UBound(veri, 2)
            If veri(i, ii) <> "" Then
                say = say + 1
                liste(say, 1) = veri(i, 1)
                liste(say, 2) = veri(i, 2)
                liste(say, 3) = veri(i, ii)
            End If
        Next ii
    Next i
    With Sheets("sonuc")
        .Cells.Clear
        .Range("A2").Resize(say, 3).Value = liste
    End With
End Sub
Hocam elleriniz dert görmesin siz ne mübarek insansınız sağolun varolun :)
 
Üst