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

[ÖmerFaruk]

@Korhan Ayhan bey,
"Veri alanlarında 255 karakterden uzun veri içeren alanlar varsa Application.Transpose kullanmak sıkıntı yaratabiliyor."

Aynı sorunun bende de olması gerekmez mi? Ofis sürümüne göre değişkenli mi arzediyor?

Bu arada boyutlandırma satırınızda akıllıca bir çözüm uygulamışsınız. Hiç aklıma gelmemişti. Teşekkürler.
ReDim Liste(1 To Rows.Count, 1 To UBound(Veri, 2))

 

[Korhan Ayhan]

Ömer bey 255 karakterle ilgii nette arama yaparsanız farklı forumlarda bu konuyla ilgili açılmış başlıkları inceleyebilirsiniz. Bazı kullanıcılar bu hata ile karşılaştıklarını belirtmişler ki soru sahibi arkadaşımızda hata aldığını belirtmiş. Siz de çalışmasının sebebini bilemiyorum.

Ek olarak dizi bölümünde kullandığım boyutlandırma kısmında aslında farklı beden sayısı belli ise o çarpanı kullanmak kodun daha hızlı sonuç vermesini sağlayacaktır. Ama bu durumu bilmediğim için ben bir excel sayfasındaki satır sayısı kadar tanımladım.

Mesela UBound(Veri, 1) * 10 olarak tanımlarsak daha hızlı sonuç alabiliriz. Burada kullandığım 10 değeri farklı beden sayısını ifade etmektedir. Bu biliniyorsa bu şekilde kullanmak hız açısından daha iyi olacaktır.

 

[mesuttasar]

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?

Aşağıdaki kodları dener misiniz?

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(i + 1, 2) = Cells(i + 1, 2).Text & "1"
Cells(1, 1).Select
10
Next i

End Sub

 

[mesuttasar]

Aşağıdaki kodları dener misiniz?

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(i + 1, 2) = Cells(i + 1, 2).Text & "1"     '<-------Bu satırdaki kodu, aşağıdaki kod ile değiştirin.
Cells(1, 1).Select
10
Next i

End Sub

Cells(i + 1, 2) = Cells(i + 1, 2).Value + 1

önceki postta belirttiğim kısmı aşağıdaki şekilde değiştirerek te kullanabilirsiniz.

 

[tefon]

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

Alternatif olarak deneyiniz.

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

ReDim Liste(1 To Rows.Count, 1 To UBound(Veri, 2)) bölümünde

Run-time error '7';
Out of Memory

hatası ile karşılaştım. 16GB ram var ama farklı bir cihaz ile tekrar deneme yapacağım. Çok teşekkür ediyorum. Emeğiniz, elleriniz dert görmesin.

 

[tefon]

Cells(i + 1, 2) = Cells(i + 1, 2).Value + 1

önceki postta belirttiğim kısmı aşağıdaki şekilde değiştirerek te kullanabilirsiniz.

Şu şekilde ufak bir uyarlama yaptım.

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(i, 2) = Cells(i + 1, 2).Text & ti
Cells(i + 1, 2) = Cells(i + 1, 2).Text & ts
Cells(1, 1).Select
10
Next i

End Sub

Harika çalışıyor gerçekten üstadım. Yardımcı olan herkese çok teşekkür ediyorum.

 

[mesuttasar]

Yardımcı olabildiysem ne mutlu, kolay gelsin..