Düşey sütundaki verileri yatay yazma

[quantum32]

Merhabalar,

Ekli dosya incelenebilirse;

Veriler Sayfa1 deki gibi. Bir makro aracılığı ile Sayfa2 deki hale getirebilir miyiz.

Teşekkürler.

 

[mesuttasar]

Tabi ki getirebiliriz.Aşağıdaki kodları boş bir modüle kopyalayıp çalıştırın.Saygılarımla,

Sub deneme()
Dim a, bb As Integer
Dim s1, s2 As Worksheet
Set s1 = Sheets("sheet1")
Set s2 = Sheets("sheet2")
s2.Select
Columns("A:I").Select
Selection.ClearContents
s1.Select
a = s1.[a65536].End(3).Row
For i = 1 To a
s1.Select
If Cells(i, 1) <> 0 Then
s2.Select
DoEvents
bb = s2.[a65536].End(3).Row
s2.Cells(bb + 1, 1) = s1.Cells(i, 1)
s2.Cells(bb + 1, 2) = s1.Cells(i, 2)
s2.Cells(bb + 1, 3) = s1.Cells(i + 1, 2)
s2.Cells(bb + 1, 4) = s1.Cells(i + 1, 3)
s2.Cells(bb + 1, 5) = s1.Cells(i + 2, 2)
s2.Cells(bb + 1, 6) = s1.Cells(i + 2, 3)
s2.Cells(bb + 1, 7) = s1.Cells(i + 3, 2)
s2.Cells(bb + 1, 8) = s1.Cells(i + 4, 2)
s2.Cells(bb + 1, 9) = s1.Cells(i + 5, 2)
End If
Next i
Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Columns("A:I").EntireColumn.AutoFit
MsgBox "Düzenleme tamamlanmıştır."
s2.Cells(1, 1).Select
End Sub

 

[quantum32]

Mesut bey,

Öncelikle teşekkür ederim. Bu hali ile düzgün çalışıyor. Ancak her bir turuncu başlığın altındaki satır sayıları azalabilir veya artabilir. Bu şekilde deneyince olmadı. Rica etsem bu şekilde düzenleyebilirmiyiz.

Saygılarımla.

 

[hımmmmmmmm]

slm

çalışma ekde

 

[quantum32]

Merhabalar,

Dosya için teşekkür ederim. Ancak Bir satırda her 2 kolonda da aynı rakam yazıyorsa 1 kere yazması gerekiyor. yani 100 100 ise 2. sayfaya 1 kere 100 yazmalı

Teşekkürler.

 

[quantum32]

Merhabalar hımmmmmm,

Yaptığınız çalışmada macroyu özelliklemi vermiyorsunuz. Bu şekilde kullanma şansım yok, kendi dosyama aktaracağım. Mümkün ise verebilir misiniz.

 

[hımmmmmmmm]

slm

ekde verdiğim dosyanın visual kısmından görebilirsin...
görünüm-araç çubukları-denetim araç kutusu tıkla
tasarım modu ikonunu tıkla...
sayfadaki buton nesne seçimi olacak ...
butona çift tıkla macro karşında
'----------------- veya---------------------
görünüm-araç çubukları-visual basic tıkla
visual basic düzenleyici ikonunu tıkla
macro karşında

 

[hımmmmmmmm]

slm

kontrollü son çalışma
'--------------------------------------------------

Private Sub CommandButton1_Click()
Set S1 = Sheets("sheet1")
Set S2 = Sheets("sheet2")
S2.Range("A:Z") = ""
'-----------------------------------------------
X = WorksheetFunction.CountA(S1.Range("B:B"))
D = "**"
For I = 1 To X
    N = S1.Cells(I, 1).Value
    K = S1.Cells(I, 2).Value
    If N = D Then
        SUT = 0
        SAT = SAT + 1
        SUT = SUT + 1:  S2.Cells(SAT, SUT) = N
        SUT = SUT + 1:  S2.Cells(SAT, SUT) = K
        GoTo DEVAM
    End If
    X1 = Cells(I, 2).Value
    X2 = Cells(I, 3).Value
    If X1 = X2 Then SUT = SUT + 1: S2.Cells(SAT, SUT) = X1: GoTo DEVAM
    '-------------------------------------------
    SUT = SUT + 1:  S2.Cells(SAT, SUT) = X1
    SUT = SUT + 1:  S2.Cells(SAT, SUT) = X2
DEVAM:
Next I
End Sub

 

[hımmmmmmmm]

slm

çift sayı kontrolü yapılmışı... çalışma ekde

 

[quantum32]

Merhabalar,

Ellerinize sağlık, çok teşekkür ederim.

Saygılarımla...

 

[quantum32]

Merhabalar hımmmmmm,

Dosyada A sütununda bulunan ** ifadesinin yerine herhangibir büyük harf (Örn. K, S, M gibi ) geldiğini düşünerek kodu tekrar güncelleyebilir miyiz.

Buraya gelecek harfler her zaman değişebilir. Ancak mutlaka herhangi bir harf olacak.

Teşekkürler.

 

[hımmmmmmmm]

slm

yeni duruma göre

Private Sub CommandButton1_Click()
Set s1 = Sheets("sheet1")
Set S2 = Sheets("sheet2")
S2.Range("A:Z") = ""
'-----------------------------------------------
X = WorksheetFunction.CountA(s1.Range("B:B"))
D = ""
SAT = 0
For I = 1 To X
    N = s1.Cells(I, 1).Value
    K = s1.Cells(I, 2).Value
    If N <> D Then
        SUT = 0
        SAT = SAT + 1
        SUT = SUT + 1:  S2.Cells(SAT, SUT) = N
        SUT = SUT + 1:  S2.Cells(SAT, SUT) = K
        N = ""
        GoTo DEVAM
    End If
    X1 = s1.Cells(I, 2).Value
    X2 = s1.Cells(I, 3).Value
    If X1 = X2 Then SUT = SUT + 1: S2.Cells(SAT, SUT) = X1: GoTo DEVAM
    '-------------------------------------------
    SUT = SUT + 1:  S2.Cells(SAT, SUT) = X1
    SUT = SUT + 1:  S2.Cells(SAT, SUT) = X2
DEVAM:
Next I
End Sub

 

[hımmmmmmmm]

slm

dosya ekde

 

[hımmmmmmmm]

slm

dosya şimdi ekde

 

[quantum32]

İyi akşamlar,

Tekrar ellerinize sağlık teşekkür ederim.

Saygılarımla...