Personelin karşısına görev yerlerini yazma

[ASLAN7410]

Merhaba, hayırlı geceler.

Ekteki excel dosyamda personel görevleri hazırlamaya çalışıyorum.
Sayın Ömer BARAN Bey, birleştirilmiş hücreleri gizleyerek personelleri
Sayfa2'ye aktarma kodu yazmıştı.

Benim yapmak istediğim butona bastığımda personelleri aktardıktan sonra,
Sayfa1'deki birleştirilmiş hücre içerisindeki görev yerlerini personellerin karşısına yazmasını istiyorum.

Yardımcı olur musunuz?

 

[askm]

İşlemin olması için ilk kişilerinde üst kısmında görev yerlerinin yazması gerekmez mi. Ali il Velinin.

 

[ASLAN7410]

Sayın askm, ilginiz için çok teşekkür ediyorum.

Dediğiniz kişiler sabit olduğu için görev yerleri yok, yani rütbeli amirler.

 

[askm]

Sub askm()
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
Dim son As Long
son = s1.Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
s2.Range("B2:F65000").ClearContents
a = 2
For i = 9 To son
    If s1.Range("B" & i & ":U" & i).MergeCells = True Then GorevYeri = s1.Cells(i, 2)
    If s1.Cells(i, 3) <> Empty Then
        s2.Cells(a, 2) = a - 1
        s2.Cells(a, 3) = s1.Cells(i, 3)
        s2.Cells(a, 4) = s1.Cells(i, 4)
        s2.Cells(a, 5) = s1.Cells(i, 5)
        s2.Cells(a, 6) = GorevYeri
        a = a + 1
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[ASLAN7410]

Sayın askm, kod tam istediğim gibi güzel çalışıyor, çok teşekkür ederim.


Hayırlı çalışmalar, hayırlı günler.

 

[Haluk]

Excel ile ilgisi yok ama, ufak bir hatırlatma;

"Personel" tekil veya çoğul şahıs/şahıslar için aynen kullanılır. Yani; 2 veya daha fazla kişi için ayrıca çoğul eki kullanılmaz.

1 personel, 10 personel ... gibi.

.

 

[askm]

Rica ederim. İyi aksamlar.

 

[ASLAN7410]

Sayın Haluk Bey, ilginiz için teşekkür ediyorum, başlığı düzelttim.

 

[ASLAN7410]

Sayın askm, yazmış olduğunuz kod gayet güzel çalışıyor, elinize sağlık,
çok teşekkür ediyorum.

Ben bu kodu bir kaç sayfa için yapmaya çalıştığım zaman aktardığı yere
sadece bir sayfayı aktarıyor, bütün sayfalar için ayarlayabilir misiniz?
.

 

[ASLAN7410]

Sayın askm, yapmak istediğim 3 ayrı listeyi tek bir listeye düşürmek.

 

[Ziynettin]

Sayın askm, yazmış olduğunuz kod gayet güzel çalışıyor, elinize sağlık,
çok teşekkür ediyorum.

Ben bu kodu bir kaç sayfa için yapmaya çalıştığım zaman aktardığı yere
sadece bir sayfayı aktarıyor, bütün sayfalar için ayarlayabilir misiniz?
.

Sub listele()
Dim a(), b(), sh As Worksheet, j As Byte, görev As String
Dim i As Long, n As Long, Say As Long, son As Long
Dim y As Byte, z As Double
z = TimeValue(Now)
For j = 1 To Sheets.Count
    Set sh = Sheets(j)
    If Not sh.Name = "ÇALIŞMA" Then
        son = sh.Cells(Rows.Count, 3).End(3).Row
        a = sh.Range("B9:E" & son)
        For i = 1 To UBound(a)
            If a(i, 2) <> "" Then n = n + 1
        Next i
    End If
Next j

'*******************************
ReDim b(1 To n, 1 To [COLOR="Red"]5[/COLOR])
For j = 1 To Sheets.Count
    Set sh = Sheets(j)
    If Not sh.Name = "ÇALIŞMA" Then
        son = sh.Cells(Rows.Count, 3).End(3).Row
        a = sh.Range("B9:E" & son)
        [COLOR="Blue"]görev=""[/COLOR]
        For i = 1 To UBound(a)
            If Not IsNumeric(a(i, 1)) Then
                görev = a(i, 1)
            End If
            If a(i, 2) <> "" Then
                Say = Say + 1
                For y = 1 To [COLOR="red"]4[/COLOR]
                    b(Say, y) = a(i, y)
                Next y
                b(Say, [COLOR="red"]5[/COLOR]) = görev
            End If
        Next i
    End If
Next j

Sheets("ÇALIŞMA").Range("B2:F" & Rows.Count).ClearContents
Sheets("ÇALIŞMA").[B2].Resize(Say, [COLOR="red"]5[/COLOR]) = b
MsgBox "İşlem Tamam." & vbLf & vbLf & "İşlem sureniz :  " & _
        CDate(TimeValue(Now) - z), vbInformation
End Sub

 

[ASLAN7410]

Sayın Ziynettin Bey, ellerinize sağlık kod güzel çalışıyor, ancak sayfalardaki rütbe kısmını aktarmıyor.

 

[Ziynettin]

Gerekli düzeltmeler yapıldı. Tekrar deneyiniz.

 

[ASLAN7410]

Sayın Ziynettin Bey, kod sayfa1'i güzel aktarıyor, Sayfa2 ve Sayfa3'teki 1.ve 2. sıradaki
personelin karşısında herhangi bir görev yeri yazmıyor, bunları bu şekilde aktarması gerekiyor.

Butona bastığımda bu görevlilerin karşısına da görev yeri atıyor.

 

[Ziynettin]

Kodu tekrar deneyin. görev="" satırı eklendi.

 

[ASLAN7410]

Sayın Ziynettin Bey, maalesef istediğim sonucu alamadım.

 

[ASLAN7410]

Sayın Ziynettin Bey, ekte gönderdiğim excel dosyasında sizin yazmış olduğunuz kod var,
butona bastığımda istediğim sonucu alamıyorum.
.

 

[Ziynettin]

Kodu tekrar deneyiniz. görev="" kod satırını yanlış satıra yazılmışım.

 

[ASLAN7410]

Sayın Ziynettin Bey, şimdi oldu ellerinize sağlık, çok teşekkür ediyorum.

Hayırlı geceler, hayırlı çalışmalar diliyorum.