Soru Satırı Belirli Bir Karaktere Göre Kopyalamak

tefon · 15 Mayıs 2022

Arkadaşlar herkese merhaba,

Elimde EXCEL bir dosya mevcut. Yaklaşık 5000 kadar ürün yüklü. Ürünlerin özellikleri vb. bilgiler yer almakta.
Bazı hücrelerde ikili veriler mevcut. Örnek (Kırmızı/Beyaz) gibi. Bu satırları alt satıra ayırarak kopyalamak istiyorum.

Örnek olarak;

İsim	Stok	Renk	Kargo	E Sutunu	F Sutunu	G Sutunu
ABCD1	10	Kırmızı/Mavi	Yurtiçi	Başlık	Açıklama	URL
ABCD2	10	Yeşil/Beyaz	Yurtiçi	Başlık	Açıklama	URL
ABCD3	10	Beyaz	Yurtiçi	Başlık	Açıklama	URL
ABCD4	10	Kırmızı	Yurtiçi	Başlık	Açıklama	URL
ABCD5	10	Siyah	Yurtiçi	Başlık	Açıklama	URL
ABCD6	10	Mavi/Yeşil	Yurtiçi	Başlık	Açıklama	URL

Olmasını istediğim;

İsim	Stok	Renk	Kargo	E Sutunu	F Sutunu	G Sutunu
ABCD1	10	Kırmızı	Yurtiçi	Başlık	Açıklama	URL
ABCD1	10	Mavi	Yurtiçi	Başlık	Açıklama	URL
ABCD2	10	Yeşil	Yurtiçi	Başlık	Açıklama	URL
ABCD2	10	Beyaz	Yurtiçi	Başlık	Açıklama	URL
ABCD3	10	Beyaz	Yurtiçi	Başlık	Açıklama	URL
ABCD4	10	Kırmızı	Yurtiçi	Başlık	Açıklama	URL
ABCD5	10	Siyah	Yurtiçi	Başlık	Açıklama	URL
ABCD6	10	Mavi	Yurtiçi	Başlık	Açıklama	URL
ABCD6	10	Yeşil	Yurtiçi	Başlık	Açıklama	URL

Yardımlar için şimdiden teşekkür ederim.

mesuttasar · 15 Mayıs 2022

Merhaba,
Öncelikle çalışma sayfanızda I,2 J2 ve K2 hücrelerine ekteki dosyada belirttiğim formülleri yazıp son dolu hücreye kadar bu formülleri kopyalayın.
İkinci olarakta butona atamış olduğum makro yardımıyla istediğiniz şekilde ikinci sayfaya kopyalama işlemini yapabilirsiniz.
Muhtemelen üstatlar daha kısa ve komplike makro yazabilirler ama benim üretibildiğim çözüm budur.
Kolay gelsin.
https://s7.dosya.tc/server21/pb1hsi/Ayir_Ornek.xlsm.html

Kod:

Sub ayir()
Sheet1.Select
endo = Sheet1.Cells(Rows.Count, "A").End(3).Row
For i = 2 To endo
If Cells(i, 9) > 0 Then
end1 = Sheet2.Cells(Rows.Count, "A").End(3).Row + 1
Sheet2.Cells(end1, 1) = Sheet1.Cells(i, 1)
Sheet2.Cells(end1, 2) = Sheet1.Cells(i, 2)
Sheet2.Cells(end1, 3) = Sheet1.Cells(i, 10)
Sheet2.Cells(end1, 4) = Sheet1.Cells(i, 4)
Sheet2.Cells(end1, 5) = Sheet1.Cells(i, 5)
Sheet2.Cells(end1, 6) = Sheet1.Cells(i, 6)
Sheet2.Cells(end1, 7) = Sheet1.Cells(i, 7)
Sheet2.Cells(end1 + 1, 1) = Sheet1.Cells(i, 1)
Sheet2.Cells(end1 + 1, 2) = Sheet1.Cells(i, 2)
Sheet2.Cells(end1 + 1, 3) = Sheet1.Cells(i, 11)
Sheet2.Cells(end1 + 1, 4) = Sheet1.Cells(i, 4)
Sheet2.Cells(end1 + 1, 5) = Sheet1.Cells(i, 5)
Sheet2.Cells(end1 + 1, 6) = Sheet1.Cells(i, 6)
Sheet2.Cells(end1 + 1, 7) = Sheet1.Cells(i, 7)
Else
end1 = Sheet2.Cells(Rows.Count, "A").End(3).Row + 1
Sheet2.Cells(end1, 1) = Sheet1.Cells(i, 1)
Sheet2.Cells(end1, 2) = Sheet1.Cells(i, 2)
Sheet2.Cells(end1, 3) = Sheet1.Cells(i, 3)
Sheet2.Cells(end1, 4) = Sheet1.Cells(i, 4)
Sheet2.Cells(end1, 5) = Sheet1.Cells(i, 5)
Sheet2.Cells(end1, 6) = Sheet1.Cells(i, 6)
Sheet2.Cells(end1, 7) = Sheet1.Cells(i, 7)
End If
Next i
End Sub

tefon · 15 Mayıs 2022

mesuttasar' Alıntı:
Merhaba,
Öncelikle çalışma sayfanızda I,2 J2 ve K2 hücrelerine ekteki dosyada belirttiğim formülleri yazıp son dolu hücreye kadar bu formülleri kopyalayın.
İkinci olarakta butona atamış olduğum makro yardımıyla istediğiniz şekilde ikinci sayfaya kopyalama işlemini yapabilirsiniz.
Muhtemelen üstatlar daha kısa ve komplike makro yazabilirler ama benim üretibildiğim çözüm budur.
Kolay gelsin.
https://s7.dosya.tc/server21/pb1hsi/Ayir_Ornek.xlsm.html

Kod:

Sub ayir() Sheet1.Select endo = Sheet1.Cells(Rows.Count, "A").End(3).Row For i = 2 To endo If Cells(i, 9) > 0 Then end1 = Sheet2.Cells(Rows.Count, "A").End(3).Row + 1 Sheet2.Cells(end1, 1) = Sheet1.Cells(i, 1) Sheet2.Cells(end1, 2) = Sheet1.Cells(i, 2) Sheet2.Cells(end1, 3) = Sheet1.Cells(i, 10) Sheet2.Cells(end1, 4) = Sheet1.Cells(i, 4) Sheet2.Cells(end1, 5) = Sheet1.Cells(i, 5) Sheet2.Cells(end1, 6) = Sheet1.Cells(i, 6) Sheet2.Cells(end1, 7) = Sheet1.Cells(i, 7) Sheet2.Cells(end1 + 1, 1) = Sheet1.Cells(i, 1) Sheet2.Cells(end1 + 1, 2) = Sheet1.Cells(i, 2) Sheet2.Cells(end1 + 1, 3) = Sheet1.Cells(i, 11) Sheet2.Cells(end1 + 1, 4) = Sheet1.Cells(i, 4) Sheet2.Cells(end1 + 1, 5) = Sheet1.Cells(i, 5) Sheet2.Cells(end1 + 1, 6) = Sheet1.Cells(i, 6) Sheet2.Cells(end1 + 1, 7) = Sheet1.Cells(i, 7) Else end1 = Sheet2.Cells(Rows.Count, "A").End(3).Row + 1 Sheet2.Cells(end1, 1) = Sheet1.Cells(i, 1) Sheet2.Cells(end1, 2) = Sheet1.Cells(i, 2) Sheet2.Cells(end1, 3) = Sheet1.Cells(i, 3) Sheet2.Cells(end1, 4) = Sheet1.Cells(i, 4) Sheet2.Cells(end1, 5) = Sheet1.Cells(i, 5) Sheet2.Cells(end1, 6) = Sheet1.Cells(i, 6) Sheet2.Cells(end1, 7) = Sheet1.Cells(i, 7) End If Next i End Sub

Yardımınız için çok teşekkür ediyorum. Bunu formülsüz sadece makro ile yapabilir miyim? Bir de ikinci sayfa değil de aynı sayfada işlem tamamlanabilir mi?

tefon · 16 Mayıs 2022

Farklı bir çözüm önerisi var mıdır? Teşekkürler.

necati · 16 Mayıs 2022

Merhaba,

Kod:

Sub EkleDoldur()
'Satır Hücre ekle ve doldur

say = Range("c2:c" & Range("c65536").End(xlUp).Row).Count
Set aralik = Range("c2:c" & Range("c65536").End(xlUp).Row)
For Each hcr In aralik
    If InStr(hcr, "/") Then
        ayir = Split(hcr, "/")
        deg = UBound(ayir)
        Range("A" & hcr.Row + 1 & ":g" & hcr.Row + deg).Select
        Selection.Insert
        Range("A" & hcr.Row & ":g" & hcr.Row).Copy Selection
        hcr.Select
        Selection.Value = ayir(0)
    For i = 1 To deg
        ActiveCell.Offset(i, 0).Value = ayir(i)
    Next
    End If
