Aynı tarihte aynı ildeki verileri diğer sayfaya aktarmak

[ASLAN7410]

Merhaba hayırlı akşamlar.

Excelde bir veri sayfam var, Sayfa1'de B sütunundaki tarihleri baz alarak A sütunundaki bilgiye göre Sayfa2'ye aralıklarla aktarmak istiyorum.

Kopyala yapıştır ile uğraşıyorum ama veri çok olduğu için çok zamanımı alıyor. Yardımcı olacak arkadaşlara şimdiden teşekkür ederim.

 

[Ziynettin]

Merhaba,

Dosyanız ekte.

Option Explicit
Sub Baslık_Ekle()
Dim a(), b, d As Object, Krt As Variant
Dim i As Long, Sat As Long, k As Variant
Dim S1 As Worksheet, S2 As Worksheet
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")

    a = S1.Range("A2:E" & S1.[A65000].End(xlUp).Row)
    Set d = CreateObject("scripting.dictionary")

        For i = 1 To UBound(a)
            Krt = a(i, 1) & "|" & a(i, 2)
            d(Krt) = d(Krt) & i & ","
        Next i
  
    Sat = 1
    S2.Cells(Sat, "A").Resize(Rows.Count, 5).Clear
        For Each k In d.keys
            S2.Cells(Sat, "A") = Split(k, "|")(1)
            S2.Cells(Sat, "A").Resize(, 5).Merge
            S2.Cells(Sat + 1, "A").Resize(, 5) = Array(S1.[A1], S1.[B1], S1.[C1], S1.[D1], S1.[E1])
            b = Application.Index(a, Application.Transpose(Split(d.Item(k), ",")), Array(1, 2, 3, 4, 5))
            S2.Cells(Sat + 2, "A").Resize(UBound(b) - 1, UBound(b, 2)) = b
            S2.Cells(Sat, "A").Resize(UBound(b) + 1, UBound(b, 2)).Borders.Color = 1
            Sat = Sat + UBound(b) + 2
        Next k
         
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "İşlem tamam", vbInformation
End Sub

 

[ASLAN7410]

Sayın Ziynettin Bey ellerinize sağlık Allah razı olsun, tam istediğim gibi oldu, çok teşekkür ederim.

Aynı evrak üzerinde küçük farklı bir şey istiyorum, yardımcı olur musunuz?

Örneği ekledim, yapmak istediğim görselliği ayırmak için Sayfa1'deki verileri Sayfa2'ye aktarıp atlayarak renklendirmek istiyorum,
veri çok olduğu için yazdırdığımda çok sayfa çıkıyor, bu yüzden sayfa üzerinde kontrol yapmak istiyorum.

 

[Ziynettin]

Sayın Ziynettin Bey ellerinize sağlık Allah razı olsun, tam istediğim gibi oldu, çok teşekkür ederim.

Aynı evrak üzerinde küçük farklı bir şey istiyorum, yardımcı olur musunuz?

Örneği ekledim, yapmak istediğim görselliği ayırmak için Sayfa1'deki verileri Sayfa2'ye aktarıp atlayarak renklendirmek istiyorum,
veri çok olduğu için yazdırdığımda çok sayfa çıkıyor, bu yüzden sayfa üzerinde kontrol yapmak istiyorum.

Option Explicit
Sub Aktar_Renk()
Dim Son As Long, Say As Long, Krt As Variant
Dim a(), b(), d As Object, i As Long, y As Byte
Dim S1 As Worksheet, S2 As Worksheet
Dim x As Range, p As Byte, Renk
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set d = CreateObject("Scripting.Dictionary")
    Son = S1.Range("A" & Rows.Count).End(3).Row
    a = S1.Range("A1:E" & Son)
    
    ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a)
        Say = Say + 1
        For y = 1 To UBound(a, 2)
            b(Say, y) = a(i, y)
        Next y
    Next i
    S2.Range("A1").Resize(Rows.Count, 5).Clear
    If Say > 0 Then
        S2.Range("A1").Resize(Say, UBound(a, 2)) = b
        S2.Range("B2").Resize(Say).NumberFormat = "dd.mm.yyyy"
        S2.Range("A1").Resize(Say, UBound(a, 2)).Borders.Color = 1
    End If
    
    Renk = Array(15, 6, "")
    For Each x In S2.Range("A2:A" & Son)
        Krt = x.Value & x.Offset(0, 1)
        d(Krt) = d(Krt) + 1
    Next x
    
    For Each x In S2.Range("A2:A" & Son)
        If x <> "" Then
        Krt = x.Value & x.Offset(0, 1)
            p = (Application.Match(Krt, d.keys, 0)) Mod UBound(Renk)
            x.Resize(, 5).Interior.ColorIndex = Renk(p)
        End If
    Next x
    S2.Select
    MsgBox "İşlem Tamam.", vbInformation
End Sub

 

[ASLAN7410]

Sayın Ziynettin Bey ilginize çok teşekkür ederim, ellerinize sağlık, vallahi çok güzel oldu Allah razı olsun, gerçekten bu iş için saatlerce uğraşıyordum.

Hayırlı çalışmalar, hayırlı akşamlar diliyorum.

 

[ASLAN7410]

Sayın Ziynettin Bey 4.mesajınızdaki kodlar gayet iyi çalışıyor, halende kullanmaktayım.

Bugün verilerimi elle kontrol ettiğimde tek olan illeri de attığını fark ettim.

Benim istediğim aynı tarihin karşısındaki mükerrer illeri aktarıp bir sarı bir gri şeklinde renklendirmek istiyorum.

Yardımcı olur musunuz?

 

[Ziynettin]

