veriyi diğer sayfalara yerleştirmek

[akdenizli07]

Arkadaşlar Merhaba,
Eklediğim dosyada en soldaki VERİ sayfasındaki bilgileri sağa doğru uzanan diğer sayfalara otomatik olarak almak istiyorum. hangi bilginin nereye yerleşeceğini renklerle ifade ettim.

VERİ' deki gün yazan yerde 1 olanlar diğer sayfanın 01.08.2011 sayfasının içine, yine VERİ'de 2 olanlar 01.08.2011 sayfasının içine otomatik yerleşecek bir yöntem arıyorum.


ÖNEMLİ!!! Bu arada VERİ olan yer max 15000 satır kadar olabiliyor. her ay değişen bir veri.

Bu olayı nasıl gerçekleştiririm. Şimdiden teşekkürler.

 

[Ömer]

veriyi diğer sayfalara yerleştirmek

Merhaba,

Module kopyalayıp çalıştırın. Denemeyi yedek dosya üzerinde yaparsınız.

Silme olayında sorun yaşamamak için sayfa sonlarındaki toplam ve sütunu sona değil başa koyamanızı tavsiye ederim. Aksi durumda kodları uzatmak gerekir.

Kodlarda "' *** Silme kodları" olarak yazdığım bölümler sayfalardaki F ve H sütunundaki ilgili bölümleri son satıra kadar siler.

Kodu çalıştırınca açılan sorgu ekranına günün ay ve yılını girmeniz gerekir.

Örneğin.

08.2011

Gibi.

Sub Dagit()
 
    Dim Wf As WorksheetFunction, sor As String, i As Long
    Dim c As Range, ilk As Long, son As Long, syf As Worksheet
 
    Set Wf = WorksheetFunction
 
    Application.ScreenUpdating = False
    On Error Resume Next
 
    Sheets("VERİ").Select
    Range("A2:C" & Rows.Count).Sort Range("A2")
 
    sor = Application.InputBox(" ay.yıl  biçimi ile ay ve yıl girin", "Sayfa Dağılımı")
    For i = Wf.Min([A:A]) To Wf.Max([A:A])
 
        Set syf = Sheets("" & Format(i, "00") & "." & sor & "")
        syf.Range("F11:F" & Rows.Count).ClearContents ' *** Silme kodları
        syf.Range("H11:H" & Rows.Count).ClearContents ' *** Silme kodları
 
        Set c = Range("A:A").Find(i, , xlValues, xlWhole)
        If Not c Is Nothing Then
            ilk = c.Row
        End If
        son = Wf.CountIf([A:A], i) + ilk - 1
 
        Range("B" & ilk & ":B" & son).Copy syf.Range("H11")
        Range("C" & ilk & ":C" & son).Copy syf.Range("F11")
 
    Next i
 
End Sub

.

 

[akdenizli07]

Allah senden razı olsun, bu sitedeki paylaşım beni duygulandırıyor.
Emeğine ve bilgine sağlık..

 

[akdenizli07]

Merhaba, hani bu Alt sayfaların isimlerinde tarih vardıya 01.08.2011 gibi
ben bunları tarih oalrak değilde aynen 1 2 3 diye 31 e kadar adlandıracağım ve bundan sonraki aylarda sabit olacak. bunun için yukarıdaki kodlarda ne gibi değişiklikler olacak yardımcı olurmusunuz?

 

[Ömer]

tarih oalrak değilde aynen 1 2 3 diye 31 e kadar adlandıracağım ve bundan sonraki aylarda sabit olacak.

Bu şekilde deneyin.

Sub Dagit()
 
    Dim Wf As WorksheetFunction, i As Long
    Dim c As Range, ilk As Long, son As Long, syf As String
 
    Set Wf = WorksheetFunction
 
    Application.ScreenUpdating = False
    Sheets("VERİ").Select
    Range("A2:C" & Rows.Count).Sort Range("A2")
 
    For i = 1 To 31
        syf = Trim(i)
        If varmi(syf) Then
           With Sheets("" & syf & "")
               .Range("F11:F" & Rows.Count).ClearContents ' *** Silme kodları
               .Range("H11:H" & Rows.Count).ClearContents ' *** Silme kodları
 
               Set c = Range("A:A").Find(i, , xlValues, xlWhole)
               If Not c Is Nothing Then
                   ilk = c.Row
               End If
 
               If ilk > 0 Then
                   son = Wf.CountIf([A:A], i) + ilk - 1
                   Range("B" & ilk & ":B" & son).Copy .Range("H11")
                   Range("C" & ilk & ":C" & son).Copy .Range("F11")
               End If
            End With
        End If
        ilk = 0
    Next i
 
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function varmi(adi As String) As Boolean
    On Error Resume Next
    varmi = CBool(Len(Worksheets(adi).Name) > 0)
End Function

.

 

[akdenizli07]

Teşekkür ederim ama bir sorun farkettim. Veri sayfasında olmayan gün de olabilir. Mesela
ayın 4. günü hiç işlem olmamış olabilir. ama yine 4.sayfaya bişeyler atıyor.

1'den 31'e kadar aralıksız olursa sıkıntı yok.

 

[Ömer]

#5 numaralı mesajı yeniden düzenledim. Tekrar denermisiniz.

 

[akdenizli07]

sağolun hocam, konu kapanmıştır. Emeğinize sağlık...

 

[taylan44]

Acil Yardım

Selamlar Arkadaşlar;
Ekteki örneğe benzer bir dosya hazırlayacağım. Daha doğrusu siz üstadların katkısı ile.
RAYİÇ sayfası el ile doldurulacak. Diğer sayfaların A sütununa yazılan RAYİN NO eğer RAYİÇ sayfasında yer alıyorsa; B C E sütununun değerlerini RAYİÇ sayfasından çeksin ve d sütunu dolu ise F sütununun değerini D*E olarak yazsın, ondalık kısmı 2 hane olacak şekilde.

Acil olarak yardımlarınızı bekliyorum.

 

[Ömer]

Merhaba,

Diğer sayfalara koyacağınız düşeyara formülü ile bu işlemi yapabilirsiniz.

Beton sayfası B7:

=DÜŞEYARA($A7;RAYİÇ!$A:$D;2;0)

2 değeri rayıç sayfasındaki 2 sütundaki değeri alır, formülü diğer sütunlara uygularken 2 değerini değiştirmeniz yeterli olacaktır.

.

 

[taylan44]

Teşekkürler,
Ancak ben bunu formüllerle değil de Makro veya VBA şeklinde çözümlenmesini istiyorum. her seferinde formül taşımakla uğraşmak istemiyorum. RAYİÇ sayfasında yer alan değerler diğer sayfaların A sütununa aynı değer yazıldığında diğer hücreleri otomatik doldursun.

 

[Ömer]

Teşekkürler,
Ancak ben bunu formüllerle değil de Makro veya VBA şeklinde çözümlenmesini istiyorum. her seferinde formül taşımakla uğraşmak istemiyorum. RAYİÇ sayfasında yer alan değerler diğer sayfaların A sütununa aynı değer yazıldığında diğer hücreleri otomatik doldursun.

Module kopyalayın ve butona bağlayarak çalıştırın.

Sub SayfayaAktar()
 
    Dim i As Long, j As Integer, c As Range, Adr As Variant
 
    Application.ScreenUpdating = False
    Sheets("RAYİÇ").Select
 
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        For j = 1 To Worksheets.Count
            With Sheets(j)
                If .Name <> "RAYİÇ" Then
                    Set c = .Range("A:A").Find(Cells(i, "A"), , xlValues, xlWhole)
                    If Not c Is Nothing Then
                        Adr = c.Address
                        Do
                            .Cells(c.Row, "B") = Cells(i, "B")
                            .Cells(c.Row, "C") = Cells(i, "C")
                            .Cells(c.Row, "E") = Cells(i, "D")
                            .Cells(c.Row, "F") = "=D" & c.Row & "*E" & c.Row
                            Set c = .Range("A:A").FindNext(c)
                        Loop While Not c Is Nothing And c.Address <> Adr
                    End If
                End If
            End With
        Next j
    Next i
 
End Sub

.

 

[taylan44]

Teşekkür ederim. İşime yaradı. Bu içeriği butona bağlı olmadan otomatik çalıştırma şansımız yok mu?

 

[Ömer]

RAYİÇ sayfasının kod bölümüne kopyalayın, RAYİÇ sayasını terk ettiğinizde kod çalışır.

Private Sub Worksheet_Deactivate()
 
    Dim i As Long, j As Integer, c As Range, Adr As Variant
 
    Application.ScreenUpdating = False
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        For j = 1 To Worksheets.Count
            With Sheets(j)
                If .Name <> "RAYİÇ" Then
                    Set c = .Range("A:A").Find(Cells(i, "A"), , xlValues, xlWhole)
                    If Not c Is Nothing Then
                        Adr = c.Address
                        Do
                            .Cells(c.Row, "B") = Cells(i, "B")
                            .Cells(c.Row, "C") = Cells(i, "C")
                            .Cells(c.Row, "E") = Cells(i, "D")
                            .Cells(c.Row, "F") = "=D" & c.Row & "*E" & c.Row
                            Set c = .Range("A:A").FindNext(c)
                        Loop While Not c Is Nothing And c.Address <> Adr
                    End If
                End If
            End With
        Next j
    Next i
 
End Sub

.

 

[taylan44]

Teşekkür ederim.
Kolay gelsin.