- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Günaydın Arkadaşlar
Kriterler Adlı Kullanıcı tanımlı makroyu kullanıyorum. Bilindiği üzere bu kod süzülen başlıkları bir hücrede göstermeye yarıyordu.
çalışma sayfamın 5,6 hücresine süzdüğüm sütunlara göre tanımlamaları yaptım.
vs.
ve bir hücrede birleştirdim.
süzme işlemi standarda yakın olduğu için bu işlemi bir userform yardımıyla yapıyorum. (mesela (Kira, aaa), (kira, bbb), (yatırım, aaa) (yatırım, bbb) gibi grupları süzüp ayrı yarı çıkartmam gerekiyor, bende kalpazanlıktan userform yardımı ile otomatiğe bağlamak istedim 
)
yeşil satırda belirtildiği üzere süzmew işlemini yapıyor, ancak hangi sütunun süzüldüğüne dair bilgileri vermiyor, ytani çıktının kira-aaa, kira-bbb, kira-ccc mi olduğunu yazmıyor.
ancak kodun çalışması bittikten sonra örneğin data sayfası b3 hücresine F2 ile girip enter'a basınca güncellemeyi yapıyor.
Özetle;
Yeşil satırdan önce b3e gir, enterla çık denebilir mi?
Kriterler Adlı Kullanıcı tanımlı makroyu kullanıyorum. Bilindiği üzere bu kod süzülen başlıkları bir hücrede göstermeye yarıyordu.
Kod:
Function Kriterler(BaslikAlti As Range) As String
Dim Filter As String: Filter = ""
Dim Filter2 As String: Filter2 = ""
On Error GoTo son
Application.Volatile
With BaslikAlti.Parent.AutoFilter
If Intersect(BaslikAlti, .Range) Is Nothing Then GoTo son
With .Filters(BaslikAlti.Column - .Range.Column + 1)
If Not .On Then GoTo son
Filter = Replace(.Criteria1, "=", """", 2)
Filter2 = Replace(.Criteria2, "=", """", 2)
Select Case .Operator
Case xlAnd: Filter = Filter & " ve " & Filter2
Case xlOr: Filter = Filter & " veya " & Filter2
End Select
End With
End With
son:
Kriterler = Filter
End Function
Kod:
=EĞER(VE(N1<>"";kriterler(I262)<>"");kriterler(I262)&" Giderleri";"Tüm Giderleri")ve bir hücrede birleştirdim.
Kod:
= O1 &"/"& O2 &EĞER(N1<>"";N1;"")&""&EĞER(N2<>"";"/"&N2;"")&""&EĞER(N3<>"";"/"&N3;"")
Kod:
'#########################################################################################################'
'#########################################################################################################'
'######### Raporla_ADOBB modülü ile oluşan Personel isimli çalışma sayfasından #########'
'######### [Personelin Adı Soyadı, Mali Yıl, Gider Türü, Masraf Mrkz] #########'
'######### başlıklarını Lvw_AdSoyad nesnesine alarak seçilen personeli, cmbYazici #########'
'######### nesnesindeki combodan textbox1 adet kadar yazdırır... #########'
'######### [URL="http://www.excel.web.tr/hsayar"]www.excel.web.tr/hsayar[/URL] 29/08/2008-12:30. #########'
'######### açılışta seçiliyor. #########'
'#########################################################################################################'
'#########################################################################################################'
Private i As Single
Private Sub UserForm_Activate() '##'
'UserformlardaEkOzellik prosodürü hsr.xla dan çalışmaktadır.
1 Call KlsrDgr '##'
2 Dim dsyIco$: dsyIco = klsrAddIns & AppPthSept & "Hsr_ico" & AppPthSept & "Print8.ico" 'icon yolu '##'
3 Call UserformlardaEkOzellik(Me, False, True, True, True, False, True, False, False, True, True _
, dsyIco) '##'
End Sub '##'
'######################################################################################################////
Private Sub UserForm_Initialize() '##'
'*\ Form denetimlerininin özelliklerini belirle '##'
CommandButton2.Cancel = True 'Userform üzerinde "ESC" ye basınca çıkışa izin ver. '##'
TextBox1 = 1: Cbx_AdSoyad.Caption = "Tüm Sayfaları Seç" '##'
With Lvw_AdSoyad '##'
.View = lvwReport: .LabelEdit = lvwManual '##'
.CheckBoxes = True 'Her elemana CheckBox oluşturur. '##'
.ColumnHeaders.Clear: .ListItems.Clear 'başlıkları ve öğeleri temizle '##'
.ColumnHeaders.Add , , "Bütçe Yılı", 100, lvwColumnLeft 'başlık ve genişliklerini ayarla '##'
.ColumnHeaders.Add , , "Malyt Yılı", 100, lvwColumnLeft
.ColumnHeaders.Add , , "Gider Türü", 100, lvwColumnLeft
.ColumnHeaders.Add , , "Masraf Merkezi", 100, lvwColumnLeft
End With 'Lvw_AdSoyad '##'
'*\ Değişken tanımlama ve set etme '##'
Dim Wsh As WshNetwork: Set Wsh = New WshNetwork '##'
'**\ Aktif Bilgisayardaki Yazıcı Listesini CmbYazici e alır '##'
With CmbYazici '##'
For i = 1 To Wsh.EnumPrinterConnections.Count - 1 Step 2 '##'
.AddItem Wsh.EnumPrinterConnections(i) '##'
Next '##'
'**\ Varsayılan yazıcıyı Combo1e atar '##'
.Value = FncHsr_VarsayilanYazici() '##'
End With 'CmbYazici '##'
'**\ Data sayfasının f5:f65536 aralığındaki benzersiz kayıtları cmb_bYIL sayfasıan getir.
Call Lvw_AdSoyad_guncelle '##'
'*\ Değişkenleri ve değerlerini hafızadan silme '##'
Set Wsh = Nothing: i = 0 '##'
End Sub '##'
Private Sub Lvw_AdSoyad_guncelle()
Dim wsTBL2 As Worksheet
Dim i%
Dim x
Set wsTBL2 = ThisWorkbook.Sheets("TABLOM2")
With Lvw_AdSoyad
.ListItems.Clear
For i = 2 To wsTBL2.Cells(65536, 1).End(xlUp).Row - 1
If wsTBL2.Cells(2, 1) <> "" Then
.ListItems.Add , , wsTBL2.Cells(i, 1)
With .ListItems(.ListItems.Count)
.SubItems(1) = wsTBL2.Cells(i, 2)
.SubItems(2) = wsTBL2.Cells(i, 3)
.SubItems(3) = wsTBL2.Cells(i, 4)
End With
End If
Next i
End With
Set wsTBL2 = Nothing
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) '##'
'Call UserForm_EnterKapa2 '##'
End Sub '##'
'######################################################################################################////
Private Sub CommandButton1_Click() '##'
1 Dim col As New Collection '##'
2 Dim wsData As Worksheet: Set wsData = ThisWorkbook.Sheets("DATA") '##'
3 Dim RngVeriSuz As Range '##'
4 With wsData '##'
5 SonSat = .Cells(65536, 2).End(3).Row '##'
6 Set RngVeriSuz = .Range("B4:P" & SonSat) '##'
7 End With '##'
'*\ Lvw_AdSoyadde Seçili olanları koleksiyona al ve sayısını tesbit et... '##'
8 With Lvw_AdSoyad '##'
9 For i = 1 To .ListItems.Count '##'
10 With .ListItems(i) '##'
11 If .Checked Then '##'
12 col.Add .Text '##'
13 col.Add .SubItems(1) '##'
14 col.Add .SubItems(2) '##'
15 col.Add .SubItems(3) '##'
16 End If '##'
17 End With '##'
18 Next i '##'
''*\ ... Eğer seçili olan sayfa yoksa prosodürden çık, ... '##'
19 If col.Count = 0 Then '##'
20 MsgBox "Seçili veri bulunamadı" '##'
21 Else '##'
22 Soru = CmbYazici.Value & " Yazıcısından " & col.Count / 4 & " adet personel analiz sayfasını " & _
TextBox1.Value & " -er/-ar adet Yazdırmak İstiyor musunuz?" '##'
23 If MsgBox(Soru, vbYesNo) = vbYes Then '##'
''*\ ... Listbox1 de seçili sayfaları CmbYazici deki yazıcıdan textbox1 deki kadar yazdır. '##'
24 For i = 1 To col.Count Step 4 '##'
25 RngVeriSuz.AutoFilter Field:=5, Criteria1:=col.Item(i + 0) '##'
26 If col.Item(i + 1) = "Tümü" Then
261 RngVeriSuz.AutoFilter Field:=6
262 Else
263 RngVeriSuz.AutoFilter Field:=6, Criteria1:=col.Item(i + 1) '##'
264 End If
27 RngVeriSuz.AutoFilter Field:=7, Criteria1:=col.Item(i + 2) '##'
28 RngVeriSuz.AutoFilter Field:=8, Criteria1:=col.Item(i + 3) '##'
wsData.Range("B3").Activate
'281 Application.Wait Now + TimeSerial(0, 0, 2)
29 [COLOR=green][B] wsData.PrintOut Copies:=TextBox1.Value, ActivePrinter:=CmbYazici.Value '##'
[/B][/COLOR]30 Next i '##'
31 End If '##'
32 End If '##'
33 End With 'Lvw_AdSoyad '##'
34 Set col = Nothing: Set RngVeriSuz = Nothing '##'
35 Unload Me '##'
End Sub
'######################################################################################################////
Private Sub Cbx_AdSoyad_Change()
'*\ Chekbox1 seçilince lw1 deki tüm kutular işaretlenir, seçim kaldırılırsa lw1 deki seçimde kaldırılır.'##'
With Lvw_AdSoyad '##'
For i = 1 To .ListItems.Count '##'
.ListItems(i).Checked = Cbx_AdSoyad.Value '##'
Next i '##'
End With 'Lvw_AdSoyad '##'
'*\ Kutucuklar işaretlenince iptal et yazısı, seçili değilken seç yazısı belirir... '##'
With Cbx_AdSoyad '##'
If .Value = True Then '##'
.Caption = "Seçimi İptal Et" '##'
Else '##'
.Caption = "Tüm Sayfaları Seç" '##'
End If '##'
End With 'Cbx_AdSoyad '##'
End Sub '##'
Private Sub CmbYazici_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
' If KeyCode = 13 Then CommandButton1_Click
End Sub
'######################################################################################################////
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub Label1_Click()
On Error Resume Next
ActiveWorkbook.FollowHyperlink Address:="[URL]http://www.excel.web.tr[/URL]", NewWindow:=True
End Sub
Private Sub SpinButton1_SpinDown()
If TextBox1 = 1 Then
TextBox1 = 1
Else
TextBox1 = Val(TextBox1) - 1
End If
End Sub
Private Sub SpinButton1_SpinUp()
TextBox1 = Val(TextBox1) + 1
End Sub
Private Sub SpinButton1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then CommandButton1_Click
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'Textboxın içinde yukarı ok tuşuna basınca değeri bir artır.
If KeyCode = 38 Then TextBox1 = Val(TextBox1) + 1: KeyCode = 0
'Textboxın içinde aşağı ok tuşuna basınca değeri bir azalt ama değer 1 in altına düşmesin.
If KeyCode = 40 Then
If TextBox1 = 1 Then
TextBox1 = 1: KeyCode = 0
Else
TextBox1 = Val(TextBox1) - 1: KeyCode = 0
End If
End If
'Textboxın içinde enter tuşuna basınca CommandButton1_Click olayını çalıştır.
If KeyCode = 13 Then CommandButton1_Click
End Sub
Private Sub Lvw_AdSoyad_KeyDown(KeyCode As Integer, ByVal Shift As Integer)
If KeyCode = 13 Then CommandButton1_Click
End Sub
[COLOR=red]'Not Kodların Sorunsuz Çalışabilmesi için pcnizde hsr.xla mevcut olmalıdır![/COLOR]ancak kodun çalışması bittikten sonra örneğin data sayfası b3 hücresine F2 ile girip enter'a basınca güncellemeyi yapıyor.
Özetle;
Yeşil satırdan önce b3e gir, enterla çık denebilir mi?
