• DİKKAT

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

Başka bir sayfadan verileri alıp uygun hücrelere bu verileri yerleştirmek.

N

nongeyikm

Katılım
7 Kasım 2005
Mesajlar
505
Excel Vers. ve Dili
Office 365 TR-64
Merhabalar,

Ekli sayfada yaptığım örnek dağılım ile anlatmaya çalıştığım olayı gerçekleştirmek mümkünmüdür?

Puantaj dağılım sayfasında veriler ayın ilk gününe girişmiş olup, bu veriler puantaj sayfasındaki günlere sicil ve aktiviteler dikkate alınarak ve de günlük mesai süresi de dikkate alınarak aktivite süresine bağlı kalınarak ayın günlerine rastgele dağıtılması gerekiyor.

Yardımlarınız için şimdiden teşekkürler.

Saygılarımla,


konuyu, çözülmüş olan http://www.excel.web.tr/f48/rapor-olu-turma-hk-t155728.html linkin devamında da yanlışlıkla paylaştım. Dikkate almayınız.
 

Ekli dosyalar

Son düzenleme:
Sn. üstadlar;
Konunun zorluğunun farkındayım. Beni fazlasıyla aşar lakin mümkün bir yolu vardır diye düşünmekteyim. Fikri olan da yokmudur? Beni günlerce uğraştıracak bir hammaliye bu.

Lütfen ilgilenecek biri yokmudur??

Saygılar,
 
Son düzenleme:
Arkadaşlar,

İşlem sayısını düşürdüm. Benim için çok önemli bu. Yokmu yardım edebilecek biri.
 
Merhaba,
dosyayı dener misiniz?
Çok yer kapladığından kırparak yükledim.
Ancak orjinal dosyanızda çalışacaktır.
Kolay gelsin.
 

Ekli dosyalar

Sn. M Şahin;

Cevabınızı görünce çok mutlu oldum. Gönderdiğiniz dosya üzerinde denedim ve ekteki hatayı verdi. kendi dosyam üzerinde mi denemeliyim? İlgilenebilirmisiniz.

Aslında aktiviteleri hücrelere yazdırmaya gerek olmayan yeni dosya yüklemiştim. (puantaj_aşama_20.xlsm) Ona da bakabilirdiniz.
 

Ekli dosyalar

  • Pano01.jpg
    Pano01.jpg
    422.1 KB · Görüntüleme: 13
Çok çok pardon.

kendi verilerimi tabloya yerleştirince oldu gibi. kontrol ediyorum. Kontrolleri bitirince dönüş yapacağım mehmet bey. Siz muhteşem birisiniz.
 
Siz övgüleri fazlasıyla hakeden birisiniz. Yapılabilirliği bile bana göre tartışma konusu olacak bir şeyi başardınız. Canı gönülden tebrik ediyor Allah razı olsun diyorum.

Saygı ve hürmetlerimle,
 
Rica ederim, selamlar, iyi çalışmalar.
 
Alternatif olsun,
Kod: 
Sub dagit()
    zaman = Timer
    Set s1 = Sheets("puantaj")
    Set s2 = Sheets("puantaj dağılım")

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    SON = s2.Cells(Rows.Count, "B").End(3).Row
    Dim z(1 To 3, 1 To 1), y()
    lst = s2.Range("A1:AF" & SON).Value

    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(lst)
            For sut = 10 To 32
                If lst(i, sut) > 0 Then
                    Key = lst(i, 3) & "|" & lst(i, 2)
                    If Not .exists(Key) Then
                        z(1, 1) = lst(i, sut)
                        z(2, 1) = sut
                        z(3, 1) = lst(1, sut)
                        .Item(Key) = z
                    Else
                        y = .Item(Key)
                        idx = UBound(y, 2) + 1
                        ReDim Preserve y(1 To 3, 1 To idx)
                        y(1, idx) = lst(i, sut)
                        y(2, idx) = sut
                        y(3, idx) = lst(1, sut)
                        .Item(Key) = y
                    End If
                End If
            Next sut
        Next i

        s1.Select
        SON = Cells(Rows.Count, "B").End(3).Row
        ReDim W(1 To SON - 1, 1 To 46)
        Range("j2:bc" & Rows.Count).ClearContents
        lst1 = Range("B2:G" & SON)
        For i = 1 To UBound(lst1)
            Key = lst1(i, 2) & "|" & DateSerial(Year(lst1(i, 1)), Month(lst1(i, 1)), 1)
            s = lst1(i, 6)
basla:
            If s > 0 Then
                If .exists(Key) Then
                    al = .Item(Key)
                    For ii = LBound(al, 2) To UBound(al, 2)
                        ts = al(1, ii)
                        If ts > 0 Then
                            idx = al(2, ii) - 10
                            If ts >= s Then
                                W(i, (idx * 2 + 1)) = al(3, ii)
                                W(i, (idx * 2 + 2)) = s
                                ts = ts - s
                                al(1, ii) = ts
                                .Item(Key) = al
                                s = 0
                                GoTo atla
                            Else
                                W(i, (idx * 2 + 1)) = al(3, ii)
                                W(i, (idx * 2 + 2)) = ts
                                al(1, ii) = 0
                                .Item(Key) = al
                                s = s - ts
                                GoTo basla
                            End If
                        End If
                    Next ii
                End If
            End If
atla:
        Next i
        [j2].Resize(UBound(W, 1), 46).Value = W
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
    End With
    MsgBox "İşlem TAMAM." & vbCr & Format(Timer - zaman, "0.0000"), vbInformation
End Sub
 
Son düzenleme:
Günaydın Veysel Bey,

İlginize çok teşekkürler. Mehmet Bey'in makrosu ile işimi hallettim. Kalın sağlıcakla.
 
Günaydın,
Veysel beyin kodları 4 küsur saniye sürüyor. Benim yazdıklarım ise;
Kod: 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
blokları
eklenirse 10 saniyelerde bitiyor. Bu durumda Veysel beyin kodları daha kullanışlı.
İyi çalışmalar.
 
Merhaba Mehmet Bey, Veysel Bey,

Diğer çalışmama benzer son bir işim daha kaldı. Aynı makroyu bu dosyamada uyguladım lakin olmadı. Diğerinde sicil vardı ektekinde ise kodlar var. Yine bu dağılımı belirttiğim günlere aynı mantıkla yapabilirmisiniz. Dosya boyutu yüksek olduğu için puantaj sayfasına tek bir kod koydum. Tamamının listelenmesi gerekiyor. Bu konu ile ilgili son isteğim bu sizden. Teşekkür ederim.

Saygılarımla,
 

Ekli dosyalar

Son düzenleme:
Merhaba,
"puantaj dağılım" sayfasındaki, "L" ve "P" sütun başlıkları aynı mıdır?
 
Günaydın Mehmet Bey,

Haklısınız. P Sütunu mükerrer olmuş. Verilerini l sütununda birleştirdim ve dosyayı güncelledim.

Not : Puantaj sayfası G sütunundaki günlük mesailer 10 saat olarak belirlenmiş fakat her gün farklı olabileceği gibi 11,12 veya 13 saatte olabilir. (Dağılımdaki aylık toplam saat ile G sütunundaki aylık toplam saat eşleşmeli)

Saygılar,
 
Son düzenleme:
Merhaba,
dosyadaki ilgili prosedürü aşağıdakiyle değiştirip deneyin.
İyi çalışmalar.
Kod: 
Sub fm_dagit()

Dim d As Object, rw As Range, k, t
Dim arr, arrOut, nR, n
Dim hdf As String
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = ThisWorkbook.Worksheets("puantaj dağılım")
Set sh2 = ThisWorkbook.Worksheets("puantaj")

 sn1 = sh1.[c65536].End(3).Row
 sn2 = sh2.[b65536].End(3).Row + 1
 
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 
 
 sh2.Range("j2:aa" & sn2).ClearContents
  Set d = GetRowLookup(sh2.Range("b2:C" & sn2))
 
 Set conn = econn(ThisWorkbook.FullName)
  SQLStr = "select * from [puantaj dağılım$a1:q" & sn1 & "] where MESAİ>0 order by SİCİL,TARİH"
'  Debug.Print SQLStr
   rs.Open SQLStr, conn, 1, 1
   If rs.EOF = True Or rs.BOF Then GoTo alt
          Do While Not rs.EOF
'................başlangıç satırı bulma............
 tarih = CDate(rs.Fields("TARİH"))
 sicil = RTrim(rs.Fields("SİCİL"))
 tpfm = rs.Fields("MESAİ")
 
say = 1
        If WorksheetFunction.CountIf(sh2.Range("c2:c" & sn2), sicil) > 0 Then
        k = tarih & Chr(0) & sicil
       
5:
            If say > 30 Then
            MsgBox "30 gün aralığında yaklaşık tarih bulunamadı!"
            GoTo gec
            End If
            If d.exists(k) And IsEmpty(d(k)) = False Then
                sat = d(k)
                GoTo 10
            Else
                tarih = DateAdd("d", 1, tarih)
                k = tarih & Chr(0) & sicil
                say = say + 1
                GoTo 5
            End If
10:
'...............................kolonların kontrolü...........
 limit = sh2.Cells(sat, "g") 'mesai limiti
            For i = 9 To 16 'field başlıkları
               If rs.Fields(i).Value > 0 Then 'mesai varsa
                    act_fm = rs.Fields(i).Value 'aktivite mesaisi 7
                    col = sh2.Range("J1:x1").Find(rs.Fields(i).Name, lookat:=xlWhole).Column 'ilgili colon
                  
                    Do
                        If act_fm > limit Then 'gün limitinden fazlaysa
                           sh2.Cells(sat, col) = rs.Fields(i).Name
                           sh2.Cells(sat, col + 1) = limit 'sütun değeri
                           act_fm = act_fm - limit
                           limit = limit - limit
                           sat = sat + 1 'bir satır alta geç
                          limit = sh2.Cells(sat, "g") 'mesai limiti
                        Else
                           sh2.Cells(sat, col) = rs.Fields(i).Name
                           sh2.Cells(sat, col + 1) = act_fm
                           limit = limit - act_fm
                           act_fm = act_fm - act_fm
                        End If
                    Loop While act_fm > 0
                    
               End If
            Next i
     End If
gec:
          rs.MoveNext
          Loop
   rs.Close
MsgBox "İşlem Tamamlandı"
GoTo alt1
alt:

MsgBox "Kayıt Bulunamadı"
alt1:


conn.Close
Set conn = Nothing
Set sh1 = Nothing: Set sh2 = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set rs = Nothing

End Sub
'create a dictionary lookup based on two column values
Function GetRowLookup(rng As Range)
    Dim d As Object, k, rw As Range
    Set d = CreateObject("scripting.dictionary")
    For Each rw In rng.Rows
        k = GetKey(rw)
        d.Add k, rw.Cells(1).Row 'not checking for duplicates!
    Next rw
    Set GetRowLookup = d
    Set d = Nothing
    Set rng = Nothing
End Function

'create a key from a given row
Function GetKey(rw As Range)
    GetKey = rw.Cells(1).Value & Chr(0) & rw.Cells(2).Value
End Function
 
Son düzenleme:
Mehmet Bey,

Verdiğiniz makroyu uygulayınca ekteki hatayı aldım.
 

Ekli dosyalar

  • Pano01.jpg
    Pano01.jpg
    288.2 KB · Görüntüleme: 8
Merhaba, sizin dün eklediğiniz dosyadaki "fm_dagit()" prosedürünü silip yukarıda yazdığımı kopyalayın sadece. Bulunmadı hatası veren fonksiyon orada var zaten.
 
Siz en iyisi en son dün eklediğiniz dosyadaki "veriyaz" modülündeki tüm kodları silip yukarıda yeniden eklediğim tüm kodu yapıştırın, çalışacaktır.
 
Mehmet Bey,

Çok özür dilerim yanıt verdim sandım. Olayı hallettiniz. Çok çok teşekkür ederim. Allah razı olsun.

Kolay gelsin, saygılar.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst