Yatay verileri Tablo haline dönüştürme

[excellkurdu]

Arkadaşlar Merhabalar,
İşimdeki verileri excel sayfasına yatay şeklinde kaydettim. Yılladır biriktirdiğim verileri Yatay dan düşey hale çevirmek istiyorum. Makro ile yapıldığında yavaşlama olacağının farkındayım. Bu sorun değil.
Yatay verilerim 10 sutundan oluşmaktadır. Soldan Sağa doğru bu 10 arlı sutun DKO6 sutununa kadar devam ediyor (yani 300 adet satır veriyi barındırıyor).
Data C sutunundaki tüm tarihlere ait verileri Tek sayfada alt alta çekmek istiyorum.
Şimdiden teşekkür ederim.

 

[ÖmerFaruk]

Örnek dosyanızdaki sayfa isimleri ve hücre aralıklarına uygun olarak aşağıdaki kodları kullanabilirsiniz.

Sub YatayVeriler()
    Dim i As Integer, k As Integer, x As Integer, xSut As Integer, xSat As Integer, Say As Long
    Arr = Worksheets("Data").Range("A5").CurrentRegion.Value
    ReDim Liste(1 To (UBound(Arr, 2) - 5) / 10 * (UBound(Arr) - 1), 1 To 11)
    For i = 2 To UBound(Arr)
        For k = 6 To UBound(Arr, 2) Step 10
            Say = Say + 1
            Liste(Say, 1) = Arr(i, 3)
            For x = 1 To 10
                Liste(Say, x + 1) = Arr(i, k + x - 1)
            Next x
        Next k
    Next i
    Worksheets("mustericanli").Range("A7").Resize(Say, 11) = Liste
End Sub

 

[excellkurdu]

Örnek dosyanızdaki sayfa isimleri ve hücre aralıklarına uygun olarak aşağıdaki kodları kullanabilirsiniz.

Sub YatayVeriler()
    Dim i As Integer, k As Integer, x As Integer, xSut As Integer, xSat As Integer, Say As Long
    Arr = Worksheets("Data").Range("A5").CurrentRegion.Value
    ReDim Liste(1 To (UBound(Arr, 2) - 5) / 10 * (UBound(Arr) - 1), 1 To 11)
    For i = 2 To UBound(Arr)
        For k = 6 To UBound(Arr, 2) Step 10
            Say = Say + 1
            Liste(Say, 1) = Arr(i, 3)
            For x = 1 To 10
                Liste(Say, x + 1) = Arr(i, k + x - 1)
            Next x
        Next k
    Next i
    Worksheets("mustericanli").Range("A7").Resize(Say, 11) = Liste
End Sub

Hocam Allah razı olsun. Gayet güzel olmuş

 

[excellkurdu]

Örnek dosyanızdaki sayfa isimleri ve hücre aralıklarına uygun olarak aşağıdaki kodları kullanabilirsiniz.

Sub YatayVeriler()
    Dim i As Integer, k As Integer, x As Integer, xSut As Integer, xSat As Integer, Say As Long
    Arr = Worksheets("Data").Range("A5").CurrentRegion.Value
    ReDim Liste(1 To (UBound(Arr, 2) - 5) / 10 * (UBound(Arr) - 1), 1 To 11)
    For i = 2 To UBound(Arr)
        For k = 6 To UBound(Arr, 2) Step 10
            Say = Say + 1
            Liste(Say, 1) = Arr(i, 3)
            For x = 1 To 10
                Liste(Say, x + 1) = Arr(i, k + x - 1)
            Next x
        Next k
    Next i
    Worksheets("mustericanli").Range("A7").Resize(Say, 11) = Liste
End Sub

Hocam sutun sayısı değişince formülü düzeltemedim.
10 lu sutun 16 ya çıkınca hata verdi. Butün varyonları denedim ama yapamadım

 

[ÖmerFaruk]

Bilgisayar başında değilim. Denemeden yolluyorum
Eğer basit değişiklikleri yapamayacaksanız sorunuz direkt 16 sütunda sorabilirdiniz.

Sub YatayVeriler()
    Dim i As Integer, k As Integer, x As Integer, xSut As Integer, xSat As Integer, Say As Long
    Arr = Worksheets("Data").Range("A5").CurrentRegion.Value
    ReDim Liste(1 To (UBound(Arr, 2) - 5) / 16 * (UBound(Arr) - 1), 1 To 17)
    For i = 2 To UBound(Arr)
        For k = 6 To UBound(Arr, 2) Step 16
            Say = Say + 1
            Liste(Say, 1) = Arr(i, 3)
            For x = 1 To 16
                Liste(Say, x + 1) = Arr(i, k + x - 1)
            Next x
        Next k
    Next i
    Worksheets("mustericanli").Range("A7").Resize(Say, 17) = Liste
End Sub

 

[excellkurdu]

Bilgisayar başında değilim. Denemeden yolluyorum
Eğer basit değişiklikleri yapamayacaksanız sorunuz direkt 16 sütunda sorabilirdiniz.

Sub YatayVeriler()
    Dim i As Integer, k As Integer, x As Integer, xSut As Integer, xSat As Integer, Say As Long
    Arr = Worksheets("Data").Range("A5").CurrentRegion.Value
    ReDim Liste(1 To (UBound(Arr, 2) - 5) / 16 * (UBound(Arr) - 1), 1 To 17)
    For i = 2 To UBound(Arr)
        For k = 6 To UBound(Arr, 2) Step 16
            Say = Say + 1
            Liste(Say, 1) = Arr(i, 3)
            For x = 1 To 16
                Liste(Say, x + 1) = Arr(i, k + x - 1)
            Next x
        Next k
    Next i
    Worksheets("mustericanli").Range("A7").Resize(Say, 17) = Liste
End Sub

Ömer Hocam bunları denedim.
"Run-time error '9': Subscript out of range" hatası veriyor. Hatayı yoksaymak için "On Error Resume Next" kullandım. Bu kez de Tablo karışık geliyor.
Düzeltme:
Ömer Hocam On Error Resume Next yerini değiştim düzeldi.

Sub uckun()
    Dim i As Integer, k As Integer, x As Integer, xSut As Integer, xSat As Integer, Say As Long
    On Error Resume Next
    Arr = Worksheets("Data").Range("A5").CurrentRegion.Value
    ReDim Liste(1 To (UBound(Arr, 2) - 5) / 16 * (UBound(Arr) - 1), 1 To 17)
    For i = 2 To UBound(Arr)
        For k = 6 To UBound(Arr, 2) Step 16
            Say = Say + 1
            Liste(Say, 1) = Arr(i, 3)
            For x = 1 To 16
                Liste(Say, x + 1) = Arr(i, k + x - 1)
            Next x
        Next k
    Next i
    Worksheets("musteriuckun").Range("A7").Resize(Say, 17) = Liste
End Sub

 

[excellkurdu]

İlgin ve alakan için teşekkür ederim

 

[ÖmerFaruk]

On Error Resume Next
buna gerek olacağını düşünmüyorum, başka bir sıkıntı olmalı.
Yine de sorunu bu şekilde çözdünüz ve işinize yaradıysa ne ala.

Kodların sonlamasından önce hata tepkisini normale almanız önemlidir.
Bunun için End Sub satırınızın hemen öncesine
On Error GoTo 0
yazmalısınız. (0=Sıfır)