Next
End Sub

tefon · 16 Mayıs 2022

necati' Alıntı:

Merhaba,

Kod:

Sub EkleDoldur()
'Satır Hücre ekle ve doldur

say = Range("c2:c" & Range("c65536").End(xlUp).Row).Count
Set aralik = Range("c2:c" & Range("c65536").End(xlUp).Row)
For Each hcr In aralik
    If InStr(hcr, "/") Then
        ayir = Split(hcr, "/")
        deg = UBound(ayir)
        Range("A" & hcr.Row + 1 & ":g" & hcr.Row + deg).Select
        Selection.Insert
        Range("A" & hcr.Row & ":g" & hcr.Row).Copy Selection
        hcr.Select
        Selection.Value = ayir(0)
    For i = 1 To deg
        ActiveCell.Offset(i, 0).Value = ayir(i)
    Next
    End If
Next
End Sub

Emeğinize sağlık. Çok teşekkür ediyorum.
İşlem yaklaşık 1 saattir sürmekte. Sanırım satır sayısı 3000 üzerinde olduğu için. İlerleyişi görmemin bir yolu var mıdır?

ÖmerFaruk · 16 Mayıs 2022

Merhaba,
5100 satırda denedim. Sonuç oldukça hızlı.

Dosyanıza Sayfa4 isimli bir sayfa ekleyip bu kodları verinizin olduğu sayfada çalıştırın.
HEr şey normalse son satırdaki Worksheets("Sayfa4"). kısımını silin ( nokta dahil)

C++:

Sub EkleDoldur()
'Satır Hücre ekle ve doldur
Dim Renkler, xArr As Variant, Liste()
LastRow = Range("A" & Rows.Count).End(3).Row
xArr = Range("A2").Resize(LastRow - 1, 7).Value

For i = LBound(xArr) To UBound(xArr)
   Say = Say + 1
   ReDim Preserve Liste(1 To 7, 1 To Say)
   For k = 1 To 7
      Liste(k, Say) = xArr(i, k)
   Next k
   Kontrol = InStr(1, xArr(i, 3), "/")
   If Kontrol Then
      Renkler = Split(xArr(i, 3), "/")
      Liste(3, Say) = Renkler(0)
      For k = 1 To UBound(Renkler)
         Say = Say + 1
         ReDim Preserve Liste(1 To 7, 1 To Say)
         For x = 1 To 7
            Liste(x, Say) = xArr(i, x)
         Next x
         Liste(3, Say) = Renkler(k)
      Next k
   End If
Next i
Worksheets("Sayfa4").Range("A2").Resize(Say, 7) = Application.Transpose(Liste)
End Sub

tefon · 16 Mayıs 2022

ÖmerFaruk' Alıntı:

Merhaba,
5100 satırda denedim. Sonuç oldukça hızlı.

Dosyanıza Sayfa4 isimli bir sayfa ekleyip bu kodları verinizin olduğu sayfada çalıştırın.
HEr şey normalse son satırdaki Worksheets("Sayfa4"). kısımını silin ( nokta dahil)

C++:

Sub EkleDoldur()
'Satır Hücre ekle ve doldur
Dim Renkler, xArr As Variant, Liste()
LastRow = Range("A" & Rows.Count).End(3).Row
xArr = Range("A2").Resize(LastRow - 1, 7).Value

For i = LBound(xArr) To UBound(xArr)
   Say = Say + 1
   ReDim Preserve Liste(1 To 7, 1 To Say)
   For k = 1 To 7
      Liste(k, Say) = xArr(i, k)
   Next k
   Kontrol = InStr(1, xArr(i, 3), "/")
   If Kontrol Then
      Renkler = Split(xArr(i, 3), "/")
      Liste(3, Say) = Renkler(0)
      For k = 1 To UBound(Renkler)
         Say = Say + 1
         ReDim Preserve Liste(1 To 7, 1 To Say)
         For x = 1 To 7
            Liste(x, Say) = xArr(i, x)
         Next x
         Liste(3, Say) = Renkler(k)
      Next k
   End If
Next i
Worksheets("Sayfa4").Range("A2").Resize(Say, 7) = Application.Transpose(Liste)
End Sub

Emeğiniz ve paylaşımınız için çok teşekkür ediyorum. Sanırım örnek olarak eklediğim EXCEL sutunlarından kaynaklı bir hata mevcut. Orjinal EXCEL Dosyam şu şekilde;

