Virgül olan satırlar bozulmadan biralt satıra eklenmesi

[saracevic]

Arkadaşlar,örnekli dosyada A Hücresinde bulunan seri numalarının sonlarında virgül ve boşluklar var,ben bunları B hücresindeki değerler bozulmadan alt satıra virgülsüz ve boşluksuz nasıl alabilirim,makro mu yazılması gerekekir acaba,şimdiden teşekkürler.

 

[Necdet]

Merhaba,

Ben sorunuzdan hiç bir şey anlamadım.

 

[saracevic]

Necdet bey sanırım ben anlatamadım kusurabakmayın,A Hücresinde bulunan seri numaraları birden fazla ve yanlarında boşluk yada virgül gibi karakterler var ,ben bu boşluk ve karakterlerin otomatik silinmesini ve bir alt satıra geçmesini sağlamak amacım,yani her bir seri numarası 1 satırda olucak,B ve C hücresindeki değerler bozulmadan,ekli resim 1 de orjinal halini ve 2. resimde olması gereken şekilde belirttim,yardımlarınız ve ilginiz için çok teşekkürler.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp dener misiniz?

Sayfa2 de sonucu gösterir.

Sub Duzenle()
    
    Dim i   As Long, _
        j   As Long, _
        k   As Integer, _
        s1  As Worksheet, _
        s2  As Worksheet, _
        deg, _
        d
    
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
    
    s2.Range("A1:C" & Rows.Count).ClearContents
    
    For i = 2 To s1.Cells(Rows.Count, "A").End(3).Row
        
        If Application.WorksheetFunction.CountA(Range("A" & i & ":C" & i)) > 0 Then
            j = j + 1
            s2.Cells(j, "B") = s1.Cells(i, "B")
            s2.Cells(j, "C") = s1.Cells(i, "C")
            j = j - 1
            deg = Application.WorksheetFunction.Trim(Replace(Replace(s1.Cells(i, "A"), ",", " "), Chr(10), " "))
            If deg = "" Then deg = " "
            d = Split(deg, " ")
                For k = 0 To UBound(d)
                    If Not d(k) = "" Then
                        j = j + 1
                        s2.Cells(j, "A") = d(k)
                    End If
                Next k
        End If
    Next i
    
    MsgBox "Düzenleme Bitmiştir..."
    With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With
    
End Sub

 

[saracevic]

Necdet Bey,uygulamış olduğunuz kod kısmı harika çalıştı ancak,yine 1 satır altında birden fazla olan seriler duruyor Ekran görüntüsü ve yeni XLS dosyasını tekrar gönderdim,ilginize teşekkür ederim.

 

[Necdet]

Merhaba,

Sub Duzenle()
    
    Dim i   As Long, _
        j   As Long, _
        k   As Integer, _
        s1  As Worksheet, _
        s2  As Worksheet, _
        deg, _
        d
    
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
    
    s2.Range("A1:C" & Rows.Count).ClearContents
    
    For i = 2 To s1.Cells(Rows.Count, "A").End(3).Row
    
        If Not s1.Cells(i, "B") = "" Then
            j = j + 1
            s1.Range("B" & i & ":L" & i).Copy s2.Cells(j, "B")
'            s2.Cells(j, "B") = s1.Cells(i, "B")
'            s2.Cells(j, "C") = s1.Cells(i, "C")
            deg = Application.WorksheetFunction.Trim(Replace(Replace(s1.Cells(i, "A"), ",", " "), Chr(10), " "))
            If Not deg = "" Then j = j - 1
            d = Split(deg, " ")
                For k = 0 To UBound(d)
                    If Not d(k) = "" Then
                        j = j + 1
                        s2.Cells(j, "A") = d(k)
                    End If
                Next k
        End If
        
    Next i
    
    MsgBox "Düzenleme Bitmiştir..."
    With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With
    
End Sub

 

[saracevic]

Necdet bey dediğin şekilde,revize ettim formulü ancak,ekran görüntüsünü gönderdim serilerin çoğu birbirine bitişik şekilde olmuş satırda uzamış

 

[Necdet]

Necdet bey dediğin şekilde,revize ettim formulü ancak,ekran görüntüsünü gönderdim serilerin çoğu birbirine bitişik şekilde olmuş satırda uzamış

Merhaba,

Tüm verilerde ayırıcı karekterin ne olduğunu doğal olarak incelemedim.
Siz en son gönderdiğiniz dosyada satır numarasını verirseniz inceleme fırsatımız olabilir.

Resimden anlamak güç.

 

[saracevic]

Necdet Bey,6810. satırdan 6815 e kadar olan satırda var,resimde büyük olduğu için sol kenarda kalmış sanırım.Teşekkürler.

 

[Necdet]

Necdet Bey,6810. satırdan 6815 e kadar olan satırda var,resimde büyük olduğu için sol kenarda kalmış sanırım.Teşekkürler.

Merhaba,

Bazı veriler virgül ile ayrılmadığı için oluyormuş. 6. mesajımdaki kodları değiştirdim. Deneyip sonucu bildirin lütfen.

 

[Necdet]

Merhaba,

A sütunu boş olanlarda varmış.

6. mesajım 2. defa değişmiştir.

 

[saracevic]

Necdet Bey, Sonuç durumunu XLS dosyasını ekledim,seri bilgileri tekrar içiçe durmakta.

 

[Necdet]

Necdet Bey, Sonuç durumunu XLS dosyasını ekledim,seri bilgileri tekrar içiçe durmakta.

Sanırım bu sefer oldu, 6 nolu mesaj yenilenmiştir.

Deneyip sonucu iletiniz.

 

[Necdet]

6. mesaj yine değiştirilmiştir

 

[saracevic]

Necdet bey,ekran görüntüsü ekledim,sonuç tekrar seriler yine içiçe gözükmek sütün genişliği 255 e kadar uzun durumda

 

[Necdet]

Necdet bey,ekran görüntüsü ekledim,sonuç tekrar seriler yine içiçe gözükmek sütün genişliği 255 e kadar uzun durumda

Son değişikliği aldınız mı? ben denediğimde öyle şeyler yoktu.

 

[saracevic]

Evet şuan tekrar denedim harika gözüküyor elleriniz dert görmesin üstadım tek bir sorun kaldı o da bazı satırlarda seri bilgisi uzun olduğu için, formülü uygulandıktan sonra "2.40207E+17" seri bilgisi bu şekilde gösteriyor.Hücreleri biçimlendirden sayı sekmesinden ondalık basamak sayısını düşüyorum ancak son rakam bilgisi 0000 şeklinde gösteriyor,buna nasıl bir çözüm bulabiliriz acaba.Tekrar yardımlarınıza minnettarım.

 

[Necdet]

Merhaba,

Sayfa2 nin A sütununu metin olarak biçimlendirin, kodları öyle çalıştırın.

 

[saracevic]

Sorunsuz harika çalışıyor yardımlarınız için çok teşekkürler.

 

[Necdet]

Sorunsuz harika çalışıyor yardımlarınız için çok teşekkürler.

Özelden sorduğunuz soruya yanıt olarak 6. mesajı yeniden düzenledim.

B:L hücresine kadar aktarıyor.

Önceki 2 satır kod açıklama olarak yerinde bıraktım. Yeşil olarak gözüken satırları silebilirsiniz de isterseniz.