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

[kaan2812]

Merhaba,

5000 kayıtlık bir liste var, aynı kısıye aıt birden fazla kayıt var. Benım amacım bu kayıtları teklemek, yani aynı okulda birden fazla aynı kısıye aıt kayıt varsa en son aya aıt kayıtı alsın, diğer kontrol ayları alanında ise o kısıye aıt sadece diğer ayları yazsın.
dosya ekte

kayıt cok fazla oldugundan yardımlarınız lutfen

 

[İhsan Tank]

Merhaba,

5000 kayıtlık bir liste var, aynı kısıye aıt birden fazla kayıt var. Benım amacım bu kayıtları teklemek, yani aynı okulda birden fazla aynı kısıye aıt kayıt varsa en son aya aıt kayıtı alsın, diğer kontrol ayları alanında ise o kısıye aıt sadece diğer ayları yazsın.
dosya ekte

kayıt cok fazla oldugundan yardımlarınız lutfen

dosyanızda öğrenci no mu tek olacak

 

[kaan2812]

evet ogrencı no tek olacak

 

[Orion1]

Şimdi öğrenci döneminde vba kodu kullanacam worksheet fonksiyonu max kullanacam ama O sütunda bazı hücreler tarıh bazı hücreler ise metin girilmiş.,
Yani 2sinden biri olsa idi ben ona göre davrancaktım.Oradaki değerleri ya tarih formatında yapın(Bu tercih sebebidir) yada metin yapın.
Ben kod ile onu yine sorgularım ama tarih olursa iyi olacak.İşlem dahada hızlanır.
Siz zira çok kayıt olduğunu söylediniz.

 

[kaan2812]

tarıh alan formatı degıstı

tarıh alan formatı degıstı
yardımlarınız ıcın tesekkurler

 

[kaan2812]

dosya ektedir tesekkurler

 

[Orion1]

tarıh alan formatı degıstı
yardımlarınız ıcın tesekkurler

Hiç bir şey değişmemiş.
H sütunundaki verlerin içinden en büyük tarihe ait ay alınmayacakmı?
Orada yine bazı hücreler tarih bazıları ise metin.
Değişen bir şey yok.

 

[kaan2812]

dosyayı duzelttım hocam
yardımın ıcın cok saol

 

[Orion1]

dosyayı duzelttım hocam
yardımın ıcın cok saol

Artık ilgilenmiyorum.
Başka arkadaşlardan yardım alınız.

 

[kaan2812]

yukarıdakı acıklamanızdan benım sorunumu anladınız.
tekrar bır sans versenız

 

[Orion1]

yukarıdakı acıklamanızdan benım sorunumu anladınız.
tekrar bır sans versenız

Böyle olunca sanki bir soruyu cevaplandırmak için yalvarıyormuş gibi oluyor.
Ben bu durumlarda soğuyorum,sorudan.Cevap vermek istemiyorum.
Neyse bakalım ne yapabilecez.

 

[Orion1]

Öğrenci dönemi kısmına sanırım en son ay yazılacak.
birden fazla dönem olduğunda diğer dönemler ne olacak?

 

[kaan2812]

evet en son ay yazılacak.
dıger donemler ozet tablodakı onceki dönem1-2 ye yazılacak

 

[Orion1]

evet en son ay yazılacak.
dıger donemler ozet tablodakı onceki dönem1-2 ye yazılacak

peki 3 tane önceki dönem varsa ne olacak.

 

[kaan2812]

ekte yer alan tabloda kısı bası 3 donem var. bır tanesı "ogrencı donemı" alanına kalan 2 ıse "oncekı donem1" ve "oncekı donem2" yazıılması planlanmakta

 

[kaan2812]

gunaydın,
bır gelısme var mı?

 

[Orion1]

Dosyanız ektedir.

Option Explicit
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:H" & sat).Value
ReDim myarr(1 To 8, 1 To sat)
For i = 1 To UBound(a, 1)
    If Not IsDate(a(i, 8)) Then
        MsgBox "H" & 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 7
            myarr(k, n) = a(i, k)
        Next
    End If
    myarr(8, z.Item(deg1)) = myarr(8, z.Item(deg1)) & a(i, 8) & "-"
Next
Sheets("Sheet2").Select
ReDim Preserve myarr(1 To 8, 1 To n)
Range("A2").Resize(n, 8) = Application.Transpose(myarr)
sat = Cells(65536, "H").End(xlUp).Row
If sat > 1 Then
    For i = 2 To sat
        sut = 8
        deg1 = Left(Cells(i, "H").Value, Len(Cells(i, "H").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 > 8 Then Call sirala(Range(Cells(i, 8), Cells(i, sut)), Range("H" & i))

    Next i
End If
Application.ScreenUpdating = True
End Sub
Option Explicit

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]

Merhaba,

18.07.2010 tarihinde soruma cevap almıstım. Ancak makrom bıraz zayıf oldugundan ana lısteye bırkactane daha sütun eklemem gerekıyor. Sütun ekledım ve makroda da kendımce bazı degısıklıkler yapayım dedım ama olmadı. ektekı dosyada ılava sütunları yesıl ıle gosterdım

 

[Orion1]

Merhaba,

18.07.2010 tarihinde soruma cevap almıstım. Ancak makrom bıraz zayıf oldugundan ana lısteye bırkactane daha sütun eklemem gerekıyor. Sütun ekledım ve makroda da kendımce bazı degısıklıkler yapayım dedım ama olmadı. ektekı dosyada ılava sütunları yesıl ıle gosterdım

Bu tür konuları baştan iyi tasarlamak lazım.Esnek düşünmek lazım.10 kere düşünüp bir kerede kodu yazmak lazım.Aksi takdirde bu tür sorunlarla karşılaşırsınız.VBA excel sayfasına benzemez.Excelde ne yapıyorsunuz?Hemncecik bir sütun ekliyorsunuz elle giriyorsunuz verileri veya siliyorsunuz.Ama vba da böyle değil durum.Sonradan değişliklik yapmak çok zordur.Hatta yeniden kod yazamak bazen dahada kolaydır diyebilirim.
Dosyayı ekledim.
Bakın olmuşmu?

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)
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]

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)"