sütun ve satırı eşleştir

[Orion1]

Merhaba,

dosya calısıyor ancak kendı bılgılerımı kopyalayınca asagıdakı satırda hata var dıyor

"Range("A2").Resize(n, 15) = Application.Transpose(myarr)"

Kendi bilgileriniz 255 karakteri geçen varsa hata verir.Excelde 2003 ve alt versiyonlarda 255 karakter sınırı vardır.
Resize komutu bu sınır aşıldığında hata veriyor.
Resize yerine dizi içinde döngüye girip verileri attım.Şimdi hata vermez.
Bunun dezavantajı büyük veri yığınlarında resize komutu kadar hızlı çalışmaz.Ama küçük alanlarda hiç anlaşılmaz bile.
Dosya ektedir.

Option Base 1

Sub donem_59()
Dim myarr(), sat As Long, i As Long, sut As Long, z As Object
Dim a(), n As Long, deg1 As String, deg2 As String, k As Byte
Dim t
Sheets("Sheet1").Select
Application.ScreenUpdating = False
sat = Cells(65536, "A").End(xlUp).Row
If sat < 2 Then
    Application.ScreenUpdating = True
    Exit Sub
End If
Sheets("Sheet2").Range("A2:IV65536").ClearContents
Set z = CreateObject("Scripting.Dictionary")
a = Range("A2:O" & sat).Value
ReDim myarr(1 To 15, 1 To sat)
For i = 1 To UBound(a, 1)
    If Not IsDate(a(i, 15)) Then
        MsgBox "O" & i + 1 & vbLf & " Hücredeki tarih" & vbLf & _
        "Geçerli bir tarih değil." & vbLf & "İşlem İptal Edildi" & vbLf _
        & "İlgili hücreye geçerli bir tarih girip tekrar deneyiniz.", vbCritical, "UYARI"
        Application.ScreenUpdating = True
        Exit Sub
    End If
    deg1 = a(i, 1) & "-" & a(i, 2)
    If Not z.exists(deg1) Then
        n = n + 1
        z.Add deg1, n
        For k = 1 To 14
            myarr(k, n) = a(i, k)
        Next
    End If
    myarr(15, z.Item(deg1)) = myarr(15, z.Item(deg1)) & a(i, 15) & "-"
Next
Sheets("Sheet2").Select
ReDim Preserve myarr(1 To 15, 1 To n)
Application.ScreenUpdating = False
For i = 1 To UBound(myarr, 2)
    For k = 1 To UBound(myarr, 1)
        Cells(i + 1, k).Value = myarr(k, i)
    Next k
Next i
'Range("A2").Resize(n, 15) = Application.Transpose(myarr)
sat = Cells(65536, "O").End(xlUp).Row
If sat > 1 Then
    For i = 2 To sat
        sut = 15
        deg1 = Left(Cells(i, "O").Value, Len(Cells(i, "O").Value) - 1)
        t = Split(deg1, "-")
        For k = LBound(t) To UBound(t)
            Cells(i, sut).Value = CDate(t(k))
            Cells(i, sut).NumberFormat = "mmmm yyyy"
            sut = sut + 1
        Next k
        If sut > 15 Then Call sirala(Range(Cells(i, 15), Cells(i, sut)), Range("O" & i))
    Next i
    Application.ScreenUpdating = True
    MsgBox "işlem tamamdır." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
Application.ScreenUpdating = True
End Sub
Sub sirala(ByVal alan As Range, ByVal ilk As Range)
    alan.Sort Key1:=ilk, Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
        DataOption1:=xlSortNormal
End Sub

 

[kaan2812]

Hocam bılıyon benı vurucan ama sımdı farkettım, örnek olarak ektekı dosyada camlıca okulundakı hem "ahmet"e hemde "cenk"e ait son ayın kaydının yansıması gerekıyordu. Gercekten sımdı fark ettım :-(

 

[Orion1]

Hocam bılıyon benı vurucan ama sımdı farkettım, örnek olarak ektekı dosyada camlıca okulundakı hem "ahmet"e hemde "cenk"e ait son ayın kaydının yansıması gerekıyordu. Gercekten sımdı fark ettım :-(

Estafurullah.
Hata bizde imiş.
Dosyayı 21 nolu mesajdan indirebilirsininiz.
Aşağıda ki gibiydi.2nci elemandan başlıyordu.Kırmızı renge dikkat.

For i = [B][COLOR="Red"]2[/COLOR][/B] To UBound(myarr, 2)
    For k = 1 To UBound(myarr, 1)
        Cells(i , k).Value = myarr(k, i)
    Next k
Next i

Böyle yapınca düzeldi

For i = [B][COLOR="red"]1[/COLOR][/B] To UBound(myarr, 2)
    For k = 1 To UBound(myarr, 1)
        Cells(i + 1, k).Value = myarr(k, i)
    Next k
Next i