yatay veriyi dikey aktarma

[peleryn]

Herkese Merhabalar;


Aktarma konusu arşivde belki de en çok veri bulunan konulardan birisi biliyorum.Ancak ben arşivle işin içinden çıkamadım.

Önce e2:j aralığındaki veriler diğer sayfanın ilk satırında tekrar etmeyen başlıklar haline getirilecek.Daha sonra bu başlıklara karşılık gelen isimler bu başlıkların altına listelenerek aktarım tamamlanacak.Gerekli açıklamayı dosya içerisinde yaptım.

İlgilenecek olanlara şimdiden çok teşekkür ederim.

 

[Ömer]

Merhaba,

Moduller sayfasının kod bölümüne kopyalayınız.

Private Sub Worksheet_Activate()
 
Dim Sd As Worksheet, son As Long, i As Integer, sons As Long, j As Integer
Dim sat As Long, hucre As Range
 
Set Sd = Sheets("DATA")
son = Sd.Cells(Rows.Count, "B").End(xlUp).Row
 
Application.ScreenUpdating = False
 
Cells.Clear
Range("A1") = "hayalibaşlık"
 
For i = 5 To 10
    sond = Cells(Rows.Count, "A").End(xlUp).Row + 1
    Sd.Range(Sd.Cells(2, i), Sd.Cells(son, i)).Copy Range("A" & sond)
Next i
 
[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
[A:A].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), _
Unique:=True
 
[B:B].Cut [A1]
 
sons = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:A" & sons).Copy
[A1].PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=True
 
Range("A2:A" & sons).Clear
 
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
    sat = 2
    With Sd.Range("E2:J" & son)
        Set c = .Find(Cells(1, j), LookIn:=xlValues)
        If Not c Is Nothing Then
            ilkadres = c.Address
            Do
                Cells(sat, j) = Sd.Range("B" & c.Row)
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> ilkadres
        End If
    End With
Next j
 
Cells.EntireColumn.AutoFit: [A2].Select
Application.ScreenUpdating = True
End Sub

 

[usubaykan]

Herkese Merhabalar;


Aktarma konusu arşivde belki de en çok veri bulunan konulardan birisi biliyorum.Ancak ben arşivle işin içinden çıkamadım.

Önce e2:j aralığındaki veriler diğer sayfanın ilk satırında tekrar etmeyen başlıklar haline getirilecek.Daha sonra bu başlıklara karşılık gelen isimler bu başlıkların altına listelenerek aktarım tamamlanacak.Gerekli açıklamayı dosya içerisinde yaptım.

İlgilenecek olanlara şimdiden çok teşekkür ederim.

Merhaba;

Alternatif olarak sayfanızın kod bölümüne aşağıdaki kodu uygulayınız.

Private Sub Worksheet_Activate()
Dim Satırlar As Range, Sdat As Worksheet, Smod As Worksheet
Dim Son_Sütun As Byte, Say As Double
Dim U As Long, S As Byte, BUL As Range, ADRES As String, Son_Satır As Long
Set Sdat = Sheets("DATA")
Set Smod = Sheets("MODULLER")
Application.ScreenUpdating = False
Smod.Cells.ClearContents
Son_Sütun = Smod.Range("IV1").End(1).Column
For Each Satırlar In Sdat.Range("E2:J" & Sdat.Range("A65536").End(3).Row)
    Say = WorksheetFunction.CountIf(Smod.Rows("1:1"), Satırlar)
    If Say = 0 And Satırlar <> Empty Then
        Smod.Cells(1, Son_Sütun) = Satırlar
        Son_Sütun = Son_Sütun + 1
            For S = Smod.Range("IV1").End(1).Column To Smod.Range("IV1").End(1).Column
                    Set BUL = Sdat.Range("E2:J65536").Find(What:=Smod.Cells(1, S), LookAt:=xlWhole)
                    If Not BUL Is Nothing Then
                        ADRES = BUL.Address
                        Son_Satır = Smod.Cells(1, S).End(3).Row
                        Do
                        Son_Satır = Son_Satır + 1
                        Smod.Cells(Son_Satır, S) = Sdat.Cells(BUL.Row, "B")
                        Set BUL = Sdat.Range("E2:J65536").FindNext(BUL)
                        Loop While Not BUL Is Nothing And ADRES <> BUL.Address
                    End If
                    Smod.Cells(2, S).Sort Key1:=Smod.Cells(2, S), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                    DataOption1:=xlSortTextAsNumbers
            Next
    End If
Next
MsgBox "İşleminiz tamamlanmıştır.", vbInformation, "Sn: " & Application.UserName
Application.ScreenUpdating = True
End Sub

 

[Korhan Ayhan]

Selamlar,

İki cevap gelmiş. Bende kod hazırlamıştım. Alternatif olması açısından incelermisiniz.

Option Explicit
 
Private Sub Worksheet_Activate()
    Dim S1 As Worksheet, S2 As Worksheet, Hücre As Range, Satır As Long
    Dim Sütun As Byte, Bul As Range, Adres As String
    
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("MODULLER")
    Satır = 1
    
    Application.ScreenUpdating = False
    
    With S2
        .Cells.Clear
        
        For Each Hücre In S1.Range("E2:J65536").SpecialCells(xlCellTypeConstants, 2)
            If WorksheetFunction.CountIf(S2.Range("IV:IV"), Hücre.Value) = 0 Then
                .Cells(Satır, 256) = Hücre.Value
                Satır = Satır + 1
            End If
        Next
        
        .Columns("IV:IV").Sort Key1:=.Range("IV1"), Order1:=xlAscending
        .Range("IV1:IV" & .Range("IV65536").End(3).Row).Copy
        .Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        .Columns("IV:IV").Clear
        .Range("A1").Select
        
        For Sütun = 1 To .Range("IV1").End(1).Column
            Set Bul = S1.Range("E:J").Find(.Cells(1, Sütun), LookAt:=xlWhole)
            If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                Satır = .Cells(65536, Sütun).End(3).Row + 1
                .Cells(Satır, Sütun) = S1.Cells(Bul.Row, "B")
            Set Bul = S1.Range("E:J").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        Next
        
        .Range(.Cells(1, "A"), Cells(1, .Range("IV1").End(1).Column)).Font.Bold = True
        .Range(.Cells(1, "A"), Cells(1, .Range("IV1").End(1).Column)).Font.ColorIndex = 5
        .Cells.EntireColumn.AutoFit
    End With
 
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = False
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[peleryn]

Ömer Hocam,Sn usubaykan ve Sn.Korhan Hocam;

Birbirinden güzel cevaplarınız için teşekkürler.Çok uğraşmıştım ama bir türlü üstesinden gelememiştim.Farklı üç cevabı da inceleyince gerçekten boyumu hayli aşan bir konu olduğu iyice belli olmuş oldu.

Bu çözümlerden hem başlık satırlarını soldan sağa hem de listeleri yukarıdan aşağıya alfabetik sırayla dizen ve sonuçta da sütunlara autofit işlemi uygulayan kod bloğunu dosyama adapte ediyorum.İlgileriniz için tekrar ayrı ayrı teşekkür ediyorum.