Aya göre kopyala yapıştır.

[arzum2000]

Merhabalar.

Sayfa2 de d1 ve e1 deki aya göre nedenler sütunlarındaki verileri sayfa1 e kopyalayacak bir makroya ihtiyacım var.Sayfa2 deki tarih değiştiğinde örneğin şubat ise nedenleri sayfa1 deki şubat ayının(nedene göre) b4-f4 satırına kopyalayacak.sayfa2 deki tarih aralığı 1 yıl aralığında ise 1,01,2010-31,12,2010 ise bu kez tüm ayları nedene göre sayfa2 den kopyalayıp sayfa1 e yapıştıracak ve kaydedecek.Tşk ediyorum.

 

[Necdet]

Merhaba,

Sayfa2 deki tarihe göre Sayfa1 e aktarım olacak ama :

diyelim ki tarih ay itibariyle ağustos olsun, sayfa2 deki hangi satırlar sayfa1 deki ağustos ayına aktarılacak?

 

[arzum2000]

eğer ağustos ayı ise sayfa1 de sadece b2-f2 aralığındaki verilere bakarak verileri sadece b10-f10 arasına yapıştıracak şayet ağustos-temmuz arası ise verileri aynı şekilde s1de satır satır ağustos ve temmuzun karşısındaki satırlara yani b9-f9 ve b10-f10 arasına kopyalayacak.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp dener misiniz? umarım doğru anlamışımdır.

Sub Aktar()
Dim sat As Integer
Dim kol As Integer
Dim ay  As Integer
Dim c As Range
Dim s1 As Worksheet
Dim s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Select
For ay = Month([D1]) To Month([E1])
    sat = ay + 2
    For kol = 1 To 5
        Set c = s1.Range("b2:f5").Find(Cells(2, kol), LookIn:=xlValues)
        If Not c Is Nothing Then
            s1.Cells(sat, c.Column) = Cells(sat, kol)
        End If
    Next kol
Next ay
End Sub

 

[arzum2000]

Biraz eksiklik var şöyleki sayfa2 de 1.ay d1 hücresi e1 ise son tarih sadece 2 ayı görebiliyoruz sayfa1 e sayfa2den d1 ve e1 arasındaki 2 tarih aralığında yapıştıracak.ilk tarihi 01.01.2010 son tarihi 31.12.2010 yazdım çalışmadı.Sadece 2 ayı göstermeyecek bu tarih aralığını seçersem 12 ay birden yapıştıracak.

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub AYA_GÖRE_KOPYALA()
    Dim S1 As Worksheet
    Dim S2 As Worksheet
    Dim X As Byte, Y As Byte, HÜCRE As Range, BUL As Range
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
       
    S1.Range("B3:F14").ClearContents
   
    For X = Month(S2.Range("D1")) To Month(S2.Range("E1"))
        For Each HÜCRE In S2.Range("A2:E2")
            Set BUL = S1.Rows(2).Find(S2.Cells(2, HÜCRE.Column), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
                For Y = 1 To 12
                    If X = Y Then S2.Cells(Y + 2, HÜCRE.Column).Copy S1.Cells(Y + 2, BUL.Column): GoTo Devam
                Next
            End If
Devam:
        Next
    Next
    
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[arzum2000]

Korhan bey size ana dosyayı gönderiyorum.grafikler sayfasına kalite2 sayfasındaki
sebeplere göre b53-x53 arasındaki toplamları tarihe ve sebeplere göre yapıştırmak istiyorum.Sizin makronuzu uyarlayamadım.

 

[Necdet]

eğer ağustos ayı ise sayfa1 de sadece b2-f2 aralığındaki verilere bakarak verileri sadece b10-f10 arasına yapıştıracak şayet ağustos-temmuz arası ise verileri aynı şekilde s1de satır satır ağustos ve temmuzun karşısındaki satırlara yani b9-f9 ve b10-f10 arasına kopyalayacak.

Merhaba, tam olarak kontrol etmemişim, dosyayı ve kodları yeniledim.

 

[arzum2000]

son gönderdiğim dosyaya uyarlayabilirseniz sevinirim dosya adı kitapson diye geçiyor.tşk ediyorum.

 

[Korhan Ayhan]

Selamlar,

İlk dosyanızla son dosyanız arasında epey farklılıklar var. Bu sebeple önerdiğimiz kodlar sonuç üretmemiş.

Aşağıdaki kodu deneyiniz.

Option Explicit
 
Sub AYA_GÖRE_KOPYALA()
    Dim S1 As Worksheet
    Dim S2 As Worksheet
    Dim X As Byte, Y As Byte, HÜCRE As Range, BUL As Range
    
    Set S1 = Sheets("grafikler")
    Set S2 = Sheets("kalite2")
       
    S1.Range("AJ76:AN87").ClearContents
   
    For X = Month(S2.Range("V1")) To Month(S2.Range("X1"))
        For Each HÜCRE In S2.Range("B2:X2")
            Set BUL = S1.Rows(75).Find(HÜCRE.Value, LookAt:=xlWhole)
            If Not BUL Is Nothing Then
                For Y = 1 To 12
                    If X = Y Then S1.Cells(Y + 75, BUL.Column).Value = S2.Cells(53, HÜCRE.Column).Value: GoTo Devam
                Next
            End If
Devam:
        Next
    Next
    
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[arzum2000]

Tamam dır tşk ediyorum bilseydim en baştan bu dosyayı gönderirdim örnek dosya göndermekle hata yapmışım.