*Ürün SPU kodu

*SKU kodu

*Ürün adı

*Fiyat(USD)

İndirim fiyatını görüntüle(USD)

*Stok

köken

*Marka adı

Malzeme

Malzeme 2

Malzeme3

*Birim çeşidi

Renk

Boyut

Rengi İçe Aktar

*Kargo şablonu

*Hizmet şablonu

*Kargo hazırlık süresi (gün)

*Ambalaj Ağırlığı (kg/adet)

*Paketleme Boyutu (Uzunluk*Genişlik*Yükseklik) Birim:cm

SKU görsel

*Ana görsel 1

Ana görsel 2

Ana görsel 3

Ana görsel 4

Ana görsel 5

Ana görsel 6

*Ürün Açıklaması

Rusya Federasyonu(USD)

Amerika Birleşik Devletleri(USD)

Kanada(USD)

İspanya(USD)

Fransa(USD)

Birleşik Krallık(USD)

Hollanda(USD)

İsrail(USD)

Brezilya(USD)

Şili(USD)

Avustralya(USD)

Ukrayna(USD)

Belarus(USD)

Japonya(USD)

Tayland(USD)

Singapur(USD)

Güney Kore(USD)

Endonezya(USD)

Malezya(USD)

Filipinler(USD)

Vietnam(USD)

İtalya(USD)

Almanya(USD)

Suudi Arabistan(USD)

Birleşik Arap Emirlikleri(USD)

Polonya(USD)

Türkiye(USD)

T37

76217

Deneme 1

23,25

94

TR (kökeni)

other

adet

Kırmızı

One Size

Yurtiçi

Service Template for New Sellers

3

0,75

5*10*8

1.jpg

açıklama

0

T131

76220

Deneme 2

41,04

116

TR (kökeni)

other

adet

Black

S/M

Yurtiçi

Service Template for New Sellers

3

0,75

5*10*8

1.jpg

açıklama

0

Ben bunu BOYUT yazan tabloya göre şu şekilde düzenlemek istiyorum.

*Ürün SPU kodu	*SKU kodu	*Ürün adı	*Fiyat(USD)	İndirim fiyatını görüntüle(USD)	*Stok	köken	*Marka adı	Malzeme	Malzeme 2	Malzeme3	*Birim çeşidi	Renk	Boyut	Rengi İçe Aktar	*Kargo şablonu	*Hizmet şablonu	*Kargo hazırlık süresi (gün)	*Ambalaj Ağırlığı (kg/adet)	Paketleme Boyutu (UzunlukGenişlik*Yükseklik) Birim:cm	SKU görsel	*Ana görsel 1	Ana görsel 2	Ana görsel 3	Ana görsel 4	Ana görsel 5	Ana görsel 6	*Ürün Açıklaması	Rusya Federasyonu(USD)	Amerika Birleşik Devletleri(USD)	Kanada(USD)	İspanya(USD)	Fransa(USD)	Birleşik Krallık(USD)	Hollanda(USD)	İsrail(USD)	Brezilya(USD)	Şili(USD)	Avustralya(USD)	Ukrayna(USD)	Belarus(USD)	Japonya(USD)	Tayland(USD)	Singapur(USD)	Güney Kore(USD)	Endonezya(USD)	Malezya(USD)	Filipinler(USD)	Vietnam(USD)	İtalya(USD)	Almanya(USD)	Suudi Arabistan(USD)	Birleşik Arap Emirlikleri(USD)	Polonya(USD)	Türkiye(USD)
T37	76217	Deneme 1	23,25		94	TR (kökeni)	other				adet	Kırmızı	One Size		Yurtiçi	Service Template for New Sellers	3	0,75	5108	1.jpg	1.jpg	1.jpg	1.jpg	1.jpg	1.jpg	1.jpg	açıklama	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0
T131	76220	Deneme 2	41,04		116	TR (kökeni)	other				adet	Black	S		Yurtiçi	Service Template for New Sellers	3	0,75	5108	1.jpg	1.jpg	1.jpg	1.jpg	1.jpg	1.jpg	1.jpg	açıklama	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0
T131	762201	Deneme 2	41,04		116	TR (kökeni)	other				adet	Black	M		Yurtiçi	Service Template for New Sellers	3	0,75	5108	1.jpg	1.jpg	1.jpg	1.jpg	1.jpg	1.jpg	1.jpg	açıklama	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0	0

Ve mümkünse bunu yaparken de ALT satıra geçen değerin SKU KODUNun sonuna 1 yazdırmam gerekiyor.

Teşekkür ederim.

tefon · 17 Mayıs 2022

Verdiğiniz kod üzerinde biraz çalışma yaparak aşağıdaki kodu oluşturdum. Kod başarılı çalışıyor. Ancak AB sütununda yer alan Ürün Açıklaması bölümü 350 karakteri geçtiğinde makro "type mismatch 13 runtime error" hatası veriyor.

AB Sütunu

*Ürün Açıklaması

Söz konusu ürünler ilgili açıklamalar yer alıyor. Zaman zaman HTML kodları da bulunabiliyor. <span>Kırmızı Renk</span> gibi.

Kullandığım kod.

Kod:

Sub EkleDoldur()
'Satır Hücre ekle ve doldur
Dim Renkler, xArr As Variant, Liste()
LastRow = Range("A" & Rows.Count).End(3).Row
xArr = Range("A2").Resize(LastRow - 1, 55).Value

For i = LBound(xArr) To UBound(xArr)
   Say = Say + 1
   ReDim Preserve Liste(1 To 55, 1 To Say)
   For k = 1 To 55
      Liste(k, Say) = xArr(i, k)
   Next k
   Kontrol = InStr(1, xArr(i, 14), "/")
   If Kontrol Then
      Renkler = Split(xArr(i, 14), "/")
      Liste(14, Say) = Renkler(0)
      For k = 1 To UBound(Renkler)
         Say = Say + 1
         ReDim Preserve Liste(1 To 55, 1 To Say)
         For x = 1 To 55
            Liste(x, Say) = xArr(i, x)
         Next x
         Liste(14, Say) = Renkler(k)
      Next k
   End If
Next i
Worksheets("Sayfa4").Range("A2").Resize(Say, 55) = Application.Transpose(Liste)
End Sub

ÖmerFaruk · 17 Mayıs 2022

Bildiğim kadarıyla hücrede toplam karakter sayısı sınırı 32.767 dir.
Bundan yola çıkarak sizin 350 olunca hata veriyor dediğiniz için 400 karaktere sahip hücrede denedim. Kodlar çalıştı.

Sorunun kaynağı başka bir konudur.

Edit:
Yeni farkettiim. Exceliniz 2003 sanırım.
2003 de bu limit 255 karakterdir diye biliyorum.

tefon · 17 Mayıs 2022

ÖmerFaruk' Alıntı:
Bildiğim kadarıyla hücrede toplam karakter sayısı sınırı 32.767 dir.
Bundan yola çıkarak sizin 350 olunca hata veriyor dediğiniz için 400 karaktere sahip hücrede denedim. Kodlar çalıştı.

Sorunun kaynağı başka bir konudur.

Edit:
Yeni farkettiim. Exceliniz 2003 sanırım.
2003 de bu limit 255 karakterdir diye biliyorum.

ÖmerFaruk bey çok teşekkür ederim cevaplarınız için. Excel sürümüm 2010. Söz konusu hücrede bolca html kodu da mevcut. Durum bundan kaynaklanıyor olabilir mi? Karakter sayısını azaltınca düzeliyor ama... Türkçe karakterler vb. şeyler de sorun yapıyor olabilir mi diye düşünüyorum?
necati beyin paylaşmış olduğu makro da 100 satır söz konusu iken çalışıyor. Ancak 2500 satırda işlem yapmak istediğimde 1.5 saat oldu halen devam etmekte.

Varsayımlardan çıkmak adına örnek bir de dosya yükledim. Vakit olması durumunda yardımınızı rica edeceğim.

https://s7.dosya.tc/server21/9izr27/Bitiyor.xlsx.html

Tekrar teşekkür eder, sağlıklı günler dilerim.

ÖmerFaruk · 17 Mayıs 2022

Dosyanızı yükledim çalışıyor.
Satır yüksekliğinden dolayı sanki bozuk gibi görünüyor diye düşünüyorsanız en alt satıra End Sub öncesi aşağıdakini ekleyin.
Worksheets("Sayfa4").Range("A2").Resize(Say, 55).RowHeight = 20

tefon · 17 Mayıs 2022

ÖmerFaruk' Alıntı:
Dosyanızı yükledim çalışıyor.
Satır yüksekliğinden dolayı sanki bozuk gibi görünüyor diye düşünüyorsanız en alt satıra End Sub öncesi aşağıdakini ekleyin.
Worksheets("Sayfa4").Range("A2").Resize(Say, 55).RowHeight = 20

Hata almaya devam ediyorum.

tefon · 17 Mayıs 2022

tefon' Alıntı:
Hata almaya devam ediyorum.

Fotoğraflarda hata olduğu için tekrar cevaplamak istedim.

ÖmerFaruk' Alıntı:
Dosyanızı yükledim çalışıyor.
Satır yüksekliğinden dolayı sanki bozuk gibi görünüyor diye düşünüyorsanız en alt satıra End Sub öncesi aşağıdakini ekleyin.
Worksheets("Sayfa4").Range("A2").Resize(Say, 55).RowHeight = 20

Hata almaya devam ediyorum. Excel sürümüm 2010 olduğu için olabilir mi?

ÖmerFaruk · 17 Mayıs 2022

Dediğim gibi gönderdiğiniz örnek dosyada ben hatayla karşılaşmıyorum.

Siz bu hatayı gönderdiğiniz örnek dosyada mı alıyorsunuz?
Hata verdiğinde Say değişkeninin değeri nedir?

Bana gönderdiğiniz dosyayı çalışır haliyle sizle tekrar paylaşıyorum.

tefon · 17 Mayıs 2022

ÖmerFaruk' Alıntı:
Dediğim gibi gönderdiğiniz örnek dosyada ben hatayla karşılaşmıyorum.

Siz bu hatayı gönderdiğiniz örnek dosyada mı alıyorsunuz?
Hata verdiğinde Say değişkeninin değeri nedir?

Bana gönderdiğiniz dosyayı çalışır haliyle sizle tekrar paylaşıyorum.

Aynı dosyada işlem yapıyorum. Sizi rahatsız etmemek adına tekrar konu açmadan önce birkaç farklı bir EXCEL sürümünde de denedim. 2003 - 2007 - 2010.. https://s7.dosya.tc/server21/9izr27/Bitiyor.xlsx.html bu dosyayı aşağıdaki makro ile çalıştırdığımda hata devam etmekte.

Kod:

Sub EkleDoldur()
'Satır Hücre ekle ve doldur
Dim Renkler, xArr As Variant, Liste()
LastRow = Range("A" & Rows.Count).End(3).Row
xArr = Range("A2").Resize(LastRow - 1, 55).Value

For i = LBound(xArr) To UBound(xArr)
   Say = Say + 1
   ReDim Preserve Liste(1 To 55, 1 To Say)
   For k = 1 To 55
      Liste(k, Say) = xArr(i, k)
   Next k
   Kontrol = InStr(1, xArr(i, 14), "/")
   If Kontrol Then
      Renkler = Split(xArr(i, 14), "/")
      Liste(14, Say) = Renkler(0)
      For k = 1 To UBound(Renkler)
         Say = Say + 1
         ReDim Preserve Liste(1 To 55, 1 To Say)
         For x = 1 To 55
            Liste(x, Say) = xArr(i, x)
         Next x
         Liste(14, Say) = Renkler(k)
      Next k
   End If
Next i
Worksheets("Sayfa4").Range("A2").Resize(Say, 55) = Application.Transpose(Liste)
End Sub

Run-time error '13';
Type mismatch

Kod:

Worksheets("Sayfa4").Range("A2").Resize(Say, 55) = Application.Transpose(Liste)

İlk satırdan itibaren kodu veriyor. 28. sütuna kadar alırsam 27 dahil sorun olmuyor. Ancak 28. sütun ve sonrasında aynı hatayı almaktayım.

ÖmerFaruk · 17 Mayıs 2022

Kusura bakmayın. Bu dosyada da sorun göremiyorum ben.
Kodları Module içine ekledim ve çalıştırdım. Bir de süreyi ekledim.

Sorunun çözümünü bilen bir başka arkadaş cevap verecektir.
Kodların son hali de aşağıdaki gibi.

C++:

Sub EkleDoldur()

   Dim Renkler, xArr As Variant, Liste(), ProsesTime As Double
   ProcessTime = Timer
   LastRow = Range("A" & Rows.Count).End(3).Row
   xArr = Range("A2").Resize(LastRow - 1, 55).Value
  
   For i = LBound(xArr) To UBound(xArr)
      Say = Say + 1
      ReDim Preserve Liste(1 To 55, 1 To Say)
      For k = 1 To 55
         Liste(k, Say) = xArr(i, k)
      Next k
      Kontrol = InStr(1, xArr(i, 14), "/")
      If Kontrol Then
         Renkler = Split(xArr(i, 14), "/")
         Liste(14, Say) = Renkler(0)
         For k = 1 To UBound(Renkler)
            Say = Say + 1
            ReDim Preserve Liste(1 To 55, 1 To Say)
            For x = 1 To 55
               Liste(x, Say) = xArr(i, x)
            Next x
            Liste(14, Say) = Renkler(k)
         Next k
      End If
   Next i
   Worksheets("Sayfa4").Range("A2").Resize(Say, 55) = Application.Transpose(Liste)
   Worksheets("Sayfa4").Range("A2").Resize(Say, 55).RowHeight = 20
   MsgBox "Your transaction is complete." & vbCr & vbCr & "Processing time ; " & Format(Timer - ProcessTime, "0.00") & " Second"
End Sub

mesuttasar · 17 Mayıs 2022

Örnek dosyanızı indirip aşağıdaki kodlarla denedim, gayet hızlı bir şekilde istediğiniz işlemi gerçekleştiriyor.
Dener misiniz?

Kod:

Sub DENEME()
Application.ScreenUpdating = False
son = Cells(Rows.Count, "A").End(3).Row
For i = son To 2 Step -1
yazi = Cells(i, 14).Text

If InStr(yazi, "/") = 0 Then GoTo 10 Else
Ln = Len(yazi)
n = InStr(yazi, "/")
ti = Left(yazi, n - 1)
ts = Right(yazi, Ln - n)
Rows(i).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Cells(i, 14) = ti
Cells(i + 1, 14) = ts
Cells(1, 1).Select
10
Next i

End Sub

tefon · 17 Mayıs 2022

mesuttasar' Alıntı:
Örnek dosyanızı indirip aşağıdaki kodlarla denedim, gayet hızlı bir şekilde istediğiniz işlemi gerçekleştiriyor.
Dener misiniz?

Kod:

Sub DENEME() Application.ScreenUpdating = False son = Cells(Rows.Count, "A").End(3).Row For i = son To 2 Step -1 yazi = Cells(i, 14).Text If InStr(yazi, "/") = 0 Then GoTo 10 Else Ln = Len(yazi) n = InStr(yazi, "/") ti = Left(yazi, n - 1) ts = Right(yazi, Ln - n) Rows(i).Select Selection.Copy Selection.Insert Shift:=xlDown Application.CutCopyMode = False Cells(i, 14) = ti Cells(i + 1, 14) = ts Cells(1, 1).Select 10 Next i End Sub

Harikasınız, çok teşekkür ediyorum.
Yüreğiniz dert görmesin.
Son olarak bu makroya ayırma işleminden sonra ürün SKU'larının aynı olmaması için *SKU kodu bölümünün sonuna ayırma işlemi kadar 1-2-3-4 şeklinde sayı ekleyebilir miyiz?

Örnek;

*Ürün SPU kodu

*SKU kodu

*Ürün adı

*Fiyat(USD)

İndirim fiyatını görüntüle(USD)

*Stok

köken

*Marka adı

Malzeme

Müstehcen resim

Cinsel istekler

*Birim çeşidi

AERenk

AEBoyut

Rengi İçe Aktar

*Kargo şablonu

*Hizmet şablonu

*Kargo hazırlık süresi (gün)

*Ambalaj Ağırlığı (kg/adet)

*Paketleme Boyutu (Uzunluk*Genişlik*Yükseklik) Birim:cm

SKU görsel

*Ana görsel 1

Ana görsel 2

Ana görsel 3

Ana görsel 4

Ana görsel 5

Ana görsel 6

*Ürün Açıklaması

Rusya Federasyonu(USD)

Amerika Birleşik Devletleri(USD)

Kanada(USD)

İspanya(USD)

Fransa(USD)

Birleşik Krallık(USD)

Hollanda(USD)

İsrail(USD)

Brezilya(USD)

Şili(USD)

Avustralya(USD)

Ukrayna(USD)

Belarus(USD)

Japonya(USD)

Tayland(USD)

Singapur(USD)

Güney Kore(USD)

Endonezya(USD)

Malezya(USD)

Filipinler(USD)

Vietnam(USD)

İtalya(USD)

Almanya(USD)

Suudi Arabistan(USD)

Birleşik Arap Emirlikleri(USD)

Polonya(USD)

Türkiye(USD)

T131

82135

Ürün Adı Buraya

41,04

118

TR (kökeni)

other

adet

Black

S/M/L/XL

Cainiao Kargo

Service Template for New Sellers

3

0,75

5*10*8

görsel.jpg

ürün açıklaması

Olmasını istediğim;

*Ürün SPU kodu

*SKU kodu

*Ürün adı

*Fiyat(USD)

İndirim fiyatını görüntüle(USD)

*Stok

köken

*Marka adı

Malzeme

Müstehcen resim

Cinsel istekler

*Birim çeşidi

AERenk

AEBoyut

Rengi İçe Aktar

*Kargo şablonu

*Hizmet şablonu

*Kargo hazırlık süresi (gün)

*Ambalaj Ağırlığı (kg/adet)

*Paketleme Boyutu (Uzunluk*Genişlik*Yükseklik) Birim:cm

SKU görsel

*Ana görsel 1

Ana görsel 2

Ana görsel 3

Ana görsel 4

Ana görsel 5

Ana görsel 6

*Ürün Açıklaması

Rusya Federasyonu(USD)

Amerika Birleşik Devletleri(USD)

Kanada(USD)

İspanya(USD)

Fransa(USD)

Birleşik Krallık(USD)

Hollanda(USD)

İsrail(USD)

Brezilya(USD)

Şili(USD)

Avustralya(USD)

Ukrayna(USD)

Belarus(USD)

Japonya(USD)

Tayland(USD)

Singapur(USD)

Güney Kore(USD)

Endonezya(USD)

Malezya(USD)

Filipinler(USD)

Vietnam(USD)

İtalya(USD)

Almanya(USD)

Suudi Arabistan(USD)

Birleşik Arap Emirlikleri(USD)

Polonya(USD)

Türkiye(USD)

T131

82135

Ürün Adı Buraya

41,04

118

TR (kökeni)

other

adet

Black

S

Cainiao Kargo

Service Template for New Sellers

3

0,75

5*10*8

görsel.jpg

ürün açıklaması

T131

821351

Ürün Adı Buraya

41,04

118

TR (kökeni)

other

adet

Black

M

Cainiao Kargo

Service Template for New Sellers

3

0,75

5*10*8

görsel.jpg

ürün açıklaması

T131

821352

Ürün Adı Buraya

41,04

118

TR (kökeni)

other

adet

Black

L

Cainiao Kargo

Service Template for New Sellers

3

0,75

5*10*8

görsel.jpg

ürün açıklaması

T131

821353

Ürün Adı Buraya

41,04

118

TR (kökeni)

other

adet

Black

XL

Cainiao Kargo

Service Template for New Sellers

3

0,75

5*10*8

görsel.jpg

ürün açıklaması

Şimdiden çok teşekkür ederim.

Korhan Ayhan · 18 Mayıs 2022

Veri alanlarında 255 karakterden uzun veri içeren alanlar varsa Application.Transpose kullanmak sıkıntı yaratabiliyor.

Alternatif olarak deneyiniz.

C++:

Option Explicit

Sub Bedenleri_Listele()
    Dim Veri As Variant, Zaman As Double, X As Long, Say As Long
    Dim Beden As Variant, Y As Byte, Z As Byte
   
    Zaman = Timer
   
    Veri = Range("A1").CurrentRegion.Value
   
    ReDim Liste(1 To Rows.Count, 1 To UBound(Veri, 2))
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Beden = Split(Veri(X, 14) & "/", "/")
        For Y = LBound(Beden) To UBound(Beden)
            If Beden(Y) <> "" Then
                Say = Say + 1
                For Z = 1 To UBound(Veri, 2)
                    Select Case Z
                        Case 2
                            Liste(Say, Z) = Veri(X, Z) & IIf(Y = 0, "", Y)
                        Case 14
                            Liste(Say, Z) = Beden(Y)
                        Case Else
                            Liste(Say, Z) = Veri(X, Z)
                    End Select
                Next
            End If
        Next
    Next
   
    Range("A1").Resize(Say, UBound(Liste, 2)) = Liste
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Soru Satırı Belirli Bir Karaktere Göre Kopyalamak

tefon

mesuttasar

tefon

tefon

necati

tefon

ÖmerFaruk

Destek Ekibi

tefon

tefon

ÖmerFaruk

Destek Ekibi

tefon

ÖmerFaruk

Destek Ekibi

tefon

tefon

ÖmerFaruk

Destek Ekibi

Ekli dosyalar

tefon

ÖmerFaruk

Destek Ekibi

mesuttasar

tefon

Korhan Ayhan

Administrator