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

yasin85 · 16 Nisan 2019

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

Orion1 · 16 Nisan 2019

Buyurun.

Dosyanız ektedir.

Kod:

Sub aktar59()
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
Sheets("Sayfa2").Select
Set sh = Sheets("Sayfa1")
Range("A2:B" & Rows.Count).Clear
Application.ScreenUpdating = False
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
sat = 2
On Error Resume Next
For i = 2 To sonsat
    kod = sh.Cells(i, "A").Value
    ayirac = sh.Cells(i, "B").Value
    deg = 0
    For j = 1 To 2
        For x = 16383 To 3 Step -1
            If sh.Cells(i, x).Value <> "" Then
                Cells(sat, "A").Value = kod
                sonuc = Format(Split(sh.Cells(i, x).Value, ayirac)(deg), "00")
                Cells(sat, "B").NumberFormat = "@"
                Cells(sat, "B").Value = Format(sonuc, "00")
                sat = sat + 1
            End If
        Next x
        deg = 1
    Next j
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı."
    
End Sub

ÖmerBey · 16 Nisan 2019

Merhaba,
Alternatif olsun, buyurunuz...

PHP:

Sub Ayir()
Dim s1 As Worksheet: Set s1 = Sheets("Sayfa1")
Dim s2 As Worksheet: Set s2 = Sheets("Sayfa2")
Dim a As Long, b As Integer, x As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
x = 1
s2.Range("A:B").ClearContents
s2.Cells(1, 1) = "KOD"
s2.Cells(1, 2) = "SONUC"
For a = 2 To s1.Cells(Rows.Count, "A").End(3).Row
    kod = s1.Cells(a, "A")
    ayr = s1.Cells(a, "B")
    For b = 3 To 16383
        If s1.Cells(a, b) <> "" Then
            metin = Split(s1.Cells(a, b), ayr)
            For Each met In metin
                x = x + 1
                s2.Cells(x, 1) = kod
                s2.Cells(x, 2) = met
            Next
        End If
    Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamam"
End Sub

Orion1 · 16 Nisan 2019

2 numaralı mesajdaki cevabımı tekrardan revize ettim.
Dosyayı tekrar indiriniz.

Ziynettin · 16 Nisan 2019

Alternatif,

Sonuç mükerrer olarak.

Kod:

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

yasin85 · 16 Nisan 2019

Orion1' Alıntı:
2 numaralı mesajdaki cevabımı tekrardan revize ettim.
Dosyayı tekrar indiriniz.

Sn. Orion1,
Ellerinize sağlık her zaman ki gibi gene muhteşem bir işlem olmuş sadece (01,02,03) yani 0 ile başlayan numaraların sıfırlarını işlem yiyor hücreyi metne çevirdim gene aynı durum onun revize edilmesi gerek diğer tüm işlemler tamam dır.

yasin85 · 16 Nisan 2019

ÖmerBey' Alıntı:

Merhaba,
Alternatif olsun, buyurunuz...

PHP:

Sub Ayir()
Dim s1 As Worksheet: Set s1 = Sheets("Sayfa1")
Dim s2 As Worksheet: Set s2 = Sheets("Sayfa2")
Dim a As Long, b As Integer, x As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
x = 1
s2.Range("A:B").ClearContents
s2.Cells(1, 1) = "KOD"
s2.Cells(1, 2) = "SONUC"
For a = 2 To s1.Cells(Rows.Count, "A").End(3).Row
    kod = s1.Cells(a, "A")
    ayr = s1.Cells(a, "B")
    For b = 3 To 16383
        If s1.Cells(a, b) <> "" Then
            metin = Split(s1.Cells(a, b), ayr)
            For Each met In metin
                x = x + 1
                s2.Cells(x, 1) = kod
                s2.Cells(x, 2) = met
            Next
        End If
    Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamam"
End Sub

Sn. @ÖmerBey ,

Ellerinize sağlık tam istediğim gibi olmuş.. elleriniz dert görmesin

Orion1 · 16 Nisan 2019

yasin85' Alıntı:
Sn. Orion1,
Ellerinize sağlık her zaman ki gibi gene muhteşem bir işlem olmuş sadece (01,02,03) yani 0 ile başlayan numaraların sıfırlarını işlem yiyor hücreyi metne çevirdim gene aynı durum onun revize edilmesi gerek diğer tüm işlemler tamam dır.

2 numaralı mesajımı revize ettim.
Tekrar indirip deneyiniz.

yasin85 · 16 Nisan 2019

Ziynettin' Alıntı:

Alternatif,

Sonuç mükerrer olarak.

Kod:

Sub test()
Set s1 = Sheets("Sayfa1")
son = s1.Cells(Rows.Count, 1).End(3).Row
a = s1.Range("A2:G" & son).Value
Set d = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a) * 10, 1 To 2)
For i = 1 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

Sn. @Ziynettin ,

Ellerinize sağlık yaptığınız çalışmayı test ettim çok güzel bir çalışma ufak bir revize edilmesi gerek satırları sağa ve aşağı doğru çoğaltığımda sadece örnekteki alan kadar işlem yapıyor onu revize ederseniz işlem tamam dır.

Ziynettin · 16 Nisan 2019

yasin85' Alıntı:
Sn. @Ziynettin ,

Ellerinize sağlık yaptığınız çalışmayı test ettim çok güzel bir çalışma ufak bir revize edilmesi gerek satırları sağa ve aşağı doğru çoğaltığımda sadece örnekteki alan kadar işlem yapıyor onu revize ederseniz işlem tamam dır.

Kod revize edildi.
Tekrar deneyiniz.

Orion1 · 16 Nisan 2019

Kendim yaptığım Progresbarı ekledim.
Eklediğim dosyaya bakabilirsiniz.

yasin85 · 17 Nisan 2019

Orion1' Alıntı:
Kendim yaptığım Progresbarı ekledim.
Eklediğim dosyaya bakabilirsiniz.

Sn. @Orion1 ,

Son dosya için test çalışması yaptım benzersiz gelmesini sağlaya bilirseniz aynı olanlar tekrar geldiği için geliş zamanını da bir o kadar daha uzatıyor.

yasin85 · 17 Nisan 2019

Ziynettin' Alıntı:
Kod revize edildi.
Tekrar deneyiniz.

Sn. @Ziynettin ,

Revizeyi test ettim işlem satırlarını sağa ve sola çoğaltıp kodu çalıştırdığımda atlamalar yapıyor.

yasin85 · 17 Nisan 2019

Sn. @ÖmerBey ,

Sayfa2 de sonuç kısmında benzersiz olarak ayarlaya bilirmiyiz.

ÖmerBey · 17 Nisan 2019

Kodun sonuna şu 3 satırı ilave edip deneyiniz.

Kod:

s2.Range("C1:C" & x).Formula = "=CONCATENATE(A1,B1)"
s2.Range("A:C").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
s2.Range("C:C").ClearContents

yasin85 · 17 Nisan 2019

ÖmerBey' Alıntı:
Kodun sonuna şu 3 satırı ilave edip deneyiniz.

Kod:

s2.Range("C1:C" & x).Formula = "=CONCATENATE(A1,B1)" s2.Range("A:C").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes s2.Range("C:C").ClearContents

Sn. @ÖmerBey ,

ilgili satırları ekleyince işlem 45 dk oldu devam ediyordu kapattım işlemi..
İlk haline geri aldım o şekilde çalıştırdım. ( 3 dk işlem bitti )..

Bu işlemi hızlandırmamız mümkün müdür.

tekrarlanan olunca excel satır sınırında kalıyor diğer veriler işlem görmüyor, tekrarlayan olmayıncaya işlem süresi çok uzun sürüyor.
yardımlarınızı bekliyorum.

