Aynı hücrede alt alta yazılanları alt alta ayrı hücrelere yazdırmak

hakanayyildiz1 · 21 Mayıs 2020

Merbahalar arkadaslar. Baslıkta oldugu gibi aynı hücrede ALT+ENTER ile yazılmıs satırlarım var. Bunları yine alt alta olacak sekilde fakat farklı hücrelere yazdırmak istiyorum. Yardımlar için şimdiden teşekkürler . Örnek bu sekildedir

Ömer · 21 Mayıs 2020

Merhaba

A1 deki veriyi B2 de itibaren alt satırlara yazar.

Kod:

Sub yaz()

    Dim s, i As Integer, sat As Integer
    
    s = Split([A1], Chr(10))
    Range("B2:B" & Rows.Count).ClearContents
    
    sat = 2
    For i = 0 To UBound(s)
        Cells(sat, "B") = s(i)
        sat = sat + 1
    Next i
        
End Sub

baydeniro · 21 Mayıs 2020

Ömer' Alıntı:

Merhaba

A1 deki veriyi B2 de itibaren alt satırlara yazar.

Kod:

Sub yaz()

    Dim s, i As Integer, sat As Integer
   
    s = Split([A1], Chr(10))
    Range("B2:B" & Rows.Count).ClearContents
   
    sat = 2
    For i = 0 To UBound(s)
        Cells(sat, "B") = s(i)
        sat = sat + 1
    Next i
       
End Sub

Ömer üstadım kod için teşekkürler. Acaba ayırma sonuçlarını C2 den sağa doğru (D2, E2 ...) yapılması için kodu nasıl revize etmemiz gerekir !

hakanayyildiz1 · 21 Mayıs 2020

Ömer' Alıntı:

Merhaba

A1 deki veriyi B2 de itibaren alt satırlara yazar.

Kod:

Sub yaz()

    Dim s, i As Integer, sat As Integer
   
    s = Split([A1], Chr(10))
    Range("B2:B" & Rows.Count).ClearContents
   
    sat = 2
    For i = 0 To UBound(s)
        Cells(sat, "B") = s(i)
        sat = sat + 1
    Next i
       
End Sub

teşekkür ederim hocam. karmaşık bir yapıda uygulaycagim. sonuclarini bildirecegim

Ömer · 22 Mayıs 2020

baydeniro' Alıntı:
Ömer üstadım kod için teşekkürler. Acaba ayırma sonuçlarını C2 den sağa doğru (D2, E2 ...) yapılması için kodu nasıl revize etmemiz gerekir !

Merhaba,

Kod:

Sub yaz()

    Dim s, i As Integer, sat As Integer
   
    s = Split([A1], Chr(10))
    'Range("B2:B" & Rows.Count).ClearContents
    Range("C2:IV2").ClearContents
   
    sat = 3
    For i = 0 To UBound(s)
        'Cells(sat, "B") = s(i)
        Cells(2, sat) = s(i)
        sat = sat + 1
    Next i
       
End Sub

baydeniro · 22 Mayıs 2020

Ömer' Alıntı:

Merhaba,

Kod:

Sub yaz()

    Dim s, i As Integer, sat As Integer
  
    s = Split([A1], Chr(10))
    'Range("B2:B" & Rows.Count).ClearContents
    Range("C2:IV2").ClearContents
  
    sat = 3
    For i = 0 To UBound(s)
        'Cells(sat, "B") = s(i)
        Cells(2, sat) = s(i)
        sat = sat + 1
    Next i
      
End Sub

Çok teşekkür ederim üstadım, elinize sağlık. Bu vesileyle Ramazan Bayramınızın Mübarek olmasını, sevdiklerinizle sağlıkla huzurla geçmesini dilerim.

Ömer · 22 Mayıs 2020

Rica ederim. Sizinde Ramazan Bayramınız Mübarek olsun.

Korhan Ayhan · 22 Mayıs 2020

Alternatif;

Satırlara dönüştürmek;

C++:

Option Explicit

Sub Metni_Satirlara_Donustur()
    Dim Veri As Variant
   
    Range("B:B").ClearContents
    Veri = Split(Range("A1"), Chr(10))
    Range("B1").Resize(UBound(Veri) + 1) = Application.Transpose(Veri)

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Sütunlara dönüştürmek;

1. Yöntem;

C++:

Option Explicit

Sub Metni_Sutunlara_Donustur()
    Dim Veri As Variant
   
    Range("B:XFD").ClearContents
    Veri = Split(Range("A1"), Chr(10))
    Range("B1").Resize(, UBound(Veri) + 1) = Veri

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

2. Yöntem;

C++:

Option Explicit

Sub Metni_Sutunlara_Donustur()
    Range("B:XFD").ClearContents
    Range("A1").TextToColumns Destination:=Range("B1"), Other:=True, OtherChar:="" & Chr(10) & ""
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

Ek olarak son verdiğim kodu VERİ menüsünden METNİ SÜTUNLARA DÖNÜŞTÜR seçeneğini kullanarak elle de yapabilirsiniz.

A1 hücresini seçin. (B ve sonraki sütunlar boş olsun.)
Veri-Metni Sütunlara Dönüştür menüsünü açın.
İleri deyin.
Ekranda DİĞER seçeneğini tikleyip yanında kutucuğa CTRL+J tuşlayın. Bu tuşlama ile ALT+ENTER işlemini yapmış oluyorsunuz.
İleri deyin.
HEDEF bölümünde B1 hücresini seçtikten sonra SON tuşuna tıklayıp işlemi tamamlayın.

hakanayyildiz1 · 23 Mayıs 2020

Ömer' Alıntı:

Merhaba

A1 deki veriyi B2 de itibaren alt satırlara yazar.

Kod:

Sub yaz()

    Dim s, i As Integer, sat As Integer
   
    s = Split([A1], Chr(10))
    Range("B2:B" & Rows.Count).ClearContents
   
    sat = 2
    For i = 0 To UBound(s)
        Cells(sat, "B") = s(i)
        sat = sat + 1
    Next i
       
End Sub

hocam yeniden bir sorum olacak. bunu sayfada istedigim yerde uygulamak istiyorum. yani illa A1 de olmasina gerek yok. mesela C sütununu komple sütunu seceyim ve oradaki ALT+ENTER lı tüm hücreleri (bazılarında tek deger var bazılarında onlarca) yanına ayrı satırlara yazmayi düsünüyorum. kodla oynadim ama düzeltemedim. yardımcı olur musunuz

Korhan Ayhan · 23 Mayıs 2020

Deneyiniz.

Seçtiğiniz alanın yan tarafı boş olursa sıkıntı yaşamadan kullanırsınız.

C++:

Option Explicit

Sub Metni_Satirlara_Donustur()
    Dim Veri As Range, Say As Long, Kelime As Variant, Y As Integer
   
    ReDim Liste(1 To Rows.Count, 1 To 1)
   
    For Each Veri In Selection
        If Veri.Value <> "" Then
            If InStr(1, Veri.Value, Chr(10)) > 0 Then
                Kelime = Split(Veri.Value, Chr(10))
                For Y = 0 To UBound(Kelime)
                    Say = Say + 1
                    Liste(Say, 1) = Kelime(Y)
                Next
            Else
                Say = Say + 1
                Liste(Say, 1) = Veri.Value
            End If
        End If
    Next
    
    If Say > 0 Then
        With Selection
            .Offset(0, .Columns.Count).EntireColumn.ClearContents
            .Offset(0, .Columns.Count).Resize(Say, 1) = Liste
        End With
    End If
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

hakanayyildiz1 · 23 Mayıs 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

Seçtiğiniz alanın yan tarafı boş olursa sıkıntı yaşamadan kullanırsınız.

C++:

Option Explicit

Sub Metni_Satirlara_Donustur()
    Dim Veri As Range, Say As Long, Kelime As Variant, Y As Integer
  
    ReDim Liste(1 To Rows.Count, 1 To 1)
  
    For Each Veri In Selection
        If Veri.Value <> "" Then
            If InStr(1, Veri.Value, Chr(10)) > 0 Then
                Kelime = Split(Veri.Value, Chr(10))
                For Y = 0 To UBound(Kelime)
                    Say = Say + 1
                    Liste(Say, 1) = Kelime(Y)
                Next
            Else
                Say = Say + 1
                Liste(Say, 1) = Veri.Value
            End If
        End If
    Next
   
    If Say > 0 Then
        With Selection
            .Offset(0, .Columns.Count).EntireColumn.ClearContents
            .Offset(0, .Columns.Count).Resize(Say, 1) = Liste
        End With
    End If
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Hocam cok tesekkürler ama simdi bir problemle karsılastım. Verilerimde böyle bir durum mevcut. Örnegin 4 defa aynı deger yazdıgında bu sekilde sadece farklı degerleri yazmak sonrasını bos bırakmak istiyorum. Mümkün müdür acaba

Korhan Ayhan · 23 Mayıs 2020

Benzersiz listemi oluşturmak istiyorsunuz?

hakanayyildiz1 · 23 Mayıs 2020

hakanayyildiz1' Alıntı:
Hocam cok tesekkürler ama simdi bir problemle karsılastım. Verilerimde böyle bir durum mevcut. Örnegin 4 defa aynı deger yazdıgında bu sekilde sadece farklı degerleri yazmak sonrasını bos bırakmak istiyorum. Mümkün müdür acaba

Yani durum şöyle : Eger hücrede char10 yoksa direkt aynısını yazsın. Eger hücrede char10 varsa char10 sayısı+1 kadar satır var demektir ve bunlari yanina yazsın. Eger hücre örnekte oldugu gibi satır sayısından fazla tekrar ediyor ise fazla satırı boş bıraksın.
Yardımlarınız ve emeginiz icin tesekkürler

hakanayyildiz1 · 23 Mayıs 2020

Korhan Ayhan' Alıntı:
Benzersiz listemi oluşturmak istiyorsunuz?

Hayır listenin tamamında benzer hücreler olabilir. Ama aynı grupta benzer olmamasi gerekir

Korhan Ayhan · 23 Mayıs 2020

Hiç uğraşmayalım. Siz örnek dosyanızı ekleyin. Görmek istediğiniz sonucu da belirtin. Dosyanızın üzerinden çözüm üretelim.

hakanayyildiz1 · 23 Mayıs 2020

Korhan Ayhan' Alıntı:
Hiç uğraşmayalım. Siz örnek dosyanızı ekleyin. Görmek istediğiniz sonucu da belirtin. Dosyanızın üzerinden çözüm üretelim.

Bu sekilde bir senaryo ürettim. Amaç kişileri yazdırmak.

https://dosya.co/p9gd38w033q6/Kitap2.xlsx.html

ckarabacak · 23 Mayıs 2020

Sayın Ömer Bey, Korhan Ayhan Merhaba

Eki dosyada anlattığım gibi a sütununda satırlarda yazan metin veya değerleri rapor dosyasına sütun olarak makro ile aktarabilirmiyiz

Yardımcı olursanız sevinirim

YUSUF44 · 24 Mayıs 2020

hakanayyildiz1' Alıntı:
Bu sekilde bir senaryo ürettim. Amaç kişileri yazdırmak.

https://dosya.co/p9gd38w033q6/Kitap2.xlsx.html

Aşağıdaki formülü dener misiniz?

=EĞER(UZUNLUK(D4)=UZUNLUK(YERİNEKOY(D4;DAMGA(10);""));D4;EĞER(EĞERSAY(D3:D4;D4)=1;SOLDAN(D4;BUL(DAMGA(10);D4)-1);YERİNEKOY(KIRP(PARÇAAL(YERİNEKOY(D4;DAMGA(10);YİNELE(DAMGA(10);400));EĞERSAY($D$3:D3;D4)*400;EĞERSAY($D$3:D3;D4)*350));DAMGA(10);"")))

Mesajı yazdıktan sonra kontrol ettim; 3 malik için doğru çalışırken 4 ve üstü malikte doğru sonucu vermiyor maalesef.

YUSUF44 · 24 Mayıs 2020

ckarabacak' Alıntı:
Sayın Ömer Bey, Korhan Ayhan Merhaba

Eki dosyada anlattığım gibi a sütununda satırlarda yazan metin veya değerleri rapor dosyasına sütun olarak makro ile aktarabilirmiyiz

Yardımcı olursanız sevinirim

Deneyiniz:

PHP:

Sub taklaci()
Set s1 = Sheets("veri")
Set s2 = Sheets("rapor")
son = s1.Cells(Rows.Count, "A").End(3).Row
s1.Range("A1:A" & son).Copy: s2.[B1].PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
Application.CutCopyMode = False
End Sub

Korhan Ayhan · 24 Mayıs 2020

@hakanayyildiz1,

Deneyiniz.

C++:

Option Explicit

Sub Metni_Satirlara_Donustur()
    Dim Dizi As Object, Veri As Variant, Son As Long, X As Long, Y As Integer
    Dim Aranan As String, Say As Long, Kelime As Variant, Zaman As Double
   
    Zaman = Timer
   
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    Son = Cells(Rows.Count, "B").End(3).Row
    Veri = Range("C4:D" & Son).Value
    
    ReDim Liste(1 To UBound(Veri), 1 To 1)
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" And Veri(X, 2) <> "" Then
            Aranan = Veri(X, 1) & Veri(X, 2)
            If Not Dizi.Exists(Aranan) Then
                Dizi.Item(Aranan) = 1
            Else
                Dizi.Item(Aranan) = Dizi.Item(Aranan) + 1
            End If
        End If
    Next
   
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" And Veri(X, 2) <> "" Then
            Aranan = Veri(X, 1) & Veri(X, 2)
            If InStr(1, Veri(X, 2), Chr(10)) > 0 Then
                Kelime = Split(Veri(X, 2), Chr(10))
                For Y = 0 To Dizi.Item(Aranan) - 1
                    Say = Say + 1
                    If Y <= UBound(Kelime) Then
                        Liste(Say, 1) = Kelime(Y)
                    Else
                        Liste(Say, 1) = ""
                    End If
                Next
            Else
                Say = Say + 1
                Liste(Say, 1) = Veri(X, 2)
            End If
        End If
        X = Say
    Next
    
    If Say > 0 Then
        With Range("E4")
            .Resize(Rows.Count - 3, 1).ClearContents
            .Resize(Say, 1) = Liste
        End With
    End If
    
    Set Dizi = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Aynı hücrede alt alta yazılanları alt alta ayrı hücrelere yazdırmak

hakanayyildiz1

Ömer

Moderatör

baydeniro

hakanayyildiz1

Ömer

Moderatör

baydeniro

Ömer

Moderatör

Korhan Ayhan

Administrator

hakanayyildiz1

Korhan Ayhan

Administrator

hakanayyildiz1

Korhan Ayhan

Administrator

hakanayyildiz1

hakanayyildiz1

Korhan Ayhan

Administrator

hakanayyildiz1

ckarabacak

Ekli dosyalar

YUSUF44

Destek Ekibi

YUSUF44

Destek Ekibi

Korhan Ayhan

Administrator