Tabloyu Parçalara Bölmek

[ptcuye41]

Merhabalar, elimdeki dosyada bulunan tabloyu alt tablolara ayırmak istiyorum. Söyleyerek anlatamayabilirim ama dosyaya bakarsanız demek istediğimi anlarsınız diye düşünüyorum. Yardım ederseniz sevirim.

Tabloyu_Parcalara_Bolme.xlsx dosyasını indir - download

Tabloyu_Parcalara_Bolme.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

 

[ÖmerFaruk]

Formülle mi? Kodla mı?
Tablonuz çok mu büyük?
Aynı sayfaya mı farklı sayfaya mı?

 

[ptcuye41]

Hangi şekilde yapılabilirse. Sanırım makro ile yapılması daha uygun olur diye bu bölüme açtım konuyu.
Elimde çok fazla bu şekilde dosya var. Bunları tek bir excel dosyası altında toplayacağım. Ama büyük dosyalarda sorun olacaksa parça parça uygulayıp en son birleştirebilirim.
Aynı sayfada olması benim daha çok işime gelir. Ama mümkün değilse farklı sayfada da olabilir.

 

[ÖmerFaruk]

Tabloların hepsi aynı büyüklükte mi? Yani A3:E7 aralığında mı?

 

[Ziynettin]

Ben de bu arada çalışma yaptımıştım. Olması istediğiniz tabloyu silin, kod çalıştırıldığında verileriniz J2 den itibaren listelenecektir.

Sub test()
Sheets("Sayfa1").Select
son = Cells(Rows.Count, 1).End(3).Row
If son < 4 Then Exit Sub
a = Range("A3:E" & son).Value
Set dc = CreateObject("scripting.dictionary")
For j = 2 To UBound(a, 2)
    For i = 2 To UBound(a)
        krt = a(1, j) & "|" & a(i, 1)
        dc(krt) = a(i, j)
    Next i
Next j

ReDim b(1 To dc.Count, 1 To 3)
For Each v In dc.keys
    s = s + 1
    b(s, 1) = Split(v, "|")(0)
    b(s, 2) = Split(v, "|")(1)
    b(s, 3) = dc(v)
Next v
With Range("J2:L" & Rows.Count)
    .ClearContents
    .ClearFormats
End With
With [J2].Resize(dc.Count, 3)
    .Value = b
    .Borders.Color = RGB(19, 19, 149)
End With
MsgBox "İşlem Bitti.", vbInformation
End Sub

 

[ptcuye41]

Tabloların hepsi aynı büyüklükte mi? Yani A3:E7 aralığında mı?

En büyük hali A4:O189

Bazı dosyalar daha küçük olabiliyor. Satır olarak 189 standart. Sütun olarak değişebiliyor. Genellikle A4:O189 şeklinde ama.

 

[ÖmerFaruk]

Ziynettin beyin kodları sorunu çözecektir, belki son mesajınıza göre düzenlemeye ihtiyaç olabilir.

 

[ptcuye41]

Ben de bu arada çalışma yaptımıştım. Olması istediğiniz tabloyu silin, kod çalıştırıldığında verileriniz J2 den itibaren listelenecektir.

Sub test()
Sheets("Sayfa1").Select
son = Cells(Rows.Count, 1).End(3).Row
If son < 4 Then Exit Sub
a = Range("A3:E" & son).Value
Set dc = CreateObject("scripting.dictionary")
For j = 2 To UBound(a, 2)
    For i = 2 To UBound(a)
        krt = a(1, j) & "|" & a(i, 1)
        dc(krt) = a(i, j)
    Next i
Next j

ReDim b(1 To dc.Count, 1 To 3)
For Each v In dc.keys
    s = s + 1
    b(s, 1) = Split(v, "|")(0)
    b(s, 2) = Split(v, "|")(1)
    b(s, 3) = dc(v)
Next v
With Range("J2:L" & Rows.Count)
    .ClearContents
    .ClearFormats
End With
With [J2].Resize(dc.Count, 3)
    .Value = b
    .Borders.Color = RGB(19, 19, 149)
End With
MsgBox "İşlem Bitti.", vbInformation
End Sub

Hocam çok teşekkür ederim. Ellerinize sağlık. Aradığım tam olarak bu. Dosyalara uygun şekilde düzenlemek için hangi parametrelerde değişiklik yapmam gerekir onları da gösterebilir misiniz?

 

[Ziynettin]

Tablo [A3:O?] aralığı olarak, listeleme R2 olacak şekilde.

Sub test_1()
Sheets("Sayfa1").Select ' Sayfa1 çalışma sayfa adıdır kendinize göre uyarlayın.
son = Cells(Rows.Count, 1).End(3).Row
If son < 4 Then Exit Sub
a = Range("A3:O" & son).Value
Set dc = CreateObject("scripting.dictionary")
For j = 2 To UBound(a, 2)
    If Not IsEmpty(a(1, j)) Then
        For i = 2 To UBound(a)
            krt = a(1, j) & "|" & a(i, 1)
            dc(krt) = a(i, j)
        Next i
    End If
Next j

ReDim b(1 To dc.Count, 1 To 3)
For Each v In dc.keys
    s = s + 1
    b(s, 1) = Split(v, "|")(0)
    b(s, 2) = Split(v, "|")(1)
    b(s, 3) = dc(v)
Next v
With Range("R2:S" & Rows.Count)
    .ClearContents
    .ClearFormats
End With
With [R2].Resize(dc.Count, 3)
    .Value = b
    .Borders.Color = RGB(19, 19, 149)
End With
MsgBox "İşlem Bitti.", vbInformation
End Sub

 

[ptcuye41]

Tablo [A3:O?] aralığı olarak, listeleme R2 olacak şekilde.

Sub test_1()
Sheets("Sayfa1").Select ' Sayfa1 çalışma sayfa adıdır kendinize göre uyarlayın.
son = Cells(Rows.Count, 1).End(3).Row
If son < 4 Then Exit Sub
a = Range("A3:O" & son).Value
Set dc = CreateObject("scripting.dictionary")
For j = 2 To UBound(a, 2)
    If Not IsEmpty(a(1, j)) Then
        For i = 2 To UBound(a)
            krt = a(1, j) & "|" & a(i, 1)
            dc(krt) = a(i, j)
        Next i
    End If
Next j

ReDim b(1 To dc.Count, 1 To 3)
For Each v In dc.keys
    s = s + 1
    b(s, 1) = Split(v, "|")(0)
    b(s, 2) = Split(v, "|")(1)
    b(s, 3) = dc(v)
Next v
With Range("R2:S" & Rows.Count)
    .ClearContents
    .ClearFormats
End With
With [R2].Resize(dc.Count, 3)
    .Value = b
    .Borders.Color = RGB(19, 19, 149)
End With
MsgBox "İşlem Bitti.", vbInformation
End Sub

Hocam çok teşekkür ederim.