verileri süzerek başka bir sayfaya aktarma

[gezgin-49]

Arkadaşlar ekte gönderdiğim dosyada Data sayfasında yukarıdan aşağıya doğru yazılan dosya numaralarından elde kısmında 1 yazıyorsa devir listesinde "A" sütununa yıl adını örneğin 1985/ gibi,
/ işaretinden sonraki dosya numarasını da "B" sütunu ile "U" sütunları arasına yazmak istiyorum, veri sayısı 3500 civarında olduğundan ekte küçük bir dosya gönderiyorum, bu konudaki yardımlarınızdan dolayı şimdiden teşekkürlerimi iletiyor, saygılar sunuyorum.

 

[halit3]

Arkadaşlar ekte gönderdiğim dosyada Data sayfasında yukarıdan aşağıya doğru yazılan dosya numaralarından elde kısmında 1 yazıyorsa devir listesinde "A" sütununa yıl adını örneğin 1985/ gibi,
/ işaretinden sonraki dosya numarasını da "B" sütunu ile "U" sütunları arasına yazmak istiyorum, veri sayısı 3500 civarında olduğundan ekte küçük bir dosya gönderiyorum, bu konudaki yardımlarınızdan dolayı şimdiden teşekkürlerimi iletiyor, saygılar sunuyorum.

Önce formül sayfasındaki düğmeye tıklıyacaksanız sonrada
devir listesi sayfasındaki düğmeye tıklıyacaksınız.

 

[Ömer]

Merhaba,

Alternatif olsun. Module kopyalarak çalıştırınız..

Sub Listele()
Dim c As Range, sat As Long, ilkadres As Variant, Sd As Worksheet
Dim i As Long, sut As Integer, son As Long
Set Sd = Sheets("Data")
Application.ScreenUpdating = False
Sheets("devir listesi").Select
Range("A2:IV65536").ClearContents
sat = 1
With Sd.Range("G:G")
    Set c = .Find(1, LookIn:=xlValues)
    If Not c Is Nothing Then
        ilkadres = c.Address
        Do
            sat = sat + 1
            Cells(sat, "A") = Sd.Cells(c.Row, "B")
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> ilkadres
    End If
End With
son = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To son
    Cells(i, "IV") = Split(Cells(i, "A"), "/")(0)
Next i
For i = 2 To son
sut = 1
    With Range("IV:IV")
        Set c = .Find(Left(Cells(i, "A"), 4), LookIn:=xlValues)
        If Not c Is Nothing Then
            ilkadres = c.Address
            Do
                sut = sut + 1
                Cells(i, sut) = Split(Cells(c.Row, "A"), "/")(1)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> ilkadres
        End If
    End With
Next i
Range("IV2:IV" & son).Copy Range("A2") 
On Error Resume Next: ActiveSheet.ShowAllData
Range("A1:A" & son).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    For i = son To 2 Step -1
        If Rows(i).Hidden = True Then
            Rows(i).Delete Shift:=xlUp
        End If
    Next i
Range("A:A").HorizontalAlignment = xlCenter
Application.ScreenUpdating = True
End Sub

.

 

[gezgin-49]

Sayın üstadlarım Halit3 ve Ömer, sizler bir harikasınız, Allah sizlerden razı olsun tam istediğim gibi olmuş, ileride bir tıkanma olursa yardımlarınızı tekrar beklerim, saygılar sunuyorum.

 

[halit3]

Sayın üstadlarım Halit3 ve Ömer, sizler bir harikasınız, Allah sizlerden razı olsun tam istediğim gibi olmuş, ileride bir tıkanma olursa yardımlarınızı tekrar beklerim, saygılar sunuyorum.

iyi çalışmalar

 

[halit3]

buda formül sayfasız olarak hazırlanmış kod.

Sub AKTAR()
Range("A2:U36").ClearContents
aranan = ""
sat = 2
For r = 2 To Worksheets("data").Cells(Rows.Count, "B").End(3).Row
aranan1 = Mid(Sheets("data").Cells(r, 2).Value, 1, 4)
If aranan <> aranan1 Then
J = 1
If Sheets("data").Cells(r, 2).Value <> "" Then
Sheets("devir listesi").Cells(sat, 1).Value = aranan1
For i = r To Worksheets("data").Cells(Rows.Count, "B").End(3).Row
If Sheets("data").Cells(i, 7).Value = 1 Then
aranan2 = Mid(Sheets("data").Cells(i, 2).Value, 1, 4)
If aranan2 = aranan1 Then
J = J + 1
Sheets("devir listesi").Cells(sat, J).Value = Mid(Sheets("data").Cells(i, 2).Value, 6, Len(Sheets("data").Cells(i, 2).Value))
End If
End If
Next i
sat = sat + 1
End If
End If
aranan = Mid(Sheets("data").Cells(r, 2).Value, 1, 4)
Next r
End Sub

 

[gezgin-49]

Sayın üstadım Halit3 ufak bir sorun var, dosyayı yeniden gönderiyorum. daha önce de söylemiştim veriler çok fazla 3500 civarında, bu nedenle aktar butonuna basınca devir listesi sayfasında renkli olan kısımların çok dışına taşıyor, istediğim eğer aynı tarihten fazla sayıda veri varsa örneğin 1995 yılında 150 tane veri olduğunu düşünürsek B:U sütunu arasında bu verileri sırasıyla yazdıktan sonra fazla kalan kısmı varsa bir alt satırda devam etsin, yine yetmezse sonraki alt satıra yazarak gitmesini istiyorum, ilginizden dolayı şimdiden teşekkür ederim.

 

[halit3]

Sayın üstadım Halit3 ufak bir sorun var, dosyayı yeniden gönderiyorum. daha önce de söylemiştim veriler çok fazla 3500 civarında, bu nedenle aktar butonuna basınca devir listesi sayfasında renkli olan kısımların çok dışına taşıyor, istediğim eğer aynı tarihten fazla sayıda veri varsa örneğin 1995 yılında 150 tane veri olduğunu düşünürsek B:U sütunu arasında bu verileri sırasıyla yazdıktan sonra fazla kalan kısmı varsa bir alt satırda devam etsin, yine yetmezse sonraki alt satıra yazarak gitmesini istiyorum, ilginizden dolayı şimdiden teşekkür ederim.

ekli dosyanızı kontrol ediniz.

 

[gezgin-49]

Allah razı olsun sayın üstadım, ellerinize, emeğinize sağlık şimdi tam istediğim gibi olmuş, ama yıllar kısmı aynı olanlarda aktar butonuna bastığımda tek olabilir mi, misalen 2009 yılından 10 sütun var, en üsttekinde 2009 yazsın diğer dokuz sütunda yıl kısmı boş bırakılsın, tüm yıl kısımları böyle olabilir mi, olmazsa da önemi yok, tekrar teşekkür ederim.

 

[halit3]

Allah razı olsun sayın üstadım, ellerinize, emeğinize sağlık şimdi tam istediğim gibi olmuş, ama yıllar kısmı aynı olanlarda aktar butonuna bastığımda tek olabilir mi, misalen 2009 yılından 10 sütun var, en üsttekinde 2009 yazsın diğer dokuz sütunda yıl kısmı boş bırakılsın, tüm yıl kısımları böyle olabilir mi, olmazsa da önemi yok, tekrar teşekkür ederim.

kodların içinde aşağıdaki kırmızı olan yerleri siliniz.

If J = 22 Then
sat = sat + 1
[COLOR=red]Sheets("devir listesi").Cells(sat, 1).Value = aranan1
[/COLOR]J = 2
End If

 

[gezgin-49]

Sayın üstadım bu da tamam ama ben yeni veri girdiğimde (2010 yılına ait verileri girdiğimde) bunları hesaplamıyor, bu konuya da bir el atarsanız memnun olurum. saygılar

 

[halit3]

Sayın üstadım bu da tamam ama ben yeni veri girdiğimde (2010 yılına ait verileri girdiğimde) bunları hesaplamıyor, bu konuya da bir el atarsanız memnun olurum. saygılar

neden hesaplamıyor bilmiyorum 2010 yılına ait veri girin ve girmiş olduğunuz veriye ait dosyayı gönderin bakalım.

 

[gezgin-49]

pardon ben formül sayfasında düzenle butonuna basmadan aktar butonuna bastığımdan dolayı 2010 verileri gelmemişti, şimdi öyle deneyince hata olmadığını farkettim,
Sayın üstadım Allah sizden razı olsun, Allah sizi darda bırakmasın, sizin şahsınızda ilgilenen tüm arkadaşlara da teşekkürlerimi bir borç biliyor ve arz ediyorum, Çalışmalarınızda başarılar dilerim. Muş' tan bir emriniz olursa, başım üstüne, Muş' tan Ankara' ya kucak dolusu sevgiler,

 

[halit3]

pardon ben formül sayfasında düzenle butonuna basmadan aktar butonuna bastığımdan dolayı 2010 verileri gelmemişti, şimdi öyle deneyince hata olmadığını farkettim,
Sayın üstadım Allah sizden razı olsun, Allah sizi darda bırakmasın, sizin şahsınızda ilgilenen tüm arkadaşlara da teşekkürlerimi bir borç biliyor ve arz ediyorum, Çalışmalarınızda başarılar dilerim. Muş' tan bir emriniz olursa, başım üstüne, Muş' tan Ankara' ya kucak dolusu sevgiler,

Teşekkürlür iyi çalışmalar.