• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Dikey olarak verilen verileri, yatay olarak tabloya nasıl işlenir

B

bilal5412

Katılım
12 Nisan 2011
Mesajlar
190
Excel Vers. ve Dili
2010-TR
Merhaba arkadaşlar,

Ekte bir dosya vardır. Bu dosyada sayfa1 ve sayfa2 vardır. Yapılmak istenen, sayfa2 deki verileri, sayfa1 deki gibi nasıl getirebiliriz.


https://drive.google.com/file/d/0B3wJKQcxKCV4VVdPdW5zR0RvYXc/view?usp=sharing

*sayfa2 deki veri sayısı sınırsızdır. A sütununda boşluk yoktur.
*sayfa1 deki başlık sabit olup OP8 e kadar belirtilen sütun sayısı sayfa2 deki benzersiz OP lerin sayısına bağlıdır.

teşekkürler.
 
Son düzenleme:
Kod: 
Sub vEmre()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    sonS2 = s2.Cells(Rows.Count, "A").End(3).Row
    opSay = s1.Range("A1").End(2).Column - 1
    lst = s2.Range("A2:C" & sonS2).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(lst)
            key = lst(i, 1)
            If Not .exists(key) Then
                sat = sat + 1
                .Add key, sat
            End If
        Next i
        ReDim w(1 To sat, 1 To opSay + 1)
        ver = .keys
        For i = 0 To UBound(ver)
            w(i + 1, 1) = ver(i)
        Next i
        For i = 1 To UBound(lst)
            sut = Val(Replace(lst(i, 2), "OP", "")) + 1
            sat = .Item(lst(i, 1))
            w(sat, sut) = lst(i, 3)
        Next i
    End With
    s1.Range("a2:IV" & Rows.Count).ClearContents
    s1.[a2].Resize(UBound(w, 1), UBound(w, 2)).Value = w
    Erase lst, ver, w
    Set s1 = Nothing
    Set s2 = Nothing
End Sub
 
veyselemre' Alıntı:
Kod: 
Sub vEmre()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    sonS2 = s2.Cells(Rows.Count, "A").End(3).Row
    opSay = s1.Range("A1").End(2).Column - 1
    lst = s2.Range("A2:C" & sonS2).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(lst)
            key = lst(i, 1)
            If Not .exists(key) Then
                sat = sat + 1
                .Add key, sat
            End If
        Next i
        ReDim w(1 To sat, 1 To opSay + 1)
        ver = .keys
        For i = 0 To UBound(ver)
            w(i + 1, 1) = ver(i)
        Next i
        For i = 1 To UBound(lst)
            sut = Val(Replace(lst(i, 2), "OP", "")) + 1
            sat = .Item(lst(i, 1))
            w(sat, sut) = lst(i, 3)
        Next i
    End With
    s1.Range("a2:IV" & Rows.Count).ClearContents
    s1.[a2].Resize(UBound(w, 1), UBound(w, 2)).Value = w
    Erase lst, ver, w
    Set s1 = Nothing
    Set s2 = Nothing
End Sub
Genişletmek için tıkla ...

Sorunum çözülmüştür. Çok teşekkürler.

İyi günler.
 
bilal5412' Alıntı:
Sorunum çözülmüştür. Çok teşekkürler.

İyi günler.
Genişletmek için tıkla ...

Emre bey,

sayfa1 deki op1,2,3,4 sütunlarının yerlerini değiştirdiğimde makro hata veriyor. Makro bu op1 veya op8 hangi sutunda ise sayfa2 deki herhangi bir kodda op8 değeri tanımlı ise sayfa1 deki op8 sütunu bul koda karşılık gelen değeri yaz. uyarlanabilir mi.
 
Son düzenleme:
bilal5412' Alıntı:
Emre bey,

sayfa1 deki op1,2,3,4 sütunlarının yerlerini değiştirdiğimde makro hata veriyor. Makro bu op1 veya op8 hangi sutunda ise sayfa2 deki herhangi bir kodda op8 değeri tanımlı ise sayfa1 deki op8 sütunu bul koda karşılık gelen değeri yaz. uyarlanabilir mi.
Genişletmek için tıkla ...
Kod: 
Sub vEmre()
basla:
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    sonS2 = s2.Cells(Rows.Count, "A").End(3).Row
    opSay = s1.Range("A1").End(2).Column
    lst = Application.Index(s1.Range(s1.Cells(1, 2), s1.Cells(1, opSay)).Value, 0, 0)

    Set dic = CreateObject("Scripting.Dictionary")
    With dic
        For i = 1 To opSay - 1
            .Add lst(i), i
        Next
    End With

    lst = s2.Range("A2:C" & sonS2).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(lst)
            key = lst(i, 1)
            If Not .exists(key) Then
                sat = sat + 1
                .Add key, sat
            End If
        Next i
        ReDim w(1 To sat, 1 To dic.Count + 1)
        ver = .keys
        For i = 0 To UBound(ver)
            w(i + 1, 1) = ver(i)
        Next i
        For i = 1 To UBound(lst)
            key = lst(i, 2)
            If Not dic.exists(key) Then
                dic.Add key, dic.Count + 1
                s1.Cells(1, dic.Count + 1).Value = key
                GoTo basla
            End If
            sut = dic.Item(lst(i, 2)) + 1
            sat = .Item(lst(i, 1))
            w(sat, sut) = lst(i, 3)
        Next i
    End With
    s1.Range("a2:IV" & Rows.Count).ClearContents
    s1.[a2].Resize(UBound(w, 1), UBound(w, 2)).Value = w
    Erase lst, ver, w
    Set s1 = Nothing
    Set s2 = Nothing
End Sub
 
veyselemre' Alıntı:
Kod: 
Sub vEmre()
basla:
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    sonS2 = s2.Cells(Rows.Count, "A").End(3).Row
    opSay = s1.Range("A1").End(2).Column
    lst = Application.Index(s1.Range(s1.Cells(1, 2), s1.Cells(1, opSay)).Value, 0, 0)

    Set dic = CreateObject("Scripting.Dictionary")
    With dic
        For i = 1 To opSay - 1
            .Add lst(i), i
        Next
    End With

    lst = s2.Range("A2:C" & sonS2).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(lst)
            key = lst(i, 1)
            If Not .exists(key) Then
                sat = sat + 1
                .Add key, sat
            End If
        Next i
        ReDim w(1 To sat, 1 To dic.Count + 1)
        ver = .keys
        For i = 0 To UBound(ver)
            w(i + 1, 1) = ver(i)
        Next i
        For i = 1 To UBound(lst)
            key = lst(i, 2)
            If Not dic.exists(key) Then
                dic.Add key, dic.Count + 1
                s1.Cells(1, dic.Count + 1).Value = key
                GoTo basla
            End If
            sut = dic.Item(lst(i, 2)) + 1
            sat = .Item(lst(i, 1))
            w(sat, sut) = lst(i, 3)
        Next i
    End With
    s1.Range("a2:IV" & Rows.Count).ClearContents
    s1.[a2].Resize(UBound(w, 1), UBound(w, 2)).Value = w
    Erase lst, ver, w
    Set s1 = Nothing
    Set s2 = Nothing
End Sub
Genişletmek için tıkla ...

Sorunum çözülmüştür. Çok teşekkürler.

İyi günler.
 
veyselemre' Alıntı:
Kod: 
Sub vEmre()
basla:
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    sonS2 = s2.Cells(Rows.Count, "A").End(3).Row
    opSay = s1.Range("A1").End(2).Column
    lst = Application.Index(s1.Range(s1.Cells(1, 2), s1.Cells(1, opSay)).Value, 0, 0)

    Set dic = CreateObject("Scripting.Dictionary")
    With dic
        For i = 1 To opSay - 1
            .Add lst(i), i
        Next
    End With

    lst = s2.Range("A2:C" & sonS2).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(lst)
            key = lst(i, 1)
            If Not .exists(key) Then
                sat = sat + 1
                .Add key, sat
            End If
        Next i
        ReDim w(1 To sat, 1 To dic.Count + 1)
        ver = .keys
        For i = 0 To UBound(ver)
            w(i + 1, 1) = ver(i)
        Next i
        For i = 1 To UBound(lst)
            key = lst(i, 2)
            If Not dic.exists(key) Then
                dic.Add key, dic.Count + 1
                s1.Cells(1, dic.Count + 1).Value = key
                GoTo basla
            End If
            sut = dic.Item(lst(i, 2)) + 1
            sat = .Item(lst(i, 1))
            w(sat, sut) = lst(i, 3)
        Next i
    End With
    s1.Range("a2:IV" & Rows.Count).ClearContents
    s1.[a2].Resize(UBound(w, 1), UBound(w, 2)).Value = w
    Erase lst, ver, w
    Set s1 = Nothing
    Set s2 = Nothing
End Sub
Genişletmek için tıkla ...

Emre Bey,

Yardımlarınız için teşekkür ederim. Bir rica için daha yardımcı olabilir misiniz. Sayfa1 deki herhangi bir veya birkaç OP yan yana örnek olarak; B,C,D,E sütunları OP2 olup, sayfa2 deki tüm OP2 değerleri bu BCDE sutunlarına tanımlanmış OP2 değeri için bu sütunlara veri girebilir mi.

**Daha önceki makro ardışık ilerleyen şeklinde idi. Şimdi ise ; OP1, OP2,OP2,OP2,OP3,OP3,OP4,OP4,OP5 gibi.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst