YAN YANA VERİLERİ KOŞULLARA GÖRE ALT ALTA GETİRME

[yasin85]

Sağa ve sola çoğalttığınız dosyayı eklermisiniz.

Sn. @Ziynettin ,

Dosya Ektedir.

 

[Orion1]

19ncu mesajda benim son yaptığım dosyayı inceledinizmi?

 

[yasin85]

Benzersiz aşağıdaki gibi oldu.
Dosya ektedir.

Private Sub UserForm_Activate()
Dim f As Long, prgrsbaruzunluk As Double, deg3 As Long
Dim labeluzunluk As Double, oran As Double
Dim sh As Worksheet, i As Long, x As Integer, sonsat As Long
Dim sat As Long, j As Byte, kod As String, ayirac As String
Dim deg As Integer, sonuc As String, myarr(), liste()
Dim z As Object, n As Long, refno As String
Sheets("Sayfa2").Select
Set sh = Sheets("Sayfa1")
Range("A2:C" & Rows.Count).Clear
Range("B2:B" & Rows.Count).NumberFormat = "@"
Range("C2:C" & Rows.Count).NumberFormat = "#,##0"
Application.ScreenUpdating = False
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Set z = CreateObject("scripting.dictionary")
sat = 2
Application.ScreenUpdating = False
prgrsbaruzunluk = 16381 * 2 * (sonsat - 1)
labeluzunluk = Label2.Width
Label2.Width = 1
deg3 = 1
liste = sh.Range("A2:XFC" & sonsat).Value
ReDim myarr(1 To 16383 * 2, 3)
For i = 1 To UBound(liste)
    kod = liste(i, 1)
    ayirac = liste(i, 2)
    deg = 0
    For j = 1 To 2
        For x = 16383 To 3 Step -1
            If liste(i, x) <> "" Then
                sonuc = Format(Split(liste(i, x), ayirac)(deg), "00")
                refno = kod & sonuc
                If Not z.exists(refno) Then
                    n = n + 1
                    z.Add refno, n
                    myarr(n, 1) = kod
                    myarr(n, 2) = sonuc
                End If
                myarr(z.Item(refno), 3) = myarr(z.Item(refno), 3) + 1
            End If
            oran = (deg3 / prgrsbaruzunluk)
            DoEvents
            Label2.Width = Int(oran * labeluzunluk)
            Label1.Caption = "% " & Int((deg3 / prgrsbaruzunluk) * 100)
            deg3 = deg3 + 1
        Next x
       deg = 1
    Next j
Next
Erase liste()
Set z = Nothing
Range("A2").Resize(n, 3) = myarr
Erase myarr()
Application.Wait Now + TimeValue("00:00:01")
Unload Me
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı."
End Sub

Sn. @Orion1 ,
Dosya çalışıyor ellerinize sağlık tek sorun yavaş olması başka problem yok C hücresinden SO hücresi arasında ve satır olarak da 1000 satırlık işlemi oldukça uzun sürede yapıyor onada katlanacağız çok güzel bir çalışma oldu ellerinize sağlık..

 

[yasin85]

Sn. @ÖmerBey ,

İlk yaptığınız işlem benzersiz çalışıyor fakat oda çok uzun sürüyor..
ikinci kodunuz hızlı çalışıyor fakat tekrarlananlar geliyor bilginize..

Sn. @ÖmerBey ,

İlk yaptığınızı dikkate alıyorum daha işlem için uğraşmayın bekleme işide bunun tuzu olsun ellerinize sağlık bilgilerinize sağlık çok teşekkürler..

 

[ÖmerBey]

Sn. @ÖmerBey ,
İlk yaptığınızı dikkate alıyorum daha işlem için uğraşmayın bekleme işide bunun tuzu olsun ellerinize sağlık bilgilerinize sağlık çok teşekkürler..

Rica ederim,
2. kod da benim yaptığım denemelerde doğru sonuç üretiyor. Daha doğrusu her iki kod da aynı sonuçları üretmişti. Neyse hangisini beğenirseniz onu kullanırsınız.
İyi çalışmalar...

 

[Orion1]

Sn. @Orion1 ,
Dosya çalışıyor ellerinize sağlık tek sorun yavaş olması başka problem yok C hücresinden SO hücresi arasında ve satır olarak da 1000 satırlık işlemi oldukça uzun sürede yapıyor onada katlanacağız çok güzel bir çalışma oldu ellerinize sağlık..

16830 küsur veriyi her satırda 2 kere dönüyor.
yavaş olması gayet doğaldır.
İyi çalışmalar.

 

[Deniz61]

Merhabalar,

C hücresinden XFC hücresine kadar uzunlukta olan alanda yan yana olan verileri alt alta gelmesinin işlemi yapmak istiyorum fakat B hücresinde yazılmış olan koşulu dikkate alarak hücre içerisinde ayraç niteliğinde bir alt satıra yazmasını sağlaya bilir miyiz?

Alt alta halini ekte bulunan exceldeki sayfa 2 düzeni gibi olması konusunda yardımcı ola bilir misiniz.

http://s2.dosya.tc/server8/dnjcjw/_VERILERI_KOSULLARA_GORE_ALT_ALTA_GETIRME.rar.html

Koşullar= (","),(" "),("/"),("*"),("-"),("alt+enter") .. vb

Hocam teşekkür ederim. Ama excel dosyası hariç bir şey indiremedim.

 

[Deniz61]

Alternatif,

Sonuç mükerrer olarak.

Sub test()
Set s1 = Sheets("Sayfa1")
a = s1.Range("A2").CurrentRegion
Set d = CreateObject("scripting.dictionary")
art = (UBound(a, 2) - 2) * 2
ReDim b(1 To UBound(a) * art, 1 To 2)
For i = 2 To UBound(a)
    For j = 3 To UBound(a, 2)
        deg = Split(a(i, j), a(i, 2))
        For x = 0 To UBound(deg)
            krt = deg(x)
            If Not d.exists(krt) Then
                d(krt) = d.Count + 1
                say = d.Count
                b(say, 1) = a(i, 1)
                b(say, 2) = deg(x)
            End If
        Next x
    Next j
Next i
Set s2 = Sheets("Sayfa2")
s2.Range("A2:B" & Rows.Count) = Empty
If say > 0 Then: s2.[A2].Resize(say, 2) = b
MsgBox "İşlem bitti.", vbInformation
End Sub

teşekkür ederim hocam

 

[yasin85]

Merhaba @ÖmerBey ,

2021 yılında sizlerden aldığım destek ile uzun zamandır kullandığım makro çalışmasında güncelleme yapmamız gerekli dosyanın çalışır halde olan halini ekliyorum.
Sayfa2 = olmasını istediğim çıktı halini ekledim özet ile oradan göre bilirsiniz.

bir önceki versiyonda KOD başlığı sabit kalacak şekilde diğer verileri alt alta yanına ekliyorduk.

yeni versiyonda KOD başlığı sabit kalacak REF AD NO ve REF ORJ NO alanları sırası ile alt alta gelmesi gereklidir.

Zamanınız var ise sizden dosyayı kontrol etmeniz ve mümkünse yardımcı olmanızı bekleriz.

Desteklerinizi bekliyoruz.

 

[yasin85]

Herkese Merhaba,

Revize işlemi için destek ola bilecek uzman hocalarımızdan yardım bekliyoruz.

Teşekkürler.