• DİKKAT

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

Tabloyu Parçalara Bölmek

P

ptcuye41

Katılım
8 Kasım 2017
Mesajlar
13
Excel Vers. ve Dili
2016 Türkçe
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 s2.dosya.tc
 
Formülle mi? Kodla mı?
Tablonuz çok mu büyük?
Aynı sayfaya mı farklı sayfaya mı?
 
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.
 
Tabloların hepsi aynı büyüklükte mi? Yani A3:E7 aralığında mı?
 
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.

Kod: 
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
 
Ziynettin beyin kodları sorunu çözecektir, belki son mesajınıza göre düzenlemeye ihtiyaç olabilir.
 
Ziynettin' Alıntı:
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.

Kod: 
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
Genişletmek için tıkla ...
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?
 
Tablo [A3:O?] aralığı olarak, listeleme R2 olacak şekilde.

Kod: 
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
 
Ziynettin' Alıntı:
Tablo [A3:O?] aralığı olarak, listeleme R2 olacak şekilde.

Kod: 
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
Genişletmek için tıkla ...
Hocam çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst