Hatim Cüz Dağıtım Programı

[ÖmerFaruk]

https://dosya.co/s4cwrz6og17h/Hatim_Cüz_Dağıtım_Program-3.xlsm.html

 

[TURKOLOG]

https://dosya.co/s4cwrz6og17h/Hatim_Cüz_Dağıtım_Program-3.xlsm.html

Ömer Hocam çok teşekkür ederim. Altın üyeligim bitmiş. Uzun zamandır yoktum. Yeniledim şimdi üyeliğimi. Teşekkür ederim.

 

[Mikdad]

Dosyayı harici link olarak paylaşabilecek olan var mı acaba

Benim çok işime yaradı. Râbbim sizlerden razı olsun inşşAllah

İndir Hatim Cüz Dağıtım Program

Dosyayı indir Hatim Cüz Dağıtım Program

dosya.co

 

[Mikdad]

hocam program evdeki pc de aşağıdaki hatayı veriyor iş yerinde de evde de office 365 var. sorun ne olablir acaba

 

[Korhan Ayhan]

Linki inceleyiniz.

satır ekleme

Merhaba; Tablomda yer alan Liste 1 yer alan bir personel ' liste 2 de yoksa karşısına satır ekleyip olmayan personeli eklemesi mevcut mudur. Yada tam tersi de olabiliyor.

www.excel.web.tr

 

[ÖmerFaruk]

Oradaki fonksiyonu sadece kişilere yazılan cüz numaralarını küçükten büyüğe sıralamak için kullanılmıştı. Eğer hatayı gerekli güncellemeyi uygulayarak yapmaktan kaçınırsanız;

Module1 içindeki eski kodlar yerine aşağıdaki revize edilmiş halini kullanın

Dim CüzYaz As Object
Sub Cuzler()
Dim Cüz1 As Object, Cüz2 As Object, CüzSec As Object
Dim Sh1 As Worksheet, Sh2 As Worksheet, rngCell As Range, Okunan
Dim Liste1(), Liste2(), Max1 As Byte, Max2 As Byte, Wf As WorksheetFunction, CüzNo As Integer, Metin As String
Dim i As Integer, k As Integer, x As Integer, Sütun As Integer, Son As Integer
    
    Set Wf = WorksheetFunction
    Set Cüz1 = VBA.CreateObject("Scripting.Dictionary")
    Set Cüz2 = VBA.CreateObject("Scripting.Dictionary")
    Set CüzYaz = VBA.CreateObject("Scripting.Dictionary")
    Set CüzSec = VBA.CreateObject("Scripting.Dictionary")
    Set Sh1 = Worksheets("Hazırlık")
    Set Sh2 = Worksheets("Döküm")
    
    Sütun = 5 + (Sh1.Range("I4") - 1) * 2
    Son = Sh1.Range("B" & Rows.Count).End(xlUp).Row
    Sh1.Columns(Sütun).ColumnWidth = 10
    Sh1.Columns(Sütun + 1).ColumnWidth = 5
    
    ReDim Liste2(1 To 30)
    For i = 7 To Son
        Max1 = 0
        Max2 = 0
        If Sh1.Range("D" & i) <> "Aktif" Then GoTo Atla
        ReDim Liste1(1 To 30)
        If Sütun > 5 Then
            For k = Columns("E").Column To Sütun - 2 Step 2
                If Sh1.Cells(i, k) <> "" Then
                    Okunan = Split(Sh1.Cells(i, k), "-")
                    For x = 0 To UBound(Okunan, 1)
                        Liste1(Okunan(x)) = Liste1(Okunan(x)) + 1
                        Max1 = Wf.Max(Max1, Liste1(Okunan(x)))
                    Next x
                End If
            Next k
        End If
        GoTo Atla11
        If i > 7 And Sh1.Cells(i - 1, Sütun) <> "" Then
            Okunan = Split(Sh1.Cells(i - 1, Sütun), "-")
            For x = 0 To UBound(Okunan, 1)
                Liste2(Okunan(x)) = Liste2(Okunan(x)) + 1
                Max2 = Wf.Max(Max2, Liste2(Okunan(x)))
            Next x
        End If
Atla11:
        Do
            Cüz1.RemoveAll: Cüz2.RemoveAll: CüzSec.RemoveAll
            For x = 1 To 30
                If (Sütun = 5 Or Liste1(x) * 1 < Max1) And (Liste2(x) = Empty Or Liste2(x) * 1 < Max2) Then
                    Cüz1.Add Cüz1.Count + 1, x
                Else
                    Cüz2.Add Cüz2.Count + 1, x
                End If
            Next x
            If Cüz1.Count > 0 Then
                For x = 1 To Cüz1.Count
                    CüzSec.Add x, Cüz1(x)
                Next x
            Else
                For x = 1 To Cüz2.Count
                    CüzSec.Add x, Cüz2(x)
                Next x
            End If
            xMax = CüzSec.Count
            CüzNo = Wf.RandBetween(1, xMax)
            If Not CüzYaz.Exists(CüzSec(CüzNo)) Then
                CüzYaz.Add CüzSec(CüzNo), 0
                If i > 7 Then Liste1(CüzSec(CüzNo)) = Liste1(CüzSec(CüzNo)) + 1
                Liste2(CüzSec(CüzNo)) = Liste2(CüzSec(CüzNo)) + 1
                Max1 = Wf.Max(Max1, Liste1(CüzSec(CüzNo)))
                Max2 = Wf.Max(Max2, Liste2(CüzSec(CüzNo)))
                If CüzYaz.Count = Sh1.Range("C" & i) Then Exit Do
            End If
        Loop
        If CüzYaz.Count > 1 Then Call Module1.SortDictionaryByKey
        Sh1.Cells(i, Sütun) = Join(CüzYaz.Keys, "-")
        If Sh1.Cells(i, Sütun).Errors.Item(xlNumberAsText).Value Then Sh1.Cells(i, Sütun).Errors.Item(xlNumberAsText).Ignore = True
        CüzYaz.RemoveAll
Atla:
    Next i
    
    Sh2.Range("A4:D" & Rows.Count).ClearContents
    Sh1.Range("A7:B" & Son).Copy
    Sh2.Range("A4").Resize(Son - 6, 2).PasteSpecial xlPasteValues
    Sh1.Range("A7").Offset(0, Sütun - 1).Resize(Son - 6, 1).Copy
    Sh2.Range("A4").Offset(0, 2).Resize(Son - 6, 1).PasteSpecial xlPasteValues
        For Each rngCell In Sh2.Range("A4").Offset(0, 2).Resize(Son - 6, 1).Cells
            With rngCell
                If .Errors.Item(xlNumberAsText).Value Then .Errors.Item(xlNumberAsText).Ignore = True
            End With
        Next rngCell
    Sh2.Range("A4").Offset(0, 2).Resize(Son - 6, 1).HorizontalAlignment = 2
    Sh1.Range("I4") = Wf.Min(52, Sh1.Range("I4") + 1)
    
    Set Cüz1 = Nothing: Set Cüz2 = Nothing: Set CüzYaz = Nothing: Set CüzSec = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing: Set Wf = Nothing
End Sub
Sub SortDictionaryByKey()
Dim tmplist, a As Integer, b As Integer, tempp As Integer
    ReDim tmplist(1 To 1)
    For Each Key In CüzYaz
        a = a + 1
        ReDim Preserve tmplist(1 To a)
        tmplist(a) = Key
    Next Key
    For a = 1 To UBound(tmplist) - 1
        For b = a + 1 To UBound(tmplist)
            If tmplist(a) > tmplist(b) Then
                tempp = tmplist(a)
                tmplist(a) = tmplist(b)
                tmplist(b) = tempp
            End If
        Next b
    Next a
    CüzYaz.RemoveAll
    For a = 1 To UBound(tmplist)
        CüzYaz.Add tmplist(a), 0
    Next a
End Sub

 

[halit3]

Merhaba
Bende farklı bir dosya ekliyorum burada veri sayfasında C sutünunda X olanları B sutünundaki değer kadar aktarım yapıyor.
Aktar komut düğmesine basınca işlemler yapılıyor ve her komut düğmesine basınca da hafta sayfasına da aktarım yapıyor.
Dosya aşağıdaki linkte

hatim_cuz.xls dosyasını indir - download

hatim_cuz.xls dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s7.dosya.tc

 

[halit3]

Bu dosyaya bazı eklemeler yaptım.

hatim_cuz_1.xls dosyasını indir - download

hatim_cuz_1.xls dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s7.dosya.tc

 

[Mikdad]

Bu dosyaya bazı eklemeler yaptım.

hatim_cuz_1.xls dosyasını indir - download

hatim_cuz_1.xls dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s7.dosya.tc

değerli hocam Allah razı olsun. şimdi ben indirdim, daha önce 24 kişi idi ama şuan kişi sayısı 45 e çıktı ve daha da yükselecek. kişileri ekledim ama ilk ekranda oluşturuyor. ama hafta sayfasında 30 satırdan fazlasını aktarmıyor
yardımcı olur musunuz?

 

[Mikdad]

hatalı olan dosyayı paylaşiyorum. sizden ricam bakar mısınız?

 

[halit3]

Aşağıdaki link deki dosyayı irdeleyiniz.

https://s2.dosya.tc/server17/scwx39/hatim_cuz_1.rar.html

 

[Mikdad]

Aşağıdaki link deki dosyayı irdeleyiniz.

https://s2.dosya.tc/server17/scwx39/hatim_cuz_1.rar.html

Selamun aleykum hocam Allah razı olsun eksiklikler giderilmiş , rapor ekranı ile ilgili bir eksik kaldı eğer o konuda da yardımcı olursanız çok sevinirim.

 

[Mikdad]

Biraz kastırdım ama sanırım oldu.

2. hafta için tıkladığımda end debug a düşüyor. debug diyince bu hatayı alıyorum. sorun nedir dostlar