yanyana boşluklu veriyi altalta boşluksuz sıralama

[mmahmutkaya]

Merhabalar,

EK'te yüklediğim dosyadaki ilk sekmedeki veriyi, ikinci sekmedeki şekilde benim elle girdiğim veriyi formülle formülle yapmak mümkün mümkün mü? Çok veri içeren dosya var da ben örnek olsun diye küçülttüm.

https://wetransfer.com/downloads/9d...88aa7d72d7d3f61f0d806c3720161217125422/3fa2c3

Teşekkürler

 

[Asri]

Linkteki dosyayı deneyiniz.
Kolonlar ve satırlar değişken olabilir.

http://dosya.co/2j13c3hppnj3/Devrik_Yapistir.xlsm.html

Dim liste() As String
Dim sonsatir, sonsutun As Integer

Sub menu()
   Call veri_yukle
   Call sonuc
End Sub

Sub sonuc()
   Sheets("Sonuc").Select
   Columns("A:I").Select
   Selection.ClearContents
   Range("A1").Select
   satir = 1
   For i = 2 To sonsatir
       Cells(satir, 1).Value = liste(i, 1)
       For k = 2 To sonsutun
         If liste(i, k) <> "" Then
           [COLOR=Red] [B]Cells(satir, 1).Value = liste(i, 1)[/B][/COLOR]
            Cells(satir, 2).Value = liste(1, k)
            Cells(satir, 3).Value = liste(i, k)
            satir = satir + 1
         End If
       Next k
   Next i
End Sub

Sub veri_yukle()
   Sheets("Veri").Select
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   sonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
   ReDim liste(sonsatir, sonsutun)
   For i = 1 To sonsatir
     For j = 1 To sonsutun
        liste(i, j) = Cells(i, j).Value
     Next j
   Next i
End Sub

 

[sakman26]

selam,

formülle çözüme yönelik bir örnek ektedir..
incelersiniz..

link : http://s3.dosya.tc/server9/7npe4z/Liste_SA.xlsx.html

 

[Ziynettin]

Alternatif,

Sub deneme()
Sheets("Veri").Select
a = Range("A1:K" & Cells(Rows.Count, 1).End(3).Row)
ReDim b(1 To Application.CountA(a), 1 To 3)
For i = 2 To UBound(a)
    b(say + 1, 1) = a(i, 1)
    For y = 2 To UBound(a, 2)
        say = say + 1
        If a(i, y) <> "" Then: c = c & "|" & a(i, y)
            k = Split(c, "|")
            b(say, 2) = a(1, y)
            b(say, 3) = a(i, y)
        say = UBound(k)
    Next y
Next i
Sheets("Sonuc").Range("A2:C" & Rows.Count).ClearContents
If say > 0 Then
Sheets("Sonuc").Range("A2").Resize(say, 3) = b
End If
Sheets("Sonuc").Select
MsgBox "İşlem Tamam.....", vbInformation
End Sub

http://s3.dosya.tc/server9/sjreql/Devrik_Yapistir.rar.html

 

[mmahmutkaya]

daha yeni girebildim siteye, hepinize çok teşekkür ediyorum, sorum olursa yine başınızı ağrıtıcam.

 

[mmahmutkaya]

Merhabalar herkese,

Yukarıda Sn. Asri'nin vermiş olduğu cevap da şöyle bir değişiklik yapabilirmiyiz. "oda1" oda2" "elektrik odası" ... gibi bilgiler sadece bir satır da değil ilgili her satırda yer alsın.

Şimdiden teşekkürler.

 

[Asri]

Merhabalar herkese,

Yukarıda Sn. Asri'nin vermiş olduğu cevap da şöyle bir değişiklik yapabilirmiyiz. "oda1" oda2" "elektrik odası" ... gibi bilgiler sadece bir satır da değil ilgili her satırda yer alsın.

Şimdiden teşekkürler.

Mesajımdaki açık kodu kullanınız.
Kırmızı ile işaretlendi.

 

[mmahmutkaya]

Çok teşekkür ederim Sn. Asri, işlerinizde kolaylıklar diliyorum.

Hem siz, hem de burada emeği geçen diğer arkadaşlara söylemek istiyorum; siz bize böyle karşılıksız iyilikler yapıyorsunuz, umarım siz de kendi işlerinizi yaparken kolaylıklarla karşılaşırsınız.