• DİKKAT

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

Servis _Guzergah Tablosu Destek

A

ayhan3477

Katılım
11 Aralık 2010
Mesajlar
39
Excel Vers. ve Dili
2003
Arkadaslar,
tabloyu bir arkadaşımızın büyük desteği ile formülle yaptık ancak teknik olarak çok bekletyor, farklı görüşler içn Yardımlarınızı rica ediyorum ( makro ? )

şirketimizde vardiyaya kalacak personel için servis listelerinin otomatik oluşmasını isityorum, bunun için ek te yer alan dosyayı sunuyorum

1. bu sayfada birim(c4) seçildiğinde aşağıdaki listede yalnızca o birim çalışanlarının listelenmesi ( ada göre sıralı combo liste?)

2. b7... de kişiyi seçtiğimde e7- I7 arası bilgilerin sayfa 2 de girilen değerlerden otomatik olarak tasınması ( bir kişinin bir kez seçilebilmesi ?)

3. gelen numerik guzergah koduna göre de J7-T7 arasında ki denk gelen hucreye X değer ataması yapılması

4. Tüm grubun mesaiye kalacağı varsayılarak Tamamı diye bir seçenek olursa
(tuş) basıldığında birimde ne seçili ise tüm listeyi ayfa 2 den taşıması ?

Arkadaşlar yardımlarınızır rica ediyorum, teşekkürler, esenkalın.


tesekkurler
 

Ekli dosyalar

yardım ? Arkadaşlar yok mu fikir verebilecek, yardım sağlayabilecek bir üstad ?
 
Son düzenleme:
üstadlar makro ile bu işin içinden çıkılmaz mı ? yardım rica ediyorum
 
ikinci sayfa için konuşursak;
"Bu Sayfada E sutununa Evet \ Hayır, Hayır seçilirse FGH ve I sutununa veri girişine izin vermeme"

FGHI sütunlarından veri girişi yapılacak tüm satırları tarayın. Örnek: F2:I500

data - validation - settings:

Allow: seçeneğinde custom seçin
formula: kısmında =$E2="Evet" yazın.

eğer E sütunundaki değer evet değil ise FGHI sütunlarına giriş yaptırmayacaktır.


birinci sayfa için konuşursak:
tanımlı alanlarınıza görmek istediğimde sheet için #ref! hatası veriyor. tanımlı alanların bulunduğu ilave bir sayfa var mıydı?
 
A.R.Olsun

eywallah usatdım ya cok tesekkur ettim,
emegine sağlık...

1. bilgi superdi :) işim,i gordu
ama esas olayı basında sıkıntım var tabloyu bir daha paylaşıyorum ..
teşekkürlerrr ustad
 

Ekli dosyalar

estağfurullah. bana üstad denilirse, gerçek üstadlara ayıp olur.

ekteki dosya işinizi görür umarım. deneme yanılma ile yaptım.



aynı ismin mükerrer girilmemesi:
personel ismi data validation ile geldiği için aynı hücreye birden fazla kriter tanımlama imkanı benim bildiğim kadarı ile bulunmuyor. yani yukarıda birim yazdığında sadece o birimin çalışanlarının listelenmesi sağlandığı için ikinci bir kriter ile mükerrerlik engellemesi yapılamıyor. tabii bu benim bilgimle sınırlı olup üstadlar, var ise, hatamı düzeltirler ise sevinirim.

makro 3. satırdaki J ve T sütunları arasındaki servis güzergah numaralarına ve 6. sütundaki koda göre çalışmaktadır. satır veya sütun eklemek isterseniz Sayfa1'deki kodları da buna göre düzeltmeniz gerekir.

Kod: 
If Target.Column <> 6 Then Exit Sub
If Target.Row < 4 Then Exit Sub
Kod: 
Range(Cells(Target.Row, "J"), Cells(Target.Row, "T")).ClearContents

alanlar sayfası:
- birim bazında çalışanların gerçek isimlerini yazın.
- birim eklemek ve silmek mümkün. ancak bunu yapınca
insert -> name -> define adımlarından sildiğiniz birimin ismini seçerek buradan da silin. eklediğiniz birimler olur ise buradan tanımlama yapın.
- güzergah için alan tanımlandı. güzergah eklemek isterseniz yine Güzergah isimli alanın =alanlar!$I$4:$J$14 olan değerini insert -> name -> define adımlarından düzeltin.
- başka tanımlı alan eklemeniz gerektiğinde (birim değilse) 2. satırdan başlayarak tanımlayın.
 

Ekli dosyalar

:)

benim için üstadsınız desem fazla olmaz açıkçası

siz bana bunu yazdığınızda bende tabloyu başka şekilde çözdüm ancak 1-2 küçük sorunum var

1. bakım grubunu sayfa 1 de seçtiğimde combo listesi açılmıyor... çözemedim
2. 23 kişiden fazla combolarda 24. kişi listeye gelmiyor
3. birim olarak sayfa 1 de montajı seçtiğimde adı soyadı alanlarını otomatik dolduracak bir (tamamını seç) ve tamamını temizle gibi bir yetenekli :) buton koyabilirmiyiz ...

elinize sağlık sizin tabloyuda inceliyorum... tablomu 5 numarayla ekledim.
teşekkür ediyorum
ayhan
 

Ekli dosyalar

1- combo'da scroll bar ile yukarı doğru çıkınız.
2- insert - name define (2007 kullanıyorsanız name manager) ile tüm tanımlı alanları listeleyin. tek tek üstlerine gelerek refers to: da hangi satıra kadar gidiyorsa liste ona göre düzeltin.
3- mümkün mutlaka ama benim hemen cevap verebileceğim bir şey değil.
 
Çok Teşekkür Ediyorum

Üstad Allah Razı Olsun
sorunu çözdüm sayenizde

tek konu kaldı toplu doldurma ve silme hususu.. inşallah çözeceğiz.

Tekrar teşekkürler.. Sağolun..
 
1. Numaralı sorun

1.sorun devam ediyor arkadaşlar,

sayfa 1 de bakım onarım ı seçtiğimde adı soyadı alanında liste çıkmıyor ?

bir onceki mesajımdaki 3. nolu konuya çözüm onerebilecek ustad var mı ?

dosyanı son hali ekte ..

teşekkürler
 

Ekli dosyalar

Bölüm dağılım sayfasına gidin. A1 hücresindeki Bakım Grubu ifadesini Bakım_Grubu olarak düzeltin.
 
3. konu.

ana giriş tablosu sayfasında bir düğme ekleyin.

aşağıdaki kodu standart bir makro modülüne (vba penceresinde iken, insert -> module) kopyalayın.

düğmeye bu kodu atayın.

şöyle bir sorun var: ana sayfanız 70 personele göre düzenlenmiş. 100den fazla çalışanı olan birimler var. bu nedenle son satır (ss) değişkenini kullanmadım. doğrudan ilk bulduğu 70 satırı B7'den başlayarak kopyalayacak. ben denedim bir problem olmadı ama yedek bir dosya üzerinden deneyiniz.

Kod: 
Sub blm_pers_kopyala()

Dim rBul As Range, birim As String, ss As Long

Sheets("Ana Giriş Tablosu").Activate
Range("B7:B76").ClearContents
birim = Range("C4").Text

With ActiveSheet
    Set rBul = Sheets("Bölüm Dağılım").Rows(1).Find(What:=birim, After:=Cells(1, 1), _
    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With

If Not rBul Is Nothing Then
    Sheets("Bölüm Dağılım").Select
    'ss = Sheets("Bölüm Dağılım").Cells(Rows.Count, rBul.Column).End(3).Row
    Range(Cells(2, rBul.Column), Cells(71, rBul.Column)).Select
    Selection.Copy
    Sheets("Ana Giriş Tablosu").Select
    Range("B7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C4").Select
    Application.CutCopyMode = False
End If

End Sub
 
mancubus' Alıntı:
3. konu.

şöyle bir sorun var: ana sayfanız 70 personele göre düzenlenmiş. 100den fazla çalışanı olan birimler var. bu nedenle son satır (ss) değişkenini kullanmadım. doğrudan ilk bulduğu 70 satırı B7'den başlayarak kopyalayacak. ben denedim
Genişletmek için tıkla ...

pardon. sayfanız devam ediyormuş.
yukarıdaki mesajda yer alan kod yerine aşağıdaki kodu kullanınız.

Kod: 
Sub blm_pers_kopyala()

Dim rBul As Range, birim As String, ss As Long

Sheets("Ana Giriş Tablosu").Activate
Range("B7:B76").ClearContents
Range("B89:B158").ClearContents

birim = Range("C4").Text
Range("B89").Value = Range("C4")

With ActiveSheet
    Set rBul = Sheets("Bölüm Dağılım").Rows(1).Find(What:=birim, After:=Cells(1, 1), _
    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With

If Not rBul Is Nothing Then
    Sheets("Bölüm Dağılım").Select
    ss = Sheets("Bölüm Dağılım").Cells(Rows.Count, rBul.Column).End(3).Row
    Range(Cells(2, rBul.Column), Cells(71, rBul.Column)).Select
    Selection.Copy
    Sheets("Ana Giriş Tablosu").Select
    Range("B7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C4").Select
    Application.CutCopyMode = False

    Sheets("Bölüm Dağılım").Select
    ss = Sheets("Bölüm Dağılım").Cells(Rows.Count, rBul.Column).End(3).Row
    Range(Cells(72, rBul.Column), Cells(ss, rBul.Column)).Select
    Selection.Copy
    Sheets("Ana Giriş Tablosu").Select
    Range("B89").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C4").Select
    Application.CutCopyMode = False

End If

End Sub
 
3. numara

Allah Razı Olsun Tekrar Ustad..

1. numara ok. :)
3. numarada butonu ekledim ama hata veriyor, dosyanın son halini ekledim.
yardımcı olabilriseniz. sevinirim.

Hakkınızı Helal Edin lütfen.
 

Ekli dosyalar

merhaba.

çalışmaz çünkü...

- benim verdiğim kodlar eski sayfa dizaynına göreydi. şimdi satır sayıları değişmiş. silinen satırlar olmuş.
- kodu activex kontrola tanımlayarak kod içinde kod yazılmış.

Private Sub CommandButton1_Click()
Sub blm_pers_kopyala()

'kodlar

End Sub
End Sub

- Private Sub Worksheet_Change(ByVal Target As Range) kodu var. bu kod ile, sayfada değişiklik olduğu takdirde, kodlar çalışarak bazı eylemler yapar. bu eylemler mecvut sayfa yapınızla uyumlu değil. zannediyorum kullanmayacaksınız da.

- benim eklediğim kodlarda da personel sayısının 65'ten az olduğu birimler için ss nedeniyle ufak bir hata var. (düzeltildi)

önerim.

Ana Giriş Tablosu sayfası içinde iken menu barda sağ klik ile control toolbox'ı seçin. üçgen cetvel şeklindeki tasarım modu butonunu tıklayın. sayfadaki "command button" düğmesini tıklayarak aktif hale getirin ve "del" tuşu ile silin. control toolbox'ı x tıklayarak kapatın.

VBA penceresinde Ana Giriş Tablosu tıklatın. buradaki tüm kodları silin.

VBA penceresinde Module1'i tıklayarak sağ pencereye aşağıdaki yeni sayfa düzeninize göre revize ettiğim kodları kopyalayın.

Ana Giriş Tablosu sayfası içinde iken menu barda sağ klik ile forms'u seçin. üzerinde tıklayıp sayfaya geçerek "button" ekleyin. otomatik assign macro penceresi açılacaktır. macros in'den this workbook seçerek gelen pencereden aşağıdaki makronun ismini seçin.

çalıştığını göreceksiniz.

yapılmış halini ben ekliyorum.



Kod: 
Sub blm_pers_kopyala()

Dim rBul As Range, birim As String, ss As Long

Sheets("Ana Giriş Tablosu").Activate
Range("B7:B71").ClearContents
Range("B85:B149").ClearContents

birim = Range("C4").Text

With ActiveSheet
    Set rBul = Sheets("Bölüm Dağılım").Rows(1).Find(What:=birim, After:=Cells(1, 1), _
    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With

If Not rBul Is Nothing Then
    Sheets("Bölüm Dağılım").Select
    ss = Sheets("Bölüm Dağılım").Cells(Rows.Count, rBul.Column).End(3).Row
    Range(Cells(2, rBul.Column), Cells(66, rBul.Column)).Select
    Selection.Copy
    Sheets("Ana Giriş Tablosu").Select
    Range("B7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C4").Select
    Application.CutCopyMode = False

    Sheets("Bölüm Dağılım").Select
    ss = Sheets("Bölüm Dağılım").Cells(Rows.Count, rBul.Column).End(3).Row
    Range(Cells(67, rBul.Column), Cells(131, rBul.Column)).Select
    Selection.Copy
    Sheets("Ana Giriş Tablosu").Select
    Range("B85").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C4").Select
    Application.CutCopyMode = False
End If

ActiveSheet.Calculate

End Sub
 

Ekli dosyalar

dosyanızı önce save etmek sonra bölüm ismine göre save as etmek için End Sub dan önce gelmek üzere aşağıdaki kodları ekleyebilirsiniz.

Kod: 
ThisWorkbook.Save

Dim klsr As String
Dim isim As String

klsr = [COLOR="Red"]"C:\Dosyalar\"[/COLOR]
isim = Range("C4").Text
On Error GoTo 0

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=klsr & isim & " - " & Format(Now, _
    "dd.mm.yyyy hh.mm.ss") & ".xls", FileFormat:=-4143, Password:=""
Application.DisplayAlerts = True

C:\Dosyalar\ bölümünü kendi klasörünüze göre düzeltin. en sondaki "\" seperatörü unutmayın.

dosya isminde tarih saat çıkmasın derseniz "Format(Now, "dd.mm.yyyy hh.mm.ss") & kısmını silebilirsiniz.
sadece tarih olsun derseniz Format(Now, "dd.mm.yyyy") olarak düzeltin.
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst