Personeli Katlara ve Odalara Otomatik Atama

[deniz9899]

Merhaba,

2 sayfadan oluşan veri dosyam var. ilk sayfamda personel listesi ve ikinci sayfada ise kat, oda ve personel bilgileri var. ihtiyacım olan şey: makro ile katlara ait sayfaları otomatik oluşturarak o katlardaki personel ve oda numaralarını kat sayfalarına yazdırmak. Excel dosyasını her açılış ve kapatışta güncellerse çok işime yarar. Excel bilgim zayıf olduğu için yardımınıza ihtiyacım var.
Veri dosyam ve olmasını istediğim örnek dosyam aşağıdaki linkte mevcut.

Yardımcı olur musunuz?

Desktop.rar dosyasını indir - download

Desktop.rar dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

 

[deniz9899]

Yardımcı olacak yok mu?

 

[kulomer46]

Merhaba

Dosyayı indiremedim ve açamadım. Dosyanızı yüklediğiniz https://s6.dosya.tc/ sitesine giremiyorum

Rica etsem ücretsiz dosya yükleme sitesi olan https://dosyam.org/ sitesine dosyanızı yükleyip, yükleme adresini burada paylaşırmısınız.

Selamlar...

 

[deniz9899]

Buyrun

Bilgi

Bilgi

dosyam.org

Teşekkürler

 

[kulomer46]

Merhaba

Dosyanızı indirdim. Ama açarken hata veriyor.

Hatanın ekran resmi


Dosyanızı bir görseydik. Talebinizi merak ettim : )

Selamlar...

 

[veyselemre]

Sub test()
    Dim katlar(), dicPer As Object, personeller(), i&, ii%, _
    dicShList As Object, dicKatlar As Object, katListesi, _
    sh As Worksheet, kat$, son&, top%
   
    With Sheets("PERSONEL")
        personeller = .Range("A2:C" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With

    Set dicPer = CreateObject("Scripting.Dictionary")
    With dicPer
   
        For i = LBound(personeller) To UBound(personeller)
            .Item(personeller(i, 1)) = Array(personeller(i, 2), personeller(i, 3))
        Next i
    End With

    Set dicShList = CreateObject("Scripting.Dictionary")
    With dicShList
        For Each sh In Worksheets
            If Not (sh.Name = "PERSONEL" Or sh.Name = "DAĞILIM") Then
                sh.Cells.ClearContents
            End If
            .Item(sh.Name) = 0
        Next sh
    End With

    With Sheets("DAĞILIM")
        katListesi = .Range("A2:F" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With
   
    For i = LBound(katListesi) To UBound(katListesi)
        kat = katListesi(i, 1)
       
        If Not dicShList.exists(kat) Then
            Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
            sh.Name = kat
            dicShList.Item(sh.Name) = 0
        Else
            Set sh = Sheets(kat)
        End If
       
        son = dicShList.Item(sh.Name) + 1
        sh.Cells(son, 1).Value = katListesi(i, 2)
           
        top = 0
        For ii = 3 To 6
            If katListesi(i, ii) > 0 Then
                top = top + 1
                son = son + 1
                sh.Cells(son, 2).Resize(, 2).Value = dicPer(katListesi(i, ii))
            End If
        Next ii
        If top = 0 Then
            son = son + 1
            sh.Cells(son, 2).Value = "BOŞ"
        End If
        dicShList.Item(sh.Name) = son
    Next i
   
End Sub

 

[deniz9899]

Çok teşekkürler @veyselemre Bey.

 

[Haluk]

Liyakata göre atama yapan bir kodu yazan var mı ?

.