yan yana olan hücreleri alt alta nasıl getirebilirim

[esad45]

benım bır satırım da ısım soy ısım var ve o aldıgı urunler yan yana yazılı a1 ad soyad b1 de urun c1 de urun d1 de urun ısımı yazılı bu boyle surup gıdıyor bazı musterılerde 3 urun bazılarında 15 urun oluyor bu satırı alt alta
ad soyad urun1
ad soyad urun2
ad soyad urun 3 seklınde alt alta nasıl getıebılrıım ısım aynı urunler farklı olacak sekılde

 

[mustafaberge]

Merhaba

Kopyala özel yapıştır işlemi tersine cevir

 

[Korhan Ayhan]

Deneyiniz.

Dosyanızda Sayfa1 ve Sayfa2 isimli iki sayfa olsun.

Sayfa1 isimli sayfada bahsettiğiniz verileriniz olsun. Aşağıdaki kod yeni listeyi Sayfa2 isimli sayfaya yapacaktır.

Verilerinizin A1 hücresinden başladığı varsayılmıştır.

Option Explicit

Sub Alt_Alta_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Say As Long
    Dim X As Long, Y As Integer, Veri As Variant
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S2.Cells.Clear
    
    Veri = S1.Range("A1").CurrentRegion.Value
    
    ReDim Liste(1 To UBound(Veri, 1) * UBound(Veri, 2), 1 To 2)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            For Y = 2 To UBound(Veri, 2)
                If Veri(X, Y) <> "" Then
                    Say = Say + 1
                    Liste(Say, 1) = Veri(X, 1)
                    Liste(Say, 2) = Veri(X, Y)
                End If
            Next
        End If
    Next
    
    If Say > 0 Then
        S2.Range("A1").Resize(Say, 2) = Liste
        S2.Columns.AutoFit
        MsgBox "Verileriniz düzenlenmiştir.", vbInformation
    Else
        MsgBox "Uygun kayıt bulunamadı.", vbInformation
    End If

    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[yusuf1284]

Hocam seçili hücreleri bir kısayol(Tüm sayfalarda çalışması için) vasıtasyla tek hücreye yazmak için ne yapabiliriz?
Benim uyguladığım yöntem alt alta veriler için not defterine yapıştırıp sonra txt içerisinde kopyalama yapıphücre içersinde yapıştırmak oluyor her sayfada konumu ve sayısı aynı değil

 

[Korhan Ayhan]

Örnek dosya paylaşarak yapmak istediğiniz işlemi açıklarsanız yardım almanız daha kolay olacaktır.

 

[yusuf1284]

Örnek dosya paylaşarak yapmak istediğiniz işlemi açıklarsanız yardım almanız daha kolay olacaktır.

Hocam içeriği baya silmek zorunda kaldım TERÖRLE MÜCADELE KAPSAMINDA yazan faaliyetlerin karşısında yazan isimler ve kontrol yapılan yeri tek sayfada tarihlerine göre toparlama ihtimalimiz var mıdır yerleri ve saati değişiyor sayfa adları hep gün gün gitmekte.
Dosyayı baktıktan sonra silme şansınız varsa silerseniz çok iyi olur ben bulamadım silmenin yolunu

 

[Korhan Ayhan]

Paylaştığınız dosyanızı isteğinize istinaden forumda sildim.

Aşağıdaki kodu deneyiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Rng As Range, Son As Long, Say As Long
    Dim X As Long, Y As Long, No As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set S1 = Sheets("FLYT_SONUCU")
    
    S1.Range("E6:K" & S1.Rows.Count).Clear
    Son = S1.Cells(S1.Rows.Count, "F").End(3).Row + 1
    
    For Each S2 In ThisWorkbook.Worksheets
        If S2.Name <> S1.Name Then
            No = No + 1
            For Each Rng In S2.Range("B4:B40,F4:F40")
                If Rng.MergeCells And Rng.Value <> "" Then
                    If InStr(1, Rng.Value, "TERÖR") > 0 Then
                        Say = Say + Rng.MergeArea.Cells.Count
                        If X = 0 Then
                            X = Son
                        Else
                            Y = Son
                        End If
                        S1.Cells(Son, "E") = No
                        Rng.Offset(, 2).MergeArea.Copy
                        S1.Cells(Son, "F").PasteSpecial xlValues
                        S1.Cells(Son, "F").Resize(Rng.MergeArea.Cells.Count).MergeCells = True
                        S1.Cells(Son, "F").Resize(Rng.MergeArea.Cells.Count).HorizontalAlignment = xlCenter
                        S1.Cells(Son, "F").Resize(Rng.MergeArea.Cells.Count).VerticalAlignment = xlCenter
                        S1.Cells(Son, "F").Resize(Rng.MergeArea.Cells.Count).WrapText = True
                        S1.Cells(Son, "F").Resize(Rng.MergeArea.Cells.Count).Borders.LineStyle = 1
                        Rng.Offset(, 1).Resize(Rng.MergeArea.Cells.Count).Copy
                        S1.Cells(Son, "G").PasteSpecial xlValues
                        S1.Cells(Son, "G").Resize(Rng.MergeArea.Cells.Count).BorderAround (1)
                        S1.Cells(Son, "H").Resize(1, 2).Value = Split(Rng.Parent.Name, " ")(0)
                        S1.Cells(Son, "H").Resize(Rng.MergeArea.Cells.Count).MergeCells = True
                        S1.Cells(Son, "I").Resize(Rng.MergeArea.Cells.Count).MergeCells = True
                        S1.Cells(Son, "J").Value = Split(Split(Rng.Value, Chr(10))(0), "-")(0)
                        S1.Cells(Son, "K").Value = Split(Split(Rng.Value, Chr(10))(0), "-")(1)
                        S1.Cells(Son, "J").Resize(Rng.MergeArea.Cells.Count).MergeCells = True
                        S1.Cells(Son, "K").Resize(Rng.MergeArea.Cells.Count).MergeCells = True
                        S1.Cells(Son, "G").Resize(Rng.MergeArea.Cells.Count, 5).HorizontalAlignment = xlCenter
                        S1.Cells(Son, "H").Resize(Rng.MergeArea.Cells.Count, 4).VerticalAlignment = xlCenter
                        S1.Cells(Son, "H").Resize(Rng.MergeArea.Cells.Count, 4).Borders.LineStyle = 1
                        Son = Son + Rng.MergeArea.Cells.Count
                    End If
                End If
            Next
            If X > 0 And Y > 0 Then
                S1.Cells(X, "E").Resize(Say).MergeCells = True
                S1.Cells(X, "E").Resize(Say).HorizontalAlignment = xlCenter
                S1.Cells(X, "E").Resize(Say).VerticalAlignment = xlCenter
                S1.Cells(X, "E").Resize(Say).Borders.LineStyle = 1
                Say = 0
                X = 0
                Y = 0
            End If
        End If
    Next

    S1.Select
    Range("A1").Select

    Set S1 = Nothing
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[yusuf1284]

Görevdeyim karakola geçince hocam teşekkür ederim

 

[esad45]

Örnek dosya paylaşarak yapmak istediğiniz işlemi açıklarsanız yardım almanız daha kolay olacaktır.

Hocam ben google form kullanarak kayit aliyorum ordaki seceneklerde kisiler ders seciyor ve dersler bir hucrede arada virgul konularak geliyor benim istedigim her ogrenci icin her dersi alt alta yazmasi yani ben boylelikle 1. sinifta ne kadar matematik dersi istendigini sayabilmeliyim ornek ham dosyami koyuyorum sayfa 2 de ise sayfa 1 deki ham bilgilerden 1 kisinin nasil olmasi gerektigini manuel yapmaya calistim dersler isimleri ve adetleri surekli degisiyor siralamada ayni sekilde degisiyor degismeyen tek sey husrede iki dersin arasi virgul ve boslukla ayrilmasi tek degismeyen bu eke ekledigim calisma kitainda ayrintili gostermeye calistigim bu calismam da yardimci olursaniz cok sevinirim

 

[esad45]

bu konuda yardim edebilecek var mi acaba?