Sayın Ziynettin Bey 4.mesajınızdaki kodlar gayet iyi çalışıyor, halende kullanmaktayım.

Bugün verilerimi elle kontrol ettiğimde tek olan illeri de attığını fark ettim.

Benim istediğim aynı tarihin karşısındaki mükerrer illeri aktarıp bir sarı bir gri şeklinde renklendirmek istiyorum.

Yardımcı olur musunuz?

Option Explicit
Sub Aktar_Renk()
Dim Son As Long, Say As Long, Krt As Variant
Dim a(), b(), d As Object, i As Long, j As Byte
Dim S1 As Worksheet, S2 As Worksheet
Dim x As Range, p As Byte, Renk, Z1 As Double, Z2 As Double
Z1 = TimeValue(Now)
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set d = CreateObject("Scripting.Dictionary")
    Son = S1.Range("A" & Rows.Count).End(3).Row
    a = S1.Range("A1:E" & Son)
    For i = 1 To UBound(a)
        Krt = a(i, 1) & " " & a(i, 2)
        d(Krt) = d(Krt) + 1
    Next i
    ReDim b(1 To UBound(a), 1 To UBound(a, 2))
    For i = 1 To UBound(a)
        Krt = a(i, 1) & " " & a(i, 2)
        If d(Krt) > 1 Then
            Say = Say + 1
            For j = 1 To 5
                b(Say, j) = a(i, j)
            Next j
        End If
    Next i
    S2.Range("A2:E" & Rows.Count).Clear
    If Say > 0 Then
        S2.Range("A2").Resize(Say, UBound(a, 2)) = b
        S2.Range("B2").Resize(Say).NumberFormat = "dd.mm.yyyy"
        S2.Range("A1").Resize(Say + 1, UBound(a, 2)).Borders.Color = 1
    End If

    Renk = Array(15, 6, "")
    For Each x In S2.Range("A2:A" & Son)
        Krt = x.Value & x.Offset(0, 1)
        d(Krt) = d(Krt) + 1
    Next x

    For Each x In S2.Range("A2:A" & Son)
        If x <> "" Then
        Krt = x.Value & x.Offset(0, 1)
            p = (Application.Match(Krt, d.keys, 0)) Mod UBound(Renk)
            x.Resize(, 5).Interior.ColorIndex = Renk(p)
        End If
    Next x
    S2.Select
    Z2 = TimeValue(Now)
    MsgBox "İşleminiz Tamamlandı." & vbLf & vbLf & "İşlem Süreniz :  " & CDate(Z1 - Z2) & "  saniye.", vbInformation
End Sub

 

[ASLAN7410]

Sayın Ziynettin Bey gece çalıştığım için bilgisayar başına yeni geçtim.

İlginize için çok teşekkür ediyorum Allah razı olsun, tam istediğim gibi oldu, ellerinize sağlık.

Verilerim hep yüksek olduğu için işlem biraz uzun sürüyor, kodun sonuna İşlem 00:10:00 saniye sürdü. şeklinde süre ekleyebilir miyiz?

 

[Ziynettin]

#7. mesajdaki koda istediğiniz eklemeler yapıldı. Tekrar deneyiniz.

 

[ASLAN7410]

Sayın Ziynettin Bey kusura bakmayın sizi yorduk, hakkınızı helal edin, Allah razı olsun tam istediğim gibi oldu.

Hayırlı geceler hayırlı çalışmalar dilerim.

 

[ASLAN7410]

Sayın Ziynettin Bey konu aynı konu olduğu için tekrar konu açmak istemedim.

7 numaralı mesajınızdaki kodlar çok işime yarıyor.

Bu konuya benzer olduğu için küçük bir istekte bulunmak istiyorum, yapmak istediğimi ekte gönderdim.

Sayfa1'deki verileri Sayfa2'ye aktarıp, Sayfa2'de B sütunundaki tarihe göre farklı tarih arasına boşluk atmak istiyorum.
A sütunundaki verilerin aynılığı önemli değil, veri çok olduğu için elle yapmak çok zor oluyor.

Yardımcı olur musunuz?

 

[ASLAN7410]

Konu günceldir.

Yardımcı olur musunuz?

 

[Ziynettin]

Merhaba,
Kodu deneyiniz.

Option Explicit
Sub tarih()
Dim a(), b(), d As Object
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Long, Say As Long, y As Byte
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set d = CreateObject("Scripting.Dictionary")
a = s1.Range("A1:M" & s1.Cells(Rows.Count, 1).End(3).Row)
For i = 1 To UBound(a)
    If a(i, 2) <> "" Then d(a(i, 2)) = ""
Next i
On Error Resume Next
ReDim b(1 To UBound(a) + d.Count, 1 To UBound(a, 2))
For i = 2 To UBound(a)
    Say = Say + 1
    For y = 1 To UBound(a, 2)
    b(1, y) = a(1, y)
        b(Say + 1, y) = a(i, y)
    Next y
    If a(i, 2) <> a(i + 1, 2) Then Say = Say + 1
Next i
s2.Cells.ClearContents
If Say > 0 Then
s1.Range(a).Copy s2.[A1]
s2.Range("A1").Resize(Say, UBound(a, 2)) = b
s2.Range("B2").Resize(Say).NumberFormat = "dd.mm.yyyy"
End If
s2.Select
MsgBox "İşlem Tamam.....", vbInformation
End Sub

Yeni yılınız hayırlı olsun.

 

[ASLAN7410]

Sayın Ziynettin Bey kusura bakmayın sizi yordum, çok teşekkür ediyorum, tam istediğim gibi oldu, Allah razı olsun.

Hayırlı geceler, hayırlı seneler.

 

[Ziynettin]

Amin.
Allah hepimizden razı olsun.