ÖmerBey · 17 Nisan 2019

Bir de şunu deneyiniz...

PHP:

Sub Ayir()
Dim s1 As Worksheet: Set s1 = Sheets("Sayfa1")
Dim s2 As Worksheet: Set s2 = Sheets("Sayfa2")
Dim a As Long, b As Integer, x As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
x = 1
s2.Range("A:C").ClearContents
s2.Range("A:C").NumberFormat = "@"
s2.Cells(1, 1) = "KOD"
s2.Cells(1, 2) = "SONUC"
For a = 2 To s1.Cells(Rows.Count, "A").End(3).Row
    DoEvents
    kod = s1.Cells(a, "A")
    ayr = s1.Cells(a, "B")
    For b = 3 To 16383
        If s1.Cells(a, b) <> "" Then
            metin = Split(s1.Cells(a, b), ayr)
            For Each met In metin
                If WorksheetFunction.CountIf(s2.Range("C:C"), kod & met) = 0 Then
                    x = x + 1
                    s2.Cells(x, 1) = kod
                    s2.Cells(x, 2) = met
                    s2.Cells(x, 3) = kod & met
                End If
            Next
        End If
    Next
Next
s2.Range("C:C").ClearContents
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamam"
End Sub

Düzeltme: Yukarıdaki kod şu şekilde daha hızlı galiba:

PHP:

Sub Ayir()
Dim s1 As Worksheet: Set s1 = Sheets("Sayfa1")
Dim s2 As Worksheet: Set s2 = Sheets("Sayfa2")
Dim a As Long, b As Integer, x As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
x = 1
s2.Range("A:C").ClearContents
s2.Range("A:C").NumberFormat = "@"
s2.Cells(1, 1) = "KOD"
s2.Cells(1, 2) = "SONUC"
For a = 2 To s1.Cells(Rows.Count, "A").End(3).Row
    DoEvents
    kod = s1.Cells(a, "A")
    ayr = s1.Cells(a, "B")
    For b = 3 To 16383
        If s1.Cells(a, b) <> "" Then
            metin = Split(s1.Cells(a, b), ayr)
            For Each met In metin
                'If WorksheetFunction.CountIf(s2.Range("C:C"), kod & met) = 0 Then
                    x = x + 1
                    s2.Cells(x, 1) = kod
                    s2.Cells(x, 2) = met
                    s2.Cells(x, 3) = kod & met
                'End If
            Next
        End If
    Next
Next
s2.Range("A:C").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
s2.Range("C:C").ClearContents
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamam"
End Sub

Ziynettin · 17 Nisan 2019

yasin85' Alıntı:
Sn. @Ziynettin ,

Revizeyi test ettim işlem satırlarını sağa ve sola çoğaltıp kodu çalıştırdığımda atlamalar yapıyor.

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

Orion1 · 17 Nisan 2019

yasin85' Alıntı:
Sn. @Orion1 ,

Son dosya için test çalışması yaptım benzersiz gelmesini sağlaya bilirseniz aynı olanlar tekrar geldiği için geliş zamanını da bir o kadar daha uzatıyor.

Benzersiz aşağıdaki gibi oldu.

Dosya ektedir.

Kod:

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

yasin85 · 17 Nisan 2019

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..

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

yasin85

Ekli dosyalar

Orion1

Uzman

Ekli dosyalar

ÖmerBey

Destek Ekibi

Orion1

Uzman

Ziynettin

Destek Ekibi

yasin85

yasin85

Orion1

Uzman

yasin85

Ziynettin

Destek Ekibi

Orion1

Uzman

Ekli dosyalar

yasin85

yasin85

yasin85

Ekli dosyalar

ÖmerBey

Destek Ekibi

yasin85

ÖmerBey

Destek Ekibi

Ziynettin

Destek Ekibi

Orion1

Uzman

Ekli dosyalar

yasin85