• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Tarihe Göre Verileri Gruplama.

Aylarına göre gruplandırır.
Kod: 
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
 
çıtır' Alıntı:
Aylarına göre gruplandırır.
Kod: 
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
Genişletmek için tıkla ...

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ü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.
 
çıtır' Alıntı:
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.
Genişletmek için tıkla ...
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.:)
 
çıtır' Alıntı:
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.
Genişletmek için tıkla ...

Ç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
 
Son düzenleme:
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.
 
çıtır' Alıntı:
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.
Genişletmek için tıkla ...

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ı.:)
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst