Tarihe Göre Verileri Gruplama.

[sinan05]

Önçeki konunuzu bilmiyorum.Onun için daha fazla yardımcı olamayaçağım.Üzgünüm.

Anladım Hocam teşekkür ederim.

 

[çıtır]

Anladım Hocam teşekkür ederim.

Rica ederim.Dönüş yaptığınız için teşekkür ederim.

 

[sinan05]

Rica ederim.Dönüş yaptığınız için teşekkür ederim.

Hocam asıl ben çok çok teşekkür ederim. Her zaman duacınızım. Bugün çok sık boğaz ettim sizi kusura bakmayın sağolun anlayışınız için.

 

[çıtır]

Aylarına göre gruplandırır.

Sub SIRALAMA2()
Dim s1 As Worksheet: Dim i As Integer
Set s1 = Sheets("Sayfa1"): Set wf = WorksheetFunction
Application.ScreenUpdating = False
son = s1.Cells(65355, "A").End(3).Row
s1.Range("A4:U" & son).MergeCells = False
s1.Range("A4:U" & son).Sort Range("A4"), xlAscending
son1 = s1.Cells(65355, "A").End(3).Row
If son > son1 Then
Rows(son1 + 1 & ":" & son).Delete Shift:=xlUp
End If
For i = son To 4 Step -1
s1.Range(s1.Cells(i, "C"), s1.Cells(i, "T")).MergeCells = True
If wf.IsNumber(s1.Range("A" & i)) * 1 And wf.IsNumber(s1.Range("A" & i + 1)) * 1 Then
If Month(s1.Range("A" & i)) * 1 < Month(s1.Range("A" & i + 1)) * 1 Then
s1.Rows(i + 1).Insert Shift:=xlDown
s1.Cells(i + 1, "B") = "............"
s1.Range(s1.Cells(i + 1, "C"), s1.Cells(i + 1, "T")).MergeCells = True
i = i + 1
End If
End If
Next
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAM", vbInformation
End Sub

 

[sinan05]

Aylarına göre gruplandırır.

Sub SIRALAMA2()
Dim s1 As Worksheet: Dim i As Integer
Set s1 = Sheets("Sayfa1"): Set wf = WorksheetFunction
Application.ScreenUpdating = False
son = s1.Cells(65355, "A").End(3).Row
s1.Range("A4:U" & son).MergeCells = False
s1.Range("A4:U" & son).Sort Range("A4"), xlAscending
son1 = s1.Cells(65355, "A").End(3).Row
If son > son1 Then
Rows(son1 + 1 & ":" & son).Delete Shift:=xlUp
End If
For i = son To 4 Step -1
s1.Range(s1.Cells(i, "C"), s1.Cells(i, "T")).MergeCells = True
If wf.IsNumber(s1.Range("A" & i)) * 1 And wf.IsNumber(s1.Range("A" & i + 1)) * 1 Then
If Month(s1.Range("A" & i)) * 1 < Month(s1.Range("A" & i + 1)) * 1 Then
s1.Rows(i + 1).Insert Shift:=xlDown
s1.Cells(i + 1, "B") = "............"
s1.Range(s1.Cells(i + 1, "C"), s1.Cells(i + 1, "T")).MergeCells = True
i = i + 1
End If
End If
Next
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAM", vbInformation
End Sub

Ah ÇITIR Hocam siz müstesna ve iyilik sever bir insansınız yine sevindirdiniz beni. Bu makroda çok güzel oldu sağolun gerçekten teşekkürler eksik olmayın İNŞALLAH tez vakit ALLAH CC. de sizi sevindirsin

 

[çıtır]

Tüm dua ve güzel dilekleriniz için amin.Aynı güzelliklerin sizede nasip olmasını dilerim.Dönüş yaptığınız için teşekkür ederim.

 

[sinan05]

Tüm dua ve güzel dilekleriniz için amin.Aynı güzelliklerin sizede nasip olmasını dilerim.Dönüş yaptığınız için teşekkür ederim.

Sağolun Amin İNŞALLAH Hocam. Dönüşler için benim teşekkür etmem lazım zira sizin her dönüşünüz dolu dolu oluyor, mesajlarınızı gözler oldum.

 

[sinan05]

Tüm dua ve güzel dilekleriniz için amin.Aynı güzelliklerin sizede nasip olmasını dilerim.Dönüş yaptığınız için teşekkür ederim.

ÇITIR Hocam rahatsız ettiğim için çok üzgünüm kusura bakmayın ama sabahtan beri kodlarla uğraşıyorum başım ağrıdı mecbur kaldım. Aşağıdaki makroda ana sayfadan kayıtlar sayfasına veri kopyalıyorum ama biçimleride kopyalıyor. S1.Range("A" & Satir & ":U" & Satir).Value = S2.Range("A" & Bul.Row & ":U" & Bul.Row).Value bu kodu denedim olmadı sadece değerleri kopyalamak istiyorum amacım ana syfa daki sadece dolu olan satırları kayıtlar sayfasındaki dolu olan en son satırın altına yapıştırmak. Müsait bir zamanınızda yardımcı olabilirseniz çok sevinirim.
NOT: Hocam hücreleri çözünce pastavalus le oluyor ama hücreleri çöz ve tekrar birleştir kodu nasıl yazılıyor.

Sub KAYİT2()
Application.ScreenUpdating = False
Dim tarih1 As Date, tarih2 As Date, xtarih As Date
Dim S1 As Worksheet, S2 As Worksheet, Defterler(), Son As Long, Satır As Long
Set S1 = Sheets("KAYITLAR")
Defterler = Array("ANA SAYFA")
Satır = 4
For Each defter In Defterler
Set S2 = Sheets(defter)
Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
Son1 = Sheets("KAYITLAR").[a65536].End(3).Row + 1
For x = 4 To Son
If S2.Cells(x, "B").Value <> "" Then
S2.Range("A" & x & ":U" & x).copy
Sheets("KAYITLAR").Cells(Son1, 1).PasteSpecial xlPasteAll
Son1 = Son1 + 1
End If
Next x
Next
Application.ScreenUpdating = True
End Sub

 

[çıtır]

Yapmak istediğiniz işlem Kayıtlar sayfasındaki belirli alanda bulunan dolu satırları Anasayfa ya almak ise neden kopylama ile uğraşıyorsunuz? Verileri çekiniz.İşlem kolaylaşır daha hızlı olur.Kopyalamaya neden gerek duydunuz?Anlayabildiğim B hücresi dolu ise A:U kopyalanarak taşınıyor.Aynı işlemi B dolu ise A:U verilerini çekerek alınız.Kullandığınız Tanımlamaları Dizi ve döngüleri anlamada zorlanıyorum.Sadece yöntem önermek için yazdım.Tabii konuyu bildiğiniz için doğrusunu siz bilirsiniz.

 

[sinan05]

Yapmak istediğiniz işlem Kayıtlar sayfasındaki belirli alanda bulunan dolu satırları Anasayfa ya almak ise neden kopylama ile uğraşıyorsunuz? Verileri çekiniz.İşlem kolaylaşır daha hızlı olur.Kopyalamaya neden gerek duydunuz?Anlayabildiğim B hücresi dolu ise A:U kopyalanarak taşınıyor.Aynı işlemi B dolu ise A:U verilerini çekerek alınız.Kullandığınız Tanımlamaları Dizi ve döngüleri anlamada zorlanıyorum.Sadece yöntem önermek için yazdım.Tabii konuyu bildiğiniz için doğrusunu siz bilirsiniz.

Hocam hayırlı günler. Daha iyi açıklamak ve görmeniz için dosyamı buraya ekliyorum önce açıklama notunu okursanız sevinirim. Hoacam şunuda belirteyim sizden rica ettiğim şeyleri çok uzun saatler ve günlerce uğraşıp işin içinden çıkamayınca size rica ediyorum veya konu açıyorum. yani af buyrun öyle keyfi isteklerde kafamı geleni size yazıp rahatsız etmek istemem asla çok sağolun dönüşünüz için.
https://www.dosya.tc/server20/yr1q5j/KASA_24.06.2019.rar.html
Hocam ilaveten senin makroyla benimkini birleştirmeyi başardım, geriye yeni kayıt etme sorunu kaldı.