EXCEL Size Yeter

Ücretlendirme

Ücretlendirme tarifelerimiz aşağıda yer almaktadır.

Kurumsal Eğitimler

Kurumsal eğitimler için kişi başına 750 TL alınmaktadır. Bu eğitimler 4 hafta olup günlük 4 saatten toplam 32 saattir.

Özel Dersler

Özel derslerde saatlik ücret 80 TL olup standart eğitimlerde 3 saati 150 TL’dir.

Projeler

Projeler için herhangi bir ücret tarifesi olmayıp projenin büyüklüğüne göre fiyatlar değişmektedir.

Günlük İşlerin Kolaylaştırılması Amaçlı Çalışmalar

Günlük işlerin kolaylaştırılması amacıyla hazırlanan programlar ve dosyalarda talep eden kişinin bir günlük maaşını geçmemeye dikkat etmekteyiz.

Çeşitli Soruların Cevaplandırılması

Basit sorularınız varsa ve “Acaba bu nasıl yapılıyordu” şeklinde sorularınız olacaksa, mail yoluyla sorulması şartıyla ücretsiz cevaplandırılır.

hücreleri seçer. Cells.Select 33- Dolu hücrelerden sonraki ilk boş hücreyi seçer. (Sütunlar için.) Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select '(0,1) olduğu zaman satırlar için olur. Loop Eğer A1 Hücresi 1 ise Mesaj kutusu çalışsın ve excelpazarı yazsın Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = ""$A$1"" Then If Target.Value = ""1"" Then MsgBox ""ExcelPazarı"" End If End Sub Örneğin 4. sütunda İşlem yapılırsa macro otomatik çalışsın Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Column = 4 Then MsgBox ""Aşkın'dan Selamlar"" End Sub Örneğin 4. Satırta İşlem yapılırsa macro otomatik çalışsın Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Row = 4 Then MsgBox ""Aşkından Selamlar"" End Sub Eğer A1 Hücresi sıfırdan büyükse macro çalışsın. Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Range(""A1"") >= 1 Then MsgBox ""Aşkından Selamlar"" End Sub Eğer A1 Hücresinin Değeri A3 Hücresindeki değerden düşükse macro çalışsın Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = ""$A$1"" Or Target.Address = ""$A$3"" Then If Range(""A1"").Value < Range(""A3"").Value Then Macro1 End If End If End Sub YAZILAN AÇIKLAMAYI GÖSTERİR (selam) Sub Macro1() MsgBox ""Selam"" End Sub Eğer A1 Hücresinde işlem yapılırsa A2 Hücresine değiştirilme tarihi ve saatini yazar Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target = Cells(1, 1) Then Cells(2, 1) = Now End Sub 'alternatif ŞİMDİ() or Bugün or Time SATIR SÜTUN GİZLEME İŞLEMLERİ EĞER AKTİF HÜCRE DEĞERİ 1 DEN BÜYÜK İSE AKTİF HÜCRENİN ALTINA BOŞ SATIR EKLER Sub InserLSiRupture() Set x = ActiveCell Do Until IsEmpty(x) If x.Row > 1 Then If x.Offset(-1, 0).Value <> x.Value Then Rows(x.Row).Insert Shift:=xlDown End If End If Set x = x.Offset(1, 0) Loop End Sub Bir önceki işlem yapılan hücreyi seç Sub LastCell() Selection.SpecialCells(xlLastCell).Select End Sub Boş Hücreleri Seç Sub boshucresec() Selection.SpecialCells(xlCellTypeBlanks).Select End Sub Eğer aktif hücreler nümerik (sayı) ise ve 500 den büyükse kalın yap Sub aktiflestir() If IsNumeric(ActiveCell) Then ActiveCell.Font.Bold = ActiveCell.Value >= 500 End If End Sub EĞER C1 HÜCRESİ BOŞSA C4 HÜCRESİNİ BOŞALT BOŞ DEĞİLSE C1 HÜCRESİNDEKİ DEĞERİ YAZI Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = ""$C$4"" And Target.Value = ""Y"" Then Target.Value = Range(""C1"").Value End If End Sub " Karma Örnekler "1- Hücre Seçmek. 1- Range(""B2"").Select 2- Cells(2,1).Select 3- [B2].Select 2- Hücreye değer atamak. Range(""B2"").Value=100 'sayısal değer Range(""B2"").Value=""pir"" 'Text; tırnak içinde 3- Hücredeki Fontun Büyüklüğünü değiştirmek. Range(""B2"").Font.Size=20 4- Hücredeki fontun adını değiştirmek. Range(""B2"").Font.Name=""Verdana"" 5- Hücredeki fontu Kalın,İtalic ve Altı Çizgili yapmak. Range(""B2"").Font.Bold = True Range(""B2"").Font.Italic = True Range(""B2"").Font.Underline = xlUnderlineStyleSingle ve yahut Range(""B2"").Select Selection.Font.Bold = True Selection.Font.Italic = True Selection.Font.Underline = xlUnderlineStyleSingle 6- Hücrenin dolgu rengini değiştirmek. Range(""B2"").Interior.ColorIndex = 6 'Sarı renk 7- Hücrenin Fontunun rengini değiştirmek. Range(""B2"").Font.ColorIndex = 3 'Kırmızı renk 8- Hücreye Formül yazdırmak. Range(""B2"").Formula=""=A1+A2""'A1 ve A2 hücresini toplar,B2 ye yazdırır. 9- Aktif olan hücrenin etrafındaki hücreyi seçmek ActiveCell.Offset(1, 0).Select 'Aktif hücrenin altıdakini seçer. ActiveCell.Offset(-1, 0).Select 'Aktif hücrenin üstündekini seçer. ActiveCell.Offset(0, 1).Select 'Aktif hücrenin sağındakini seçer. ActiveCell.Offset(0, -1).Select 'Aktif hücrenin solundakini seçer. 10- Aktif olan hücrenin belirtilen kadar uzağındaki hücreyi seçmek. ActiveCell.Offset(0, 5).Select 'Aktif hücrenin sağındaki 5. hücreyi seçer. 11- Aktif hücreden belirtilen uzaklıktaki hücreye değer atamak. ActiveCell.Offset(1,1).Value = ""Muhammed"" 'Aktif hücrenin altında ve sağındaki hücreye Muhammed yazdırır. 12- Aktif hücrenin üzerindeki iki hücrenin değerleri toplanır ve sonuç aktif olan hücreye yazılır. Sub toplama() t1 = ActiveCell.Offset(-1, 0).Value t2 = ActiveCell.Offset(-2, 0).Value ActiveCell.Value = t1 + t2 End Sub 13- Seçili hücrelerdeki biçimleri siler. Selection.ClearFormats 14- Seçili hücreleri aşağı öteler. Range(""A1:A5"").Select 'A1 ile A5 arasındaki hücreler seçilir. Selection.Insert Shift:=xlDown 'Seçimi aşağı kaydırır. Burada sadece seçili olan 5 adet hücre aşağı kaydırılır. 15- Seçili hücrelere ait hüm satırı ötelemek. Range(""A1:A5"").Select Selection.EntireRow.Insert '14. koddan farklı olarak seçili olan hücrelere ait 1 ila 5 arasındaki tüm satırlar 5 satır aşağı ötelenir. 16- Seçili hücrelere ait tüm sütunu ötelemek. Range(""D6:E7).Select selection.EntireColumn.Insert 17- Açık olan Excel Çalışma Kitabının belirtilen sayfasındaki istenen hücreye değer atar. Workbooks(""Kitap1.xls"").Worksheets(""Sayfa1"").Range(""A1"").Value = 3 18- Yapılan seçimlerde boş olmayan hücre sayısını verir. Sub hucresayisi() Dim kontur As Integer kontur = Application.CountA(Selection) MsgBox ""Seçimdeki dolu hücrelerin sayısı:"" & kontur End Sub 19- 18. maddedeki kodlamada 'CountA' da bulunan 'A' kaldırılırsa seçimde sadece kaç hücrede sayı (rakam) varsa onların adedini verir. Application.Count(Selection) 20- Seçili hücrelerin sayısını verir. Selection.Count 21- Seçimin satır sayısını verir. Selection.Rows.Count 22- Seçimin sütun sayısını verir. Selection.Columns.Count 24- Seçili hücrenin altında veriler varsa onları seçer. İlk boş hücreden sonra ilk değer olan hücreyi seçer. Range(ActiveCell,ActiveCell.End(xlDown)).Select 25- 24. de üstteki hücreler için aynı ilemi yapar. Range(ActiveCell,ActiveCell.End(xlUp)).Select 26- 24. de sağdaki hücreler için aynı işlemi yapar. Range(ActiveCell,ActiveCell.End(xlToRight)).Select 27- 24. de soldaki hücreler için aynı işlemi yapar. Range(ActiveCell,ActiveCell.End(xlToLeft)).Select 28- Aktif hücrenin etrafındaki dolu hücreleri seçer. ActiveCell.CurrentRegion.Select 29- Seçimin etrafındaki dolu hücreleri seçer. Selection.CurrentRegion.Select ActiveCell.EntireColumn.Select 31- Seçili hücrelerin bulundukları sütunları tamamen seçer. Selection.EntireColumn.Select 30- Aktif hücrenin bulunduğu satırı tamamını seçer. ActiveCell.EntireRow.Select 31- Seçili hücrelerin bulundukları satırları tamamen seçer. Selection.EntireRow.Select 32- Çalışma sayfasında bulunan bütün hücreleri seçer. Cells.Select 33- Dolu hücrelerden sonraki ilk boş hücreyi seçer. (Sütunlar için.) Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select '(0,1) olduğu zaman satırlar için olur. Loop Eğer A1 Hücresi 1 ise Mesaj kutusu çalışsın ve excelpazarı yazsın Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = ""$A$1"" Then If Target.Value = ""1"" Then MsgBox ""ExcelPazarı"" End If End Sub Örneğin 4. sütunda İşlem yapılırsa macro otomatik çalışsın Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Column = 4 Then MsgBox ""Aşkın'dan Selamlar"" End Sub Örneğin 4. Satırta İşlem yapılırsa macro otomatik çalışsın Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Row = 4 Then MsgBox ""Aşkından Selamlar"" End Sub Eğer A1 Hücresi sıfırdan büyükse macro çalışsın. Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Range(""A1"") >= 1 Then MsgBox ""Aşkından Selamlar"" End Sub Eğer A1 Hücresinin Değeri A3 Hücresindeki değerden düşükse macro çalışsın Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = ""$A$1"" Or Target.Address = ""$A$3"" Then If Range(""A1"").Value < Range(""A3"").Value Then Macro1 End If End If End Sub YAZILAN AÇIKLAMAYI GÖSTERİR (selam) Sub Macro1() MsgBox ""Selam"" End Sub Eğer A1 Hücresinde işlem yapılırsa A2 Hücresine değiştirilme tarihi ve saatini yazar Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target = Cells(1, 1) Then Cells(2, 1) = Now End Sub 'alternatif ŞİMDİ() or Bugün or Time SATIR SÜTUN GİZLEME İŞLEMLERİ EĞER AKTİF HÜCRE DEĞERİ 1 DEN BÜYÜK İSE AKTİF HÜCRENİN ALTINA BOŞ SATIR EKLER Sub InserLSiRupture() Set x = ActiveCell Do Until IsEmpty(x) If x.Row > 1 Then If x.Offset(-1, 0).Value <> x.Value Then Rows(x.Row).Insert Shift:=xlDown End If End If Set x = x.Offset(1, 0) Loop End Sub Bir önceki işlem yapılan hücreyi seç Sub LastCell() Selection.SpecialCells(xlLastCell).Select End Sub Boş Hücreleri Seç Sub boshucresec() Selection.SpecialCells(xlCellTypeBlanks).Select End Sub Eğer aktif hücreler nümerik (sayı) ise ve 500 den büyükse kalın yap Sub aktiflestir() If IsNumeric(ActiveCell) Then ActiveCell.Font.Bold = ActiveCell.Value >= 500 End If End Sub EĞER C1 HÜCRESİ BOŞSA C4 HÜCRESİNİ BOŞALT BOŞ DEĞİLSE C1 HÜCRESİNDEKİ DEĞERİ YAZI Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = ""$C$4"" And Target.Value = ""Y"" Then Target.Value = Range(""C1"").Value End If End Sub " Karşılama (açılış makrosu) "Private Sub Workbook_Open() Dim Utilis As String Dim DateJour As Date 'Récupération du nom de l'utilisateur Utilis = Application.UserName 'Récupération de la date du jour DateJour = Date Msgbox ""Selamün Aleyküm "" & Utilis & Chr(10) & _ ""Nous sommes le "" & DateJour End Sub" Karşılaştırma; sayfa1 sayfa2 a,b,c sütunları "Sub Karsilastir1() Dim Sh1 As Worksheet, Sh2 As Worksheet Dim Bul As Range, Soyad, i Dim ilkAdres Set Sh1 = Worksheets(""Sayfa1"") Set Sh2 = Worksheets(""Sayfa2"") For i = 2 To Sh2.Cells(65536, ""C"").End(xlUp).Row Soyad = Sh2.Cells(i, 3) Set Bul = Sh1.Range(""C:C"").Find(Soyad, LookAt:=xlWhole) If Not Bul Is Nothing Then ilkAdres = Bul.Address Do If Sh2.Cells(i, 2) = Bul.Offset(, -1) Then Bul.Offset(, 1) = ""Bulundu"" End If Set Bul = Sh1.Range(""C:C"").FindNext(Bul) Loop Until ilkAdres = Bul.Address End If Next End Sub" Kaydederek çıkış "Sub kaydet_cik() ThisWorkbook.Close Saved = True End Sub" Kaydederken a1 e tarih ve saatini yazar "Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Range(""A1"") = Now 'Select any cell you want End Sub" Kaydederken mesaj verdirme "Private Sub Workbook_BeforeSave _ (ByVal SaveAsUI As Boolean, Cancel As Boolean) pir = _ MsgBox("" Gerçekten kadetmek istiyor musunuz?"", _ vbYesNo) If pir = vbNo Then Cancel = True End Sub" Kaydedince a1 e tarihli kaydeder sol alt bilgi olarak ta ekler "Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Range(""A1"").Value = ""Stand: "" & Format(Date, ""DD.MM.YYYY"") Worksheets(""Tabelle1"").PageSetup.LeftFooter = ""Stand: "" & Format(Date, ""DD.MM.YYYY"") End Sub" Kaydet,temİzle ve tamamen kapat "Sub Makro1() Range(""A1:C20"").ClearContents ActiveWorkbook.Save Application.Quit End Sub " Kaydetmeden çıkış "Sub Ohne_Speichern_schliessen() ThisWorkbook.Close Saved = True 'oder ThisWorkbook.Close False End Sub" Kaydetmeden çıkış "Sub close() ThisWorkbook.Close Saved = True End Sub" Kaydetmeden kapatma "Sub DateiSchließen() ActiveWorkbooks.Close SaveChanges:=False End Sub" Kaydetmeden önce şifre isteme "Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) a = InputBox(""Kaydetmek için şifrenizini girin"") If a <> 1234 Then Cancel = True End If End Sub" Kayit engelenebİlİr mİ? "Thisworkbook'a aşağıdaki kodları ekleyin Private Sub Workbook_BeforePrint(Cancel As Boolean) If Sheets(""Sayfa1"").Range(""M56"") = """" Then MsgBox (""Yazdırılamıyor !"" & vbNewLine & _ ""M56 hücresini boş bırakamazsınız."") Cancel = True End If End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If Sheets(""Sayfa1"").Range(""M56"") = """" Then MsgBox (""Kaydedilemiyor!"" & vbNewLine & _ ""M56 hücresini boş bırakamazsınız."") Cancel = True End If End Sub" Kdv hesaplatma " Private Sub Command1_Click() Dim a, sonuc As Integer a = InputBox(""ÜCRETİ GİRİNİZ"") If a > 0 Then sonuc = a * 1.18 MsgBox sonuc End If End Sub" Kdv hesaplatma 2 "Private Sub Command1_Click() Dim a, sonuc As Integer a = InputBox(""ÜCRETİ GİRİNİZ"") If a > 0 Then sonuc = a * 1.18 MsgBox sonuc End If End Sub" Kelimeler arasında 1 space boşluğu bırakır "Sub BereichGlaetten() Dim r As Range, c As Range On Error Resume Next Set r = Application.InputBox(""Bereich markieren, der geglättet werden soll: "", Type:=8) For Each c In r.Cells c.Value = Application.WorksheetFunction.Trim(c.Value) Next c End Sub" Kenarlık penceresi "Sub Dialog_08() Application.Dialogs(xlDialogBorder).Show End Sub" Kendi kendine kapanan kitap 10 sn de "Thisworkbooka Private Sub Workbook_BeforeClose(Cancel As Boolean) Zurücksetzen End Sub Private Sub Workbook_Open() startzeit End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) startzeit End Sub 'Modüle Dim DaA As Date Sub startzeit() On Error Resume Next Application.OnTime EarliestTime:=DaA, Procedure:=""Schließen"", Schedule:=False DaA = Now + CDate(""0:00:10"") Application.OnTime DaA, ""Schließen"" End Sub Sub Schließen() ThisWorkbook.Close True End Sub Sub Zurücksetzen() Application.OnTime EarliestTime:=DaA, Procedure:=""Schließen"", Schedule:=False End Sub" Kendi kendine kapanan kitap 10 sn de mÜkemmel "Thisworkbooka Private Sub Workbook_Open() DaZeit = ""0:00:10"" ThisWorkbook.Worksheets(""Tabelle1"").Range(""A1"") = CDate(DaZeit) Zeitmakro End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error Resume Next Application.OnTime EarliestTime:=VaEt, Procedure:=""Zeitmakro"", Schedule:=False End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) ThisWorkbook.Worksheets(""Tabelle1"").Range(""A1"") = DaZeit End Sub 'Modüle Sub Zeitmakro() ' ThisWorkbook.Worksheets(""Tabelle1"").Range(""A1"") = ThisWorkbook.Worksheets(""Tabelle1"").Range(""A1"") - CDate(""00:00:01"") If ThisWorkbook.Worksheets(""Tabelle1"").Range(""A1"") <> 0 Then VaEt = Now + TimeValue(""00:00:01"") Application.OnTime VaEt, ""Zeitmakro"" Else ThisWorkbook.Close True 'speichern ' Meldung bei Excel immer in Vordergrund ' Dim mldg ' mldg = MsgBox(""Endzeit erreicht"", 1048576, ""Endzeit"") ' 1048576 entspricht vbMsgBoxRtlReading End If End Sub" Kes kopyalayı iptal etmek & aç " Kullanıcıların çalışma kitabını açtıklarında kesme/kopyalama ve yapıştırma komutlarını kullanamaz. Sub DisableCutAndPaste() EnableControl 21, False ' cut EnableControl 19, False ' copy EnableControl 22, False ' paste EnableControl 755, False ' pastespecial Application.OnKey ""^c"", """" Application.OnKey ""^v"", """" Application.OnKey ""+{DEL}"", """" Application.OnKey ""+{INSERT}"", """" Application.CellDragAndDrop = False End Sub ' BU KOD KISITLAMALARI AKTİF YAPAR Sub EnableCutAndPaste() EnableControl 21, True ' cut EnableControl 19, True ' copy EnableControl 22, True ' paste EnableControl 755, True ' pastespecial Application.OnKey ""^c"" Application.OnKey ""^v"" Application.OnKey ""+{DEL}"" Application.OnKey ""+{INSERT}"" Application.CellDragAndDrop = True End Sub Sub EnableControl(Id As Integer, Enabled As Boolean) Dim CB As CommandBar Dim C As CommandBarControl For Each CB In Application.CommandBars Set C = CB.FindControl(Id:=Id, recursive:=True) If Not C Is Nothing Then C.Enabled = Enabled Next End Sub " Kes kopyalayi İptal et & aÇ " Kullanıcıların çalışma kitabını açtıklarında kesme/kopyalama ve yapıştırma komutlarını kullanamaz. Sub DisableCutAndPaste() EnableControl 21, False ' cut EnableControl 19, False ' copy EnableControl 22, False ' paste EnableControl 755, False ' pastespecial Application.OnKey ""^c"", """" Application.OnKey ""^v"", """" Application.OnKey ""+{DEL}"", """" Application.OnKey ""+{INSERT}"", """" Application.CellDragAndDrop = False End Sub ' BU KOD KISITLAMALARI AKTİF YAPAR Sub EnableCutAndPaste() EnableControl 21, True ' cut EnableControl 19, True ' copy EnableControl 22, True ' paste EnableControl 755, True ' pastespecial Application.OnKey ""^c"" Application.OnKey ""^v"" Application.OnKey ""+{DEL}"" Application.OnKey ""+{INSERT}"" Application.CellDragAndDrop = True End Sub Sub EnableControl(Id As Integer, Enabled As Boolean) Dim CB As CommandBar Dim C As CommandBarControl For Each CB In Application.CommandBars Set C = CB.FindControl(Id:=Id, recursive:=True) If Not C Is Nothing Then C.Enabled = Enabled Next End Sub " Kesme, kopyala, yapıştır etkin "Sub EnableCutAndPaste() EnableControl 21, True ' cut EnableControl 19, True ' copy EnableControl 22, True ' paste EnableControl 755, True ' pastespecial Application.OnKey ""^c"" Application.OnKey ""^v"" Application.OnKey ""+{DEL}"" Application.OnKey ""+{INSERT}"" Application.CellDragAndDrop = True End Sub" Kesme, kopyala, yapıştır iptal "Sub DisableCutAndPaste() EnableControl 21, False ' cut EnableControl 19, False ' copy EnableControl 22, False ' paste EnableControl 755, False ' pastespecial Application.OnKey ""^c"", """" Application.OnKey ""^v"", """" Application.OnKey ""+{DEL}"", """" Application.OnKey ""+{INSERT}"", """" Application.CellDragAndDrop = False End Sub" Kırmızı renkli sayıyı seç g12 ye yazsın "Sub sommeCouleurRougeText() Dim Cellule As Range Dim total As Variant For Each Cellule In Selection If Cellule.Font.ColorIndex = 3 Then '3 rouge et 1 pour le noir 'If Cellule.Interior.ColorIndex = 3 Then (pour la couleur de fond) If IsNumeric(Cellule) Then total = total + Cellule.Value End If Next MsgBox total Range(""G12"") = total End Sub" Kısayol tuşları listesi "Option Explicit Sub StartList() Dim R As Range ActiveSheet.UsedRange.ClearContents Set R = Range(""A3"") ListCtrls Application.CommandBars.ActiveMenuBar, R End Sub Sub ListCtrls(Ctrl As Object, Rng As Range) Dim C As Office.CommandBarControl Static S As String Dim Pos As Integer If TypeOf Ctrl Is CommandBar Then S = ""ALT"" End If If Not TypeOf Ctrl Is Office.CommandBarButton Then For Each C In Ctrl.Controls Rng.Value = C.Caption Pos = InStr(1, C.Caption, ""&"") If Pos Then S = S & ""+"" & Mid(C.Caption, Pos + 1, 1) Rng.EntireRow.Cells(1, ""H"").Value = UCase(S) End If Set Rng = Rng(2, 2) ListCtrls C, Rng Set Rng = Rng(1, 0) If Len(S) > 3 Then S = Left(S, Len(S) - 2) End If Next C End If " Kitabı açma-kopyalama-kapama "Sub dosyaaç() Workbooks.Open Filename:=""C:\Belgelerim\kitap1.xls"" End Sub Sub kopyala() Sheets(""Sayfa1"").Copy After:=Workbooks(""Kitap1"").Sheets(1) End Sub Sub dosyakapat() Workbooks(""kitap1.xls"").Close End Sub" Kitabı belirlenen isimle kayıt etme "Sub test() UsrRsp = Application.Dialogs(xlDialogSaveAs).Show(""test.xls"") Select Case UsrRsp Case -1 Case 0 End Select End Sub" Kitabı diskete yedekleme "Sub SaveWorkbookBackupToFloppyA() Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean If TypeName(ActiveWorkbook) = ""Nothing"" Then Exit Sub Set awb = ActiveWorkbook If awb.Path = """" Then Application.Dialogs(xlDialogSaveAs).Show Else BackupFileName = awb.Name OK = False On Error GoTo NotAbleToSave If Dir(""A:\"" & BackupFileName) <> """" Then Kill ""A:\"" & BackupFileName End If With awb Application.StatusBar = ""Saving this workbook "" .Save Application.StatusBar = ""Saving this workbook backup "" .SaveCopyAs ""A:\"" & BackupFileName OK = True End With End If NotAbleToSave: Set awb = Nothing Application.StatusBar = False If Not OK Then MsgBox ""Backup Copy Not Saved!"", vbExclamation, ThisWorkbook.Name End If End Sub" Kitabı isimle kaydetme "Sub Save() ActiveWorkbook.Save End Sub Sub SaveName() ActiveWorkbook.SaveAs Filename:=""C:\MyFile.xls"" End Sub" Kitabı kapat, kaydet "Çalışma Kitabını Kapat Sub kayıt() ActiveWorkbook.Close End Sub Çalışma Kitabını Kaydet Sub kayıt() ActiveWorkbook.Save End Sub " Kitabı kapatırken a1 hücresine tarihi yaz "Private Sub Workbook_BeforeClose(Cancel As Boolean) Sheets(1).[A1] = ""Dernière modification le "" & Format(Date, ""dd/mm/yyyy"") End Sub" Kitabı kaydederken mesaj alma "Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _ Cancel As Boolean) a = MsgBox(""Bu kitabı gerçetken kaydetmek istiyor musunuz?"", vbYesNo) If a = vbNo Then Cancel = True End Sub" Kitabı kaydet pencereyi kapat, a1'i seç: "KİTABI KAYDET PENCEREYİ KAPAT A1'İ SEÇ Private Sub CommandButton6_Click() ActiveWorkbook.Save ActiveWindow.Close Range(""A1"").Select End Sub " Kitabı kilitleme. Salt okunur olarak açma. Makroları gizler "Sub auto_open() Application.CommandBars(""Worksheet Menu Bar"").Controls(6).Controls(""Makro"").Enabled = False Application.OnKey ""%{F11}"", ""mesaj"" End Sub Sub auto_close() Application.CommandBars(""Worksheet Menu Bar"").Controls(6).Controls(""Makro"").Enabled = True Application.OnKey ""%{F11}"" End Sub Sub mesaj() MsgBox ""Makrolar gizli!!"" End Sub" Kitabı otomatik kaydedip kapatma "Thisworkbook a Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.DisplayAlerts = False ActiveWorkbook.Save Application.DisplayAlerts = True End Sub" Kitabı yedekleme "Sub SaveWorkbookBackup() Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean If TypeName(ActiveWorkbook) = ""Nothing"" Then Exit Sub Set awb = ActiveWorkbook If awb.Path = """" Then Application.Dialogs(xlDialogSaveAs).Show Else BackupFileName = awb.FullName i = 0 While InStr(i + 1, BackupFileName, ""."") > 0 i = InStr(i + 1, BackupFileName, ""."") Wend If i > 0 Then BackupFileName = Left(BackupFileName, i - 1) BackupFileName = BackupFileName & "".bak"" OK = False On Error GoTo NotAbleToSave With awb Application.StatusBar = ""Saving this workbook "" .Save Application.StatusBar = ""Saving this workbook backup "" .SaveCopyAs BackupFileName OK = True End With End If NotAbleToSave: Set awb = Nothing Application.StatusBar = False If Not OK Then MsgBox ""Backup Copy Not Saved!"", vbExclamation, ThisWorkbook.Name End If End Sub" Kitabın adını öğrenme "Sub Dateiname() MsgBox ActiveWorkbook.Name End Sub" Kitabın başlığını değiştirme "Sub test() Application.Caption = ""Excelci"" ActiveWindow.Caption = ""pirr"" 'Incorrect MsgBox Application.Caption & "" "" & ActiveWindow.Caption 'Correct MsgBox Application.Caption End Sub" Kitabın boyutunu hesaplasın "Sub Taillefile() Dim SizeFile SizeFile = FileLen(""c:\ajeter\classeur1.xls"") MsgBox ""Taille du fichier "" & SizeFile & "" octets"" 'du classeur actif MsgBox FileLen(ThisWorkbook.FullName) & "" octets"" End Sub" Kitabın bulunduğu yolu ve ismini belirtir "Function FileOrFolderName(InputString As String, _ ReturnFileName As Boolean) As String Dim i As Integer, FolderName As String, FileName As String i = 0 While InStr(i + 1, InputString, Application.PathSeparator) > 0 i = InStr(i + 1, InputString, Application.PathSeparator) Wend If i = 0 Then FolderName = CurDir Else FolderName = Left(InputString, i - 1) End If FileName = Right(InputString, Len(InputString) - i) If ReturnFileName Then FileOrFolderName = FileName Else FileOrFolderName = FolderName End If End Function Sub TestFileOrFolderName() MsgBox FileOrFolderName(ThisWorkbook.FullName, False), , _ ""This Workbook Foldername:"" MsgBox FileOrFolderName(ThisWorkbook.FullName, True), , _ ""This Workbook Filename:"" End Sub" Kitabın ilk kaydediliş tarihini yazar "Sub LetztesSpeicherdatumEintragen() Range(""A1"").Value = _ ActiveWorkbook.BuiltinDocumentProperties(""Last Save Time"").Value End Sub" Kitabın kopyasını userform,modul,class silerek oluşturur "Sub SaveWithoutMacros() Dim vFilename As Variant Dim wbActiveBook As Workbook Dim oVBComp As Object Dim oVBComps As Object On Error GoTo CodeError vFilename = Application.GetSaveAsFilename(filefilter:=""Microsoft Excel Workbooks,*.xls"", _ Title:=""Save Copy Without Macros"") If vFilename = False Then Exit Sub ActiveWorkbook.SaveCopyAs vFilename Set wbActiveBook = Workbooks.Open(vFilename) Set oVBComps = wbActiveBook.VBProject.VBComponents For Each oVBComp In oVBComps Select Case oVBComp.Type Case 1, 2, 3 oVBComps.Remove oVBComp Case Else With oVBComp.CodeModule .DeleteLines 1, .CountOfLines End With End Select Next oVBComp wbActiveBook.Save MsgBox ""Vba kodlarınız silinerek çalışma kitabınızın kopyası oluşturuldu!."", vbInformation, ""pir"" Exit Sub CodeError: MsgBox Err.Description, vbExclamation, ""Başarısız"" End Sub " Kitabınızı diskete yedekler "Sub SaveWorkbookBackupToFloppyA() Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean If TypeName(ActiveWorkbook) = ""Nothing"" Then Exit Sub Set awb = ActiveWorkbook If awb.Path = """" Then Application.Dialogs(xlDialogSaveAs).Show Else BackupFileName = awb.Name OK = False On Error GoTo NotAbleToSave If Dir(""A:\"" & BackupFileName) <> """" Then Kill ""A:\"" & BackupFileName End If With awb Application.StatusBar = ""Saving this workbook "" .Save Application.StatusBar = ""Saving this workbook backup "" .SaveCopyAs ""A:\"" & BackupFileName OK = True End With End If NotAbleToSave: Set awb = Nothing Application.StatusBar = False If Not OK Then MsgBox ""Dosya Yedeklenemedi!"", vbExclamation, ThisWorkbook.Name End If End Sub" Kitabınızın kapanması bir hücrenin değerine bağlı ise "This workbook kısmına; Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If Worksheets(""Sayfa1"").Range(""A1"").Value < 10 Then Cancel = True End If End Sub " Kİtabi kapat kİtabi kaydet "Çalışma Kitabını Kapat Sub kayıt() ActiveWorkbook.Close End Sub Çalışma Kitabını Kaydet Sub kayıt() ActiveWorkbook.Save End Sub " Kİtabi kaydet pencereyİ kapat a1'İ seÇ "KİTABI KAYDET PENCEREYİ KAPAT A1'İ SEÇ Private Sub CommandButton6_Click() ActiveWorkbook.Save ActiveWindow.Close Range(""A1"").Select End Sub " Kİtabi otomatİk kaydetme "ÇALIŞMA KİTABINI KAPATTIĞINIZDA KİTABI OTOMATİK KAYIT YAPAR VEYA YAPMAZ Sub Auto_close() Workbooks(""Kitap1.xls"").Close True 'False kaydetmeden kitabı kapar End Sub " Kitap açılırken bu gün tarihli yedek alır "Private Sub Workbook_Open() Dim StDatei As String Dim StPhad As String StDatei = ThisWorkbook.Name ' Dateiname StPhad = ThisWorkbook.Path ' Phad Dim Fso As Object Set Fso = CreateObject(""Scripting.FileSystemObject"") If Fso.FileExists(StPhad & ""\"" & Format(Now, ""DD-MM-YY"") & ""_"" & Format(Now, ""hh-mm"") & ""_"" & StDatei) Then Kill StPhad & ""\"" & Format(Now, ""DD-MM-YY"") & ""_"" & Format(Now, ""hh-mm"") & ""_"" & StDatei End If ActiveWorkbook.SaveCopyAs FileName:=StPhad & ""\"" & Format(Now, ""DD-MM-YY"") & ""_"" & Format(Now, ""hh-mm"") & ""_"" & StDatei End Sub" Kitap açma (1 den fazla dosya) "Sub OpenMultipleFiles() Dim fn As Variant, f As Integer fn = Application.GetOpenFilename(""Excel-files,*.xls"", _ 1, ""Select One Or More Files To Open"", , True) If TypeName(fn) = ""Boolean"" Then Exit Sub For f = 1 To UBound(fn) Debug.Print ""Selected file #"" & f & "": "" & fn(f) Workbooks.Open fn(f) MsgBox ActiveWorkbook.Name, , ""Active Workbook Name:"" ActiveWorkbook.Close False Next f End Sub" Kitap açma (tek dosya) "Sub OpenOneFile() Dim fn As Variant fn = Application.GetOpenFilename(""Excel-files,*.xls"", _ 1, ""Select One File To Open"", , False) If TypeName(fn) = ""Boolean"" Then Exit Sub Debug.Print ""Selected file: "" & fn Workbooks.Open fn End Sub" Kitap adını a1 e aldırma "Sub kitap_ismi() Sheets(""Sayfa1"").Range(""A1"").Value = ThisWorkbook.FullName End Sub" Kitap başlığı isimlendirme (caption) "Public AppCap$ Public ActWinCap$ 'Titelleiste ändern, wenn Mappe aktiviert wird Private Sub Workbook_Activate() Application.Caption = ""excel-lex"" ActiveWindow.Caption = ""http://www.excel-lex.de.vu: Das EXCEL-2000-Lexikon ©2003 K.-M. Buss"" End Sub 'Titelleiste zurücksetzen, wenn diese geschlossen wird Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.Caption = AppCap ActiveWindow.Caption = ActWinCap End Sub 'Titelleiste zurücksetzen, wenn diese deaktiviert wird Private Sub Workbook_Deactivate() Application.Caption = AppCap ActiveWindow.Caption = ActWinCap End Sub 'Titelleiste ändern, wenn Mappe geöffnet wird Private Sub Workbook_Open() Application.Caption = ""excel-lex"" ActiveWindow.Caption = ""http://www.excel-lex.de.vu: Das EXCEL-2000-Lexikon ©2003 K.-M. Buss"" End Sub" Kitap her açılışta a1 1 artar "Sub Workbook_Open() With Worksheets(1).Range(""A1"") .Value = .Value + 1 End With End Sub " Kitap ismi ile klasör oluşturur her sayfayı ayrı ayrı olarak kaydet "Option Explicit Sub sayfalari_ayir_kaydet() Dim Sheet As Worksheet, SheetName$, MyFilePath$, N& MyFilePath$ = ActiveWorkbook.Path & ""\"" & _ Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next MkDir MyFilePath For N = 1 To Sheets.Count Sheets(N).Activate SheetName = ActiveSheet.Name Cells.Copy Workbooks.Add (xlWBATWorksheet) With ActiveWorkbook With .ActiveSheet .Paste .Name = SheetName [A1].Select End With .SaveAs Filename:=MyFilePath _ & ""\"" & SheetName & "".xls"" .Close SaveChanges:=True End With .CutCopyMode = False Next End With Sayfa1.Activate End Sub" Kitap kaç kere açılmış "Sub auto_open() Worksheets(""Sheet2"").Range(""A1"") = Worksheets(""Sheet2"").Range(""A1"") + 1 End Sub" Kitap kapanırken a1 e tarih ekleme "Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Range(""A1"").Value = ""Stand: "" & Format(Date, ""DD.MM.YYYY"") Worksheets(""Tabelle1"").PageSetup.LeftFooter = ""Stand: "" & Format(Date, ""DD.MM.YYYY"") End Sub" Kitap kaydet ismini sen belirle - mesajla bildirir "Sub ShowFileSaveAsDialog() Workbooks.Add ' create a new workbook With Worksheets(1).Range(""A1"") ' add information to the new workbook .Formula = ""Log File for "" & Format(Date, ""yyyy-mm-dd"") & "":"" .Font.Size = 14 .Font.Bold = True End With Application.Dialogs(xlDialogSaveAs).Show ' display the Save as dialog If Len(ActiveWorkbook.Path) = 0 Then ' the workbook was not saved MsgBox ""You can save the workbook manually later "" Else MsgBox ""The workbook is saved as "" & ActiveWorkbook.FullName End If End Sub" Kitap kaydetme ismini belirli "Sub SaveOneFile() Dim fn As Variant fn = Application.GetSaveAsFilename(""MyFileName.xls"", _ ""Excel files,*.xls"", 1, ""Select your folder and filename"") If TypeName(fn) = ""Boolean"" Then Exit Sub ActiveWorkbook.SaveAs fn End Sub" Kitap penceresini 2 boyut küçültme "Sub InTheMiddle() Dim dWidth As Double, dHeight As Double With Application .WindowState = xlMaximized dWidth = .Width dHeight = .Height .WindowState = xlNormal .Top = dHeight / 4 .Height = dHeight / 2 .Left = dWidth / 4 .Width = dWidth / 2 End With End Sub" Kitap sayfasını simge durumunda küçültme "Private Sub CmdIntro_Click() ActiveWindow.WindowState = xlMinimized End Sub" Kitap toplam kaç kere,hangi tarih ve hangi saatte açıldı "This workbook bölümüne; Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String Counter = GetSetting(""XYZ Corp"", ""Budget"", ""Count"", 0) LastOpen = GetSetting(""XYZ Corp"", ""Budget"", ""Opened"", """") Msg = ""Çalışma kitabı "" & Counter & "" kere açıldı."" Msg = Msg & vbCrLf & ""En son açılış: "" & LastOpen MsgBox Msg, vbInformation, ThisWorkbook.Name Counter = Counter + 1 LastOpen = Date & "" "" & Time SaveSetting ""XYZ Corp"", ""Budget"", ""Count"", Counter SaveSetting ""XYZ Corp"", ""Budget"", ""Opened"", LastOpen End Sub " Kitap yedekleme "Sub SaveWorkbookBackup() Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean If TypeName(ActiveWorkbook) = ""Nothing"" Then Exit Sub Set awb = ActiveWorkbook If awb.path = """" Then Application.Dialogs(xlDialogSaveAs).Show Else BackupFileName = awb.FullName i = 0 While InStr(i + 1, BackupFileName, ""."") > 0 i = InStr(i + 1, BackupFileName, ""."") Wend If i > 0 Then BackupFileName = Left(BackupFileName, i - 1) BackupFileName = BackupFileName & "".bak"" OK = False On Error GoTo NotAbleToSave With awb Application.StatusBar = ""Saving this workbook "" .Save Application.StatusBar = ""Saving this workbook backup "" .SaveCopyAs BackupFileName OK = True End With End If NotAbleToSave: Set awb = Nothing Application.StatusBar = False If Not OK Then MsgBox ""Backup Copy Not Saved!"", vbExclamation, ThisWorkbook.Name End If End Sub," Kitapta istenilen sayfa adını önizlemek için "Private Sub Workbook_BeforePrint(Cancel As Boolean) ActiveSheet.PageSetup.RightFooter = ActiveWorkbook.FullName End Sub " Kitapta ne kadar formül varsa ayrıntılı olarak belirtir (yeni sayfada) "Option Explicit Public Sub ListFormulasInWorkbook() ' by J.E. McGimpsey ' revised 04 July 2003 by Tom Ogilvy to add ' sheets when reaching ROWLIM formulas Const SHEETNAME As String = ""Formulas in *"" Const ALLFORMULAS As Integer = _ xlNumbers + xlTextValues + xlLogical + xlErrors Const ROWLIM As Long = 65500 Dim formulaSht As Worksheet Dim destRng As Range Dim cell As Range Dim wkSht As Worksheet Dim formulaRng As Range Dim shCnt As Long Dim oldScreenUpdating As Boolean With Application oldScreenUpdating = .ScreenUpdating .ScreenUpdating = False End With shCnt = 0 ListFormulasAddSheet formulaSht, shCnt ' list formulas on each sheet Set destRng = formulaSht.Range(""A4"") For Each wkSht In ActiveWorkbook.Worksheets If Not wkSht.Name Like SHEETNAME Then Application.StatusBar = wkSht.Name destRng.Value = wkSht.Name Set destRng = destRng.Offset(1, 0) On Error Resume Next Set formulaRng = wkSht.Cells.SpecialCells( _ xlCellTypeFormulas, ALLFORMULAS) On Error GoTo 0 If formulaRng Is Nothing Then destRng.Offset(0, 1).Value = ""None"" Set destRng = destRng.Offset(1, 0) Else For Each cell In formulaRng With destRng .Offset(0, 1) = cell.Address(0, 0) .Offset(0, 2) = ""'"" & cell.Formula .Offset(0, 3) = cell.Value End With Set destRng = destRng.Offset(1, 0) If destRng.row > ROWLIM Then ListFormulasAddSheet formulaSht, shCnt Set destRng = formulaSht.Range(""A5"") destRng.Offset(-1, 0).Value = wkSht.Name End If Next cell Set formulaRng = Nothing End If With destRng.Resize(1, 4).Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = 5 End With Set destRng = destRng.Offset(1, 0) If destRng.row > ROWLIM Then ListFormulasAddSheet formulaSht, shCnt Set destRng = formulaSht.Range(""A5"") destRng.Offset(-1, 0).Value = wkSht.Name End If End If Next wkSht With Application .StatusBar = False .ScreenUpdating = oldScreenUpdating End With End Sub Private Sub ListFormulasAddSheet( _ formulaSht As Worksheet, shtCnt As Long) Const SHEETNAME As String = ""Formulas in "" Const SHEETTITLE As String = ""Formulas in $ as of "" Const DATEFORMAT As String = ""dd MMM yyyy hh:mm"" Dim shtName As String With ActiveWorkbook ' Delete existing sheet and create new one shtCnt = shtCnt + 1 shtName = Left(SHEETNAME & .Name, 28) If shtCnt > 1 Then _ shtName = shtName & ""_"" & shtCnt On Error Resume Next Application.DisplayAlerts = False .Worksheets(shtName).Delete Application.DisplayAlerts = True On Error GoTo 0 Set formulaSht = .Worksheets.Add( _ after:=Sheets(Sheets.Count)) End With With formulaSht ' Format headers .Name = shtName .Columns(1).ColumnWidth = 15 .Columns(2).ColumnWidth = 8 .Columns(3).ColumnWidth = 60 .Columns(4).ColumnWidth = 40 With .Range(""C:D"") .Font.Size = 9 .HorizontalAlignment = xlLeft .EntireColumn.WrapText = True End With With .Range(""A1"") .Value = Application.Substitute(SHEETTITLE, ""$"", _ ActiveWorkbook.Name) & Format(Now, DATEFORMAT) With .Font .Bold = True .ColorIndex = 5 .Size = 14 End With End With With .Range(""A3"").Resize(1, 4) .Value = Array(""Sheet"", ""Address"", ""Formula"", ""Value"") With .Font .ColorIndex = 13 .Bold = True .Size = 12 End With .HorizontalAlignment = xlCenter With .Borders(xlEdgeBottom) .LineStyle = xlDouble .Weight = xlThick .ColorIndex = 5 End With End With End With End Sub" Kitapta ne kadar refers varsa ayrıntılı olarak belirtir (yeni sayfada) "Option Explicit Public Sub ListNamesInWorkbook() ' by J.E. McGimpsey ' Thanks to Tom Ogilvy for help with overflow. Const SHEETNAME As String = ""Names in *"" Const ROWLIM As Long = 65500 Dim nameSht As Worksheet Dim destRng As Range Dim cell As Range Dim wkSht As Worksheet Dim shCnt As Long Dim i As Long Dim oldScreenUpdating As Boolean With Application oldScreenUpdating = .ScreenUpdating .ScreenUpdating = False End With shCnt = 0 ListNamesAddSheet nameSht, shCnt ' list Workbook-level names Set destRng = nameSht.Range(""A5"") With destRng.Offset(-1, 0) .Value = ""Workbook-Level names"" .Font.Bold = True End With With ActiveWorkbook.Names If .Count Then destRng.Offset(0, 1).ListNames 'only workbook level Set destRng = destRng.Offset(0, 1).End(xlDown).Offset(1, -1) Else destRng.Offset(0, 1).Value = ""None"" Set destRng = destRng.Offset(0, 1) End If End With With destRng.Resize(1, 3).Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = 5 End With Set destRng = destRng.Offset(1, 0) For Each wkSht In ActiveWorkbook.Worksheets With destRng .Value = ""Names in sheet """""" & wkSht.Name & """""""" .Font.Bold = True Set destRng = .Offset(1, 0) End With With wkSht.Names If .Count Then For i = 1 To .Count With .Item(i) destRng.Offset(0, 1) = Mid(.Name, InStr(.Name, ""!"") + 1) destRng.Offset(0, 2) = ""'"" & .RefersTo Set destRng = destRng.Offset(1, 0) If destRng.Row > ROWLIM Then ListNamesAddSheet nameSht, shCnt Set destRng = nameSht.Range(""A5"") destRng.Offset(-1, 0).Value = _ ""Names in sheet """""" & wkSht.Name & """""""" End If End With Next i Else destRng.Offset(0, 1).Value = ""None"" Set destRng = destRng.Offset(1, 0) End If End With With destRng.Resize(1, 4).Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = 5 End With Set destRng = destRng.Offset(1, 0) Next wkSht With Application .StatusBar = False .ScreenUpdating = oldScreenUpdating End With End Sub Private Sub ListNamesAddSheet( _ nameSht As Worksheet, shtCnt As Long) Const SHEETNAME As String = ""Names in "" Const SHEETTITLE As String = ""Names in $ as of "" Const DATEFORMAT As String = ""dd MMM yyyy hh:mm"" Dim shtName As String With ActiveWorkbook ' Delete existing sheet and create new one shtName = Left(SHEETNAME & .Name, 28) shtCnt = shtCnt + 1 If shtCnt > 1 Then _ shtName = shtName & ""_"" & Format(shtCnt, ""00"") On Error Resume Next Application.DisplayAlerts = False .Worksheets(shtName).Delete Application.DisplayAlerts = True On Error GoTo 0 Set nameSht = .Worksheets.Add( _ after:=Sheets(Sheets.Count)) End With With nameSht ' Format headers .Name = shtName .Columns(1).ColumnWidth = 30 .Columns(2).ColumnWidth = 20 .Columns(3).ColumnWidth = 90 With .Range(""B:C"") .Font.Size = 9 .HorizontalAlignment = xlLeft .EntireColumn.WrapText = True End With With .Range(""A1"") .Value = Application.Substitute(SHEETTITLE, ""$"", _ ActiveWorkbook.Name) & Format(Now, DATEFORMAT) With .Font .Bold = True .ColorIndex = 5 .Size = 14 End With End With With .Range(""A3"").Resize(1, 3) .Value = Array(""Sheet"", ""Name"", ""Refers To"") With .Font .ColorIndex = 13 .Bold = True .Size = 12 End With .HorizontalAlignment = xlCenter With .Borders(xlEdgeBottom) .LineStyle = xlDouble .Weight = xlThick .ColorIndex = 5 End With End With End With End Sub" Kitapta yazdırmayı iptal etme "Sub Auto_Open() 'Prevent Printing via menu MenuBars(xlWorksheet).Menus(""File"").MenuItems(""Print "").Delete 'Turn off Print icon wherever it may be in the toolbars For J = 1 To Toolbars.Count For K = 1 To Toolbars(J).ToolbarButtons.Count If Toolbars(J).ToolbarButtons(K).Id = 2 Then Toolbars(J).ToolbarButtons(K).Enabled = False End If If Toolbars(J).ToolbarButtons(K).Id = 3 Then Toolbars(J).ToolbarButtons(K).Enabled = False End If Next K Next J End Sub Sub Auto_Close() 'Reset the menu items For Each mb In MenuBars mb.Reset Next mb 'Reset the buttons For J = 1 To Toolbars.Count For K = 1 To Toolbars(J).ToolbarButtons.Count If Toolbars(J).ToolbarButtons(K).Id = 2 Then Toolbars(J).ToolbarButtons(K).Enabled = True End If If Toolbars(J).ToolbarButtons(K).Id = 3 Then Toolbars(J).ToolbarButtons(K).Enabled = True End If Next K Next J End Sub Private Sub Workbook_BeforePrint(Cancel As Boolean) Cancel = True End Sub" Kitaptaki tüm resimleri silme "Sub DeleteShapes() Dim wks As Worksheet For Each wks In Worksheets wks.Pictures.Delete Next wks End Sub" Klasör açma "Private Sub Command1_Click() Dim a a = Shell(""C:\WINDOWS\Explorer.exe c:\windows"", vbNormalFocus) End Sub " Klasör alma "Sub Klasör_Al() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") Set f = ds.GetFolder(""D:\ExcelÖrnekleri"") End Sub" Klasör arama "Sub klasör_ara() Dim ds, a Set ds = CreateObject(""Scripting.FileSystemObject"") a = ds.FolderExists(""C:\SXSİ"") If a = True Then MsgBox ""Bu isimde bir klasör var"" Else MsgBox ""Bu isimde bir klasör yok"" End If End Sub" Klasör bilgisi "Sub Klasör_Bilgisi_Göster() Dim ds, f, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set f = ds.GetFolder(""D:\ExcelÖrnekleri"") s = UCase(""D:\ExcelÖrnekleri"") & vbCrLf s = s & ""Created: "" & f.DateCreated & vbCrLf 'Oluşturma s = s & ""Last Accessed: "" & f.DateLastAccessed & vbCrLf 'Son Erişim s = s & ""Last Modified: "" & f.DateLastModified 'Son Değiştirilme MsgBox s, 0, ""File Access Info"" End Sub" Klasör ismi değiştirme "Sub Klasör_İsmi_Değiştir() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") dosya = ds.GetFileName(""D:\ExcelÖrnekleri\Yeni"") dosya2 = ds.GetFileName(""C:\SXS"") f = ds.MoveFolder(dosya, dosya2) End Sub" Klasör oluşturma "Sub Klasör_Oluştur() Dim ds Set ds = CreateObject(""Scripting.FileSystemObject"") ds.CreateFolder ""C:\SXS\Deneme"" End Sub" Klasör oluşturuyormuşuz gibi bir dizin oluşturur "Sub Dizin_İsmi_Oluştur() Dim ds, a Set ds = CreateObject(""Scripting.FileSystemObject"") a = ds.BuildPath(""C:\SXSİ"", ""\A"") MsgBox a End Sub" Klasör silme "Sub Klasör_Sil() Dim ds Set ds = CreateObject(""Scripting.FileSystemObject"") ds.DeleteFolder ""C:\SXS\Deneme"" End Sub" Klasör ve dosya makrolarındaki yolları kendine göre düzenle "Sub DosyaKlasorYol() 'Aktif Çalışma Kitabının ismini Çalışma kitabının başlığına (en üste yazdırır) ActiveWindow.Caption = ActiveWorkbook.FullName 'Aktif Çalışma Kitabının ismini aktif hücreye yazdırır ActiveCell = ActiveWorkbook.FullName 'Aktif hücreye aktif sayfanın isminin yazdırılması ActiveCell.Value = ActiveSheet.Name 'Aktif Çalışma sayfasının isminin Çalışma kitabının başlığına (en üste) yazdırır ActiveWindow.Caption = ActiveSheet.Name 'belirtilen dizindeki dosyanın boyutunu verir MsgBox FileLen(""C:\Ahmet\taşınan.xls"") 'Belirtilen sürücüdeki klasörün ismini değiştirir Name ""C:\Ahmet\Alihan\12.xls"" As ""C:\Veli\taşınan.xls"" 'Belirtilen sürücüdeki klasörün ismini değiştirir Name ""C:\Alis"" As ""C:\Ahmet"" 'Yeni Klasör dizin oluşturur MkDir ""c:\Alihan"" End Sub" KlasÖrdekİ dosyalari comboboxta gÖstermek "Private Sub UserForm_Initialize() MyPath = ""C:\Temp\"" MyObj = Dir(MyPath, vbDirectory) Do While MyObj <> """" i = i + 1 If (GetAttr(MyPath & MyObj) And vbDirectory) = vbDirectory Then If MyObj <> "".."" And MyObj <> ""."" Then ComboBox1.AddItem MyObj End If End If MyObj = Dir Loop End Sub " Klasördeki tüm xls dosyalarını sxs klasörüne kopyala "Sub Dosya_Kopyala() Dim ds Set ds = CreateObject(""Scripting.FileSystemObject"") ds.CopyFile ""D:\ExcelÖrnekleri\*.xls"", ""C:\SXS"" End Sub" Klasördeki veya dizindeki xls dosyasının boyutunu öğrenme "Sub Groesse() Dim sFileName As String 'sFileName = ThisWorkbook.Name sFileName = ""C:\xls.xls"" 'C:\pir\xls.xls MsgBox ""Diese Mappe hat eine Grösse von "" & FileLen(sFileName) & "" kB"" End Sub" KlasÖrden ÇaliŞma sayfasi aÇma kÖprÜ kurma "Sayfa1'e A1 hücresinden başlayarak aşağıdoğru klasör içindeki doyalara köprü kurar, anasayfanın adı ""anasayfa.xls"" olmalı veya kodu değiştirin Private Sub Workbook_Open() Dim fs, f, f1, fc, s Set fs = CreateObject(""Scripting.FileSystemObject"") Set f = fs.GetFolder(ActiveWorkbook.Path) Set fc = f.Files i = 1 For Each f1 In fc If f1.Name <> ""anasayfa.xls"" Then Sheets(""Sayfa1""). Range(""a"" & i).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=f1.Name, _ TextToDisplay:=Mid(f1.Name, 1, Len(f1.Name) - 4) i = i + 1 End If Next End Sub " Klasöre gözat penceresini çağırır "Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type '32-bit API declarations Declare Function SHGetPathFromIDList Lib ""shell32.dll"" _ Alias ""SHGetPathFromIDListA"" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib ""shell32.dll"" _ Alias ""SHBrowseForFolderA"" (lpBrowseInfo As BROWSEINFO) As Long Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer bInfo.pidlRoot = 0& If IsMissing(Msg) Then bInfo.lpszTitle = ""Select a folder."" Else bInfo.lpszTitle = Msg End If bInfo.ulFlags = &H1 x = SHBrowseForFolder(bInfo) path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Range(""A1"") = GetDirectory Else GetDirectory = """" End If End Function" Klasöre gözat xls listele "Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Declare Function SHGetPathFromIDList Lib ""shell32.dll"" Alias ""SHGetPathFromIDListA"" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib ""shell32.dll"" Alias ""SHBrowseForFolderA"" (lpBrowseInfo As BROWSEINFO) As Long Sub Verzeichnisse_auflisten() Dim Pfad1, Name1, Anzahl, X, X0, X1, X2, Verz, Anzverz, Größe Dim TB1, TB2 As Worksheet Dim msg As String Set TB1 = ThisWorkbook.Worksheets(1) Set TB2 = ThisWorkbook.Worksheets(2) start = Now TB1.[a:D] = """" TB2.[a:D] = """" 'überflüssige Tabellenblätter löschen If ThisWorkbook.Worksheets.Count > 2 Then Application.DisplayAlerts = False For X = 3 To ThisWorkbook.Worksheets.Count ThisWorkbook.Worksheets(3).Delete Next X Application.DisplayAlerts = True End If ' Pfad abfragen msg = ""Wählen Sie bitte einen Ordner aus:"" Pfad1 = getdirectory(msg) If Pfad1 = """" Then Exit Sub Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen. TB1.[a2] = Pfad1 Anzahl = 2 TB1.[a1] = ""Pfad"" TB1.[b1] = ""UnterVerz."" TB1.[c1] = ""Anz. Dateien"" TB1.[d1] = ""Datgröße in Verz."" X0 = 2 X1 = 2 Do While TB1.Cells(Rows.Count, 1).End(xlUp).Row <> TB1.Cells(Rows.Count, 2).End(xlUp).Row For X2 = X0 To X1 Pfad1 = TB1.Cells(X2, 1) ' Pfad setzen. If Right(Pfad1, 1) <> ""\"" Then Pfad1 = Pfad1 & ""\"" Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen. Verz = 0 Do While Name1 <> """" ' Schleife beginnen. ' Aktuelles und übergeordnetes Verzeichnis ignorieren. If Name1 <> ""."" And Name1 <> "".."" Then ' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein ' Verzeichnis ist. If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then Anzahl = Anzahl + 1 TB1.Cells(Anzahl, 1) = Pfad1 & Name1 & ""\"" Verz = Verz + 1 'Eintrag nur anzeigen, wenn es sich um ein Verzeichnis handelt. End If End If Name1 = Dir ' Nächsten Eintrag abrufen. Loop TB1.Cells(X2, 2) = Verz Next X2 X0 = X1 + 1 X1 = X2 Loop 'Dateien aus den Verzeichnissen auslesen Anzverz = TB1.Cells(Rows.Count, 1).End(xlUp).Row i = 1 ii = 0 For Verz = 2 To Anzverz Anzahl = 0 Größe = 0 Set fs = CreateObject(""Scripting.FileSystemObject"") Set f = fs.GetFolder(TB1.Cells(Verz, 1)) Set fc = f.Files For Each f1 In fc If i = 65536 Then ii = ii + 1 ThisWorkbook.Worksheets.Add.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) ThisWorkbook.Worksheets(ii + 2).Name = ""Dateien "" & ii + 1 Set TB2 = ThisWorkbook.Worksheets(ii + 2) i = 1 End If i = i + 1 Anzahl = Anzahl + 1 TB2.Cells(i, 1) = f1.Name TB2.Cells(i, 2) = f & ""\"" & f1.Name 'Hyperlink auf die Datei einfügen TB2.Hyperlinks.Add Anchor:=TB2.Cells(i, 2), Address:= _ f & ""\"" & f1.Name TB2.Cells(i, 3) = FileLen(f1) TB2.Cells(i, 4) = FileDateTime(f1) Größe = Größe + FileLen(f1) Next TB1.Cells(Verz, 3) = Anzahl TB1.Cells(Verz, 4) = Größe / 1024 / 1024 Next Verz 'MsgBox (ii * 65536) + i ende = Now MsgBox ""Anzahl der Verzeichnisse: "" & Verz & Chr(13) & _ ""Anzahl der Dateien: "" & (ii * 65536) + i & Chr(13) & _ Chr(13) & ""Dauer: "" & Format(ende - start, ""nn:ss"") End Sub ' Muß erwähnt sein: Diese Funktion stammt nicht von mir. ' Die Quelle ist mir nicht mehr bekannt. Function getdirectory(Optional msg) As String Dim bInfo As BROWSEINFO Dim Path As String Dim r As Long, X As Long, pos As Integer ' Ausgangsordner = Desktop bInfo.pidlRoot = 0& ' Dialogtitel If IsMissing(msg) Then bInfo.lpszTitle = ""Wählen Sie bitte einen Ordner aus."" Else bInfo.lpszTitle = msg End If ' Rückgabe des Unterverzeichnisses bInfo.ulFlags = &H1 ' Dialog anzeigen X = SHBrowseForFolder(bInfo) ' Ergebnis gliedern Path = Space$(512) r = SHGetPathFromIDList(ByVal X, ByVal Path) If r Then pos = InStr(Path, Chr$(0)) getdirectory = Left(Path, pos - 1) Else getdirectory = """" End If End Function" KlasÖrÜn İÇİnde kaÇ adet jpg uzantili dosya var ? "Sub jpgbul() Dim Dosya Dim i As Integer Dosya = Dir(""C:\Evren\Resimler\*.jpg"") i = 1 While Dosya <> """" Dosya = Dir Cells(i, 1) = Dosya i = i + 1 Wend MsgBox i - 1 End Sub" Klavye ok yönleri ile mesaj alma "Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = vbKeyEscape Then MsgBox ""Escape'e bastın"" End If If KeyCode = vbKeyRight Then MsgBox ""sağ ok'a bastın"" End If If KeyCode = vbKeyLeft Then MsgBox ""sol ok'a bastın"" End If If KeyCode = vbKeyUp Then MsgBox ""ileri ok'a bastın"" End If If KeyCode = vbKeyDown Then MsgBox ""geri ok'a bastın"" End If End Sub" Kod yazarak showmodal durumunu ayarlamak. "Bir modul ilave edip, içine aşağıdakileri yapıştırın. Daha sonra da bir şekilde Test isimli prosedürü çalıştırın. (Formun adı - Name özelliği - UserForm1 olması ve kullanılan Excel versiyonunun 2000 veya üzerinde olması durumunda çalışır.) visual basic kodu: Sub Test() UserForm1.Show 0 End Sub" Kod yazarken Vba penceresinde kod yazarken örneğin Worksheets yazacaksınız, ancak bunu açılır pencereden seçmek için CTR + J yi, önerme veya tamamlama için ise CTR + ARA ÇUBUĞU'nu kullanabilirsiniz Koda formÜl adres yolunu hÜcreden vermek "Sub Yaz() ActiveCell.Formula = [b3].Text & "":\"" & [c3].Text & ""\"" & [d3].Text & ""\"" & [e3].Text & ""\["" & [e4] & "".xls]"" & [e5] & "" '!"" & [e6] End Sub " Kodlara aÇiklama ekleme "KODLARIN BAŞINA VEYA SONUNA GİRİLDİĞİNDE AÇIKLAMA EKLER MsgBox ""DENEME"" " Kodları kopyalama CTRL+C CTRL+V İLE KOPYALA YAPIŞTIR İŞLEMİNİ YAPABİLİRSİNİZ Kodlarin hata vermesİnİ engeller "BU KOD YAZDIĞINIZ KODLAR HATA VERİRSE ONU ENGELLER (KODUNUZUN BAŞINA EKLEYİN) On Error Resume Next " Kolon numarasını ver kolonu bulsun "kullanılışı 'A1=5 'B1=Columnletter(A1) Function ColumnLetter(ColumnNumber As Integer) As String If ColumnNumber > 26 Then ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & Chr(((ColumnNumber - 1) Mod 26) + 65) Else ColumnLetter = Chr(ColumnNumber + 64) End If End Function" Kolon sayısını yaz kolon adını harf olarak versin (ktf) "örnek kullanılışı =Columnletter(A1) Function ColumnLetter(ColumnNumber As Integer) As String If ColumnNumber > 26 Then ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & Chr(((ColumnNumber - 1) Mod 26) + 65) Else ColumnLetter = Chr(ColumnNumber + 64) End If End Function" Komutları özelleştir penceresi "Sub Dialog_18() Application.Dialogs(xlDialogCustomizeToolbar).Show End Sub" Kopyala yapiŞtir "Tablonuzun herhangi bir hücresi seçiliyken aşağıdaki makroyu çalıştırın. Sub Makro1() Selection.CurrentRegion.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveCell.SpecialCells(xlLastCell).Select End Sub " Kopyala yapiŞtir İŞlemlerİ "KOPYALAMA YAPIŞTIRMA İŞLEMLERİ Sub kopya() Range(""a1:a2"").Copy Range(""b1"").PasteSpecial xlPasteValues Application.CutCopyMode = False Range(""a1:a2"").Value = """" End Sub " Kopyalama ve yapıştırma "Sub autobreite() spbreite = ActiveCell.Columns.ColumnWidth Selection.Copy Range(""A1"").Select ActiveSheet.Paste With Selection .ColumnWidth = spbreite End With End Sub" Kopyala-yapıştır "Sub NewBar() Application.CommandBars.Add(Name:=""BarPerso"").Visible = True Application.CommandBars(""BarPerso"").Controls.Add Type:=msoControlButton, ID _ :=19, Before:=1 Application.CommandBars(""BarPerso"").Controls.Add Type:=msoControlButton, ID _ :=22, Before:=2 With CommandBars(""BarPerso"") .Left = 620 .Top = 450 .Width = 120 End With End Sub" Kopyala-yapıştır'ı engelleme "Option Explicit Sub auto_open() 'kopyala kes yapıştırı açılışta pasif yapar EnableControl 21, False 'Kes EnableControl 19, False ' Kopyala EnableControl 22, False ' Yapıştır EnableControl 755, False ' özelyapıştır Application.OnKey ""^c"", ""yasakla"" Application.OnKey ""^v"", ""yasakla"" Application.CellDragAndDrop = False 'hücreyi çoğaltma ve taşıma CommandBars(""ToolBar List"").Enabled = False 'düzen menüsündeki ilgili menüleri gizle End Sub Sub auto_close() 'kopyala kes yapıştır kapanırken aktifleştirir EnableControl 21, True 'Kes EnableControl 19, True ' Kopyala EnableControl 22, True ' Yapıştır EnableControl 755, True ' özelyapıştır Application.OnKey ""^c"" Application.OnKey ""^v"" Application.CellDragAndDrop = True CommandBars(""ToolBar List"").Enabled = True End Sub Sub EnableControl(Id As Integer, Enabled As Boolean) Dim CB As CommandBar Dim C As CommandBarControl On Error Resume Next For Each CB In Application.CommandBars Set C = CB.FindControl(Id:=Id, recursive:=True) If Not C Is Nothing Then C.Enabled = Enabled Next End Sub Sub yasakla() MsgBox ""Üzgünüm yapmak istediğiniz işlem yasaklanmıştır.!"", , ""www.kod.gen.tr"" End Sub" Korumali hÜcrelere siralama yapmak? "Aşağıdaki makroyu sıralama işlemi için kullanıyorum. Ancak sayfa koruma yaptığım zaman doğal olarak sıralamayı yapmıyor. Kilitli ve gizli hücreleri seçerek, Diğer anlamda sayfa korumayı bozmadan sıralama işlemini nasıl yapabilirim. Sub SIRALA() Range(""B6:F300"").Select Selection.Sort Key1:=Range(""B6""), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal MsgBox ""BU İŞ BU KADAR )"", vbInformation End Sub Bunun için kodlarınızın başına korumayı açan, sonunada korumayı tekrar koyan satırlar ilave edebilirsiniz. Örneğin koruma şifreniz ""1234"" olsun; visual basic kodu: Sub SIRALA() activesheet.unprotect ""1234"" Range(""B6:F300"").Sort Key1:=Range(""B6"") MsgBox ""BU İŞ BU KADAR )"", vbInformation activesheet.protect ""1234"" End Sub " Korumali sayfada makro ÇaliŞir mi? "Sub deneme() Sheets(""Sayfa1"").Unprotect Password:=""sifre"" 'Buraya sizin kodlarınız yazın. Sheets(""Sayfa1"").Protect Password:=""sifre"" End Sub " Koşul sağlanıyorsa çıkarma işlemi yapsın "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Target, Range(""a1"")) Is Nothing Then If Range(""A1"").Value = 6 Then Range(""C1"").Value = Range(""C1"").Value - Range(""B1"").Value End If End If End Sub" KoŞula gÖre ÇaliŞan makro "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveCell.Address = ""$A$1"" And [a1] = 0 Then Call makroadı End Sub " Koşullu biçimlendirme penceresi "Sub Dialog_14() Application.Dialogs(xlDialogConditionalFormatting).Show End Sub" Kök dosya göster "Sub Kök_Dosya_Göster() Dim ds, d, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set d = ds.GetDrive(""C:\"") s = d.RootFolder MsgBox s End Sub" Köprü ekle penceresi "Sub Dialog_39() Application.Dialogs(xlDialogInsertHyperlink).Show End Sub" Köprüleri silmek için "Sub KopruSil() Range(""A:A"").Select Selection.Hyperlinks.Delete Range(""A1"").Select End Sub" Kritere uyanları c sütununda (c2den itibaren) bulup tüm satırları ile birlikte siler(kriter combobox) "For x = Cells(65536, 3).End(xlUp).Row To 2 Step -1 If Cells(x, 3) = ComboBox1.Text Then Rows(x).Delete Next" Kullanıcı adı ve parola eklemek "ThisWorkbook"" kısmına yazın Private Sub workbook_open() Application.Visible = False UserForm1.Show End Sub 'Dosyanıza ekleyeceğiniz Userforma bir CommandButton ve iki Textbox yerleştirin ve aşağıdaki kodu Userformun kod kısmına girin Private Sub CommandButton1_Click() If TextBox1.Value = ""Ali"" Or TextBox1.Value = ""Veli"" Then goto Kontrol2 Else Unload UserForm1 MsgBox ""Üzgünüm girdiğiniz kullanıcı adı hatalı."", vbCritical, ""HATA"" ActiveWorkbook.Close 0 Exit Sub EndIf Kontrol2: If TextBox2.Value = ""123"" Or TextBox2.Value = ""456"" Then MsgBox ""Programa girişiniz onaylanmıştır."", vbInformation Unload Me Application.Visible = True Else Unload UserForm1 MsgBox ""Üzgünüm girdiğiniz parola hatalı."", vbCritical, ""HATA"" ActiveWorkbook.Close 0 Exit Sub EndIf End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode <> 1 Then Cancel = True End Sub 'Ayrıca Textbox2'nin Properties kısmında bulunan ""PasswordChar"" bölümüne ""*"" (yıldız) işareti koyarsanız girilen parola ekranda ""*****"" şeklinde görünecektir. " Kullanıcı adı ve pc adını öğrenme "Private Declare Function GCN Lib ""kernel32"" Alias ""GetComputerNameA"" (ByVal myPara As String, myLen As Long) As Long Private Declare Function GUN Lib ""advapi32.dll"" Alias ""GetUserNameA"" (ByVal myPara As String, myLen As Long) As Long ' ****** 'Private Declare Function GetComputerNameA Lib ""kernel32"" (ByVal lpBuffer As String, nSize As Long) As Long 'Private Declare Function GetUserNameA Lib ""advapi32.dll"" (ByVal lpBuffer As String, nSize As Long) As Long Public Function ActiveUserName() As String Dim AUN As String * 100 Dim AunLen As Byte AunLen = 100 If GUN(AUN, Len(AUN)) Then ActiveUserName = Left(AUN, AunLen) Else ActiveUserName = ""User can not be Identified"" End If End Function Public Function ActiveComputerName() As String Dim ACN As String * 100 Dim AcnLen As Byte AcnLen = 100 If GCN(ACN, Len(ACN)) Then ActiveComputerName = Left(ACN, AcnLen) Else ActiveComputerName = ""User can not be Identified"" End If End Function Sub wer_und_was_bin_ich() Dim Qe As Byte MsgBox (""Mein Rechner heisst"" & ActiveComputerName) MsgBox (""Aktuell angemeldeter User ist: "" & ActiveUserName) End Sub" Kullanıcı adını bulan fonksiyon "Declare Function GetUserName Lib ""advapi32.dll"" _ Alias ""GetUserNameA"" (ByVal lpBuffer As String, _ nSize As Long) As Long Sub ShowUserName() Dim Buffer As String * 100 Dim BuffLen As Long BuffLen = 100 GetUserName Buffer, BuffLen MsgBox Left(Buffer, BuffLen - 1) End Sub" Kullanıcı kitabının kapatılması "Option Explicit Sub CloseUserBooks() Dim objWB As Workbook, arrSysBooks arrSysBooks = Array(ThisWorkbook.Name, _ ""SYS01F.XLS"", ""SYS01S.XLS"", _ ""SYS01M.XLS"", ""SYS01D.XLS"") 'These books can be open. With Application .DisplayAlerts = True 'Make sure the user has a chance to save! For Each objWB In Workbooks 'Loop through the Workbook collection. If IsError(.Match(objWB.Name, arrSysBooks, 0)) Then 'Not in the array? MsgBox ""Your workbook "" & objWB.Name & "" must be closed before the system can start."", 0, ""The Fortress"" objWB.Close End If Next End With End Sub" Kullanıcı tanımlı not fonksiyonu "Function Puan(a) If a > 100 Then Puan = ""Notun 100 den büyük olduğuna emin misiniz?"" If a = ""d"" Then Puan = ""F1"" If a = ""g"" Then Puan = ""F2"" If a < 0 Then Puan = ""NOT Sıfırdan Küçük Olmaz"" If a >= 0 And a <= 59 Then Puan = ""F3"" If a >= 60 And a <= 69 Then Puan = ""C"" If a >= 70 And a <= 74 Then Puan = ""B2"" If a >= 75 And a <= 80 Then Puan = ""B1"" If a >= 81 And a <= 89 Then Puan = ""A2"" If a >= 90 And a <= 100 Then Puan = ""A1"" End Function" Kullanici tanimli foksİyon "Function Sutun2(a As String) As Integer If LCase(a) = LCase(""a"") Then Sutun2 = 1 End Function" Kullanici tanimli(sayfa sayisi) "Function SayfaSec(Hucre As Range) As String Select Case Range(""B1"") Case 0 SayfaSec = ""Sayfa boş"" Case 1 To 51 SayfaSec = Sheets(1).Name Case 52 To 101 SayfaSec = Sheets(2).Name ' ' . ' End Select End Function Veya normal fonksiyonlar ile; =""Sayfa "" & nsat(B1/50) " Kullanilan xl turkce, ingilizce .. Veya ne ? "Sub Test() Dim MyLang As Long MyLang = Application.LanguageSettings.LanguageID(msoLanguageIDInstall) MsgBox GetLang(MyLang) End Sub ' Function GetLang(ID As Long) As String Select Case ID Case msoLanguageIDEnglishUS GetLang = ""XL - Ingilizce"" Case msoLanguageIDTurkish GetLang = ""XL - Turkce"" Case msoLanguageIDRussian GetLang = ""XL - Rusca"" Case msoLanguageIDFrench GetLang = ""XL - Fransizca"" Case msoLanguageIDDutch GetLang = ""XL - Almanca"" Case msoLanguageIDSpanish GetLang = ""XL - Ispanyolca"" Case msoLanguageIDItalian GetLang = ""XL - Italyanca"" Case Else GetLang = ""XL - Belirsiz"" End Select End Function" KuruŞlari hesaplama "On Error Resume Next a = Round(TextBox3, 2) a = WorksheetFunction.Substitute(a, "","", ""."") b = Round(TextBox4, 2) b = WorksheetFunction.Substitute(b, "","", ""."") c = Round(TextBox5, 2) c = WorksheetFunction.Substitute(c, "","", ""."") y = Round(TextBox2, 2) y = WorksheetFunction.Substitute(y, "","", ""."") z = (Val(a) + Val(b) + Val(c)) - Val(y) z = WorksheetFunction.Substitute(z, ""."", "","") TextBox1 = z " Küsuratlı bir parasal tutarın ytl ve ykr kısımlarını ayrı hücrelere yazdırma "B1 hücresine girilecek formül; =TAMSAYI(A1) C1 hücresine girilecek formül; =(A1-TAMSAYI(A1))*100" Label de dikey yazı "Private Sub UserForm_Initialize() Dim Metin As String Dim byt As Byte Label1.Caption = ""Süleyman"" For byt = 1 To Len(Label1) Metin = Metin & Mid(Label1, byt, 1) & Chr(13) Next byt Label1 = Metin End Sub" Label de tarih ve saat yazdırma "Private Sub UserForm_Initialize() Label1.Caption = Format(Now, ""dddd d mmmm yyyy hh:mm:ss"") End Sub " Label lerde ortalama alma Label3 = Format((Val(Label1) + Val(Label2)) / 2, "0.00") Label türetme "Private Sub UserForm_Initialize() Dim NewLabel As Control Me.Width = 600 Me.Height = 300 TopPos = 4 For j = 1 To 5 TopPos = TopPos + 20 LeftPos = 10 For i = 1 To 10 Set NewLabel = Controls.Add(""Forms.label.1"") With NewLabel .Width = 50 .Caption = ""Test"" & i & "" - "" & j .Height = 15 .Left = LeftPos + .Width .Top = TopPos .Tag = i .AutoSize = True .Visible = True End With LeftPos = LeftPos + NewLabel.Width + 15 Next i Next j End Sub" Label1 ve label2 de rakamlar var.Ben label1 ve label2 dekİ rakamlarin ortalamasini label3 te almak İstİyorum "Label1 ve Label2'e değerleri aktardığın kodun/prosedurun sonuna aşağıdakini ilave et; Kod: Label3 = Format((Val(Label1) + Val(Label2)) / 2, ""0.00"") " Label'a istenilen sayfa ve hücreden değer almak "Private Sub UserForm_Initialize() UserForm1.Label1.Caption = Worksheets(""Sayfa1"").Range(""A"" & ActiveCell.Row) End Sub" Labelde tarih formatı "Private Sub UserForm_Initialize() Label1.Caption = Format(Now, ""dddd d mmmm yyyy hh:mm:ss"") End Sub" Label'de tarih ve saat Label1:Captioni = Now Labele tiklayinca açiklama çikar "Private Sub Label1_Click() Label1.Caption = ""Programmer pir"" End Sub" Labeller de toplama, ortalama alma Label3 = Format((Val(Label1) + Val(Label2)) / 2, "0.00") Link koleksiyon "Sub ColorLinks() Dim myLnk As Hyperlink 'Dim wks As Worksheet ' For Each wks In ActiveWorkbook.Worksheets 'For Each myLnk In wks.Hyperlinks For Each myLnk In ActiveSheet.Hyperlinks 'MsgBox myLnk.Parent.Address & vbLf _ & myLnk.Parent.Parent.Name Range(myLnk.Parent.Address).Interior.ColorIndex = 34 Next myLnk ' Next wks End Sub" Lisans programı "Option Explicit Declare Function ShellAbout Lib ""shell32.dll"" _ Alias ""ShellAboutA"" ( _ ByVal hWnd As Long, _ ByVal szApp As String, _ ByVal szOtherStuff As String, _ ByVal hIcon As Long) As Long Declare Function GetActiveWindow Lib ""user32"" () As Long '// Define your message constants here Const strApp As String = ""My Programe"" Const strMyDetails As String = "" Ivan F Moala, 3 Sept, 2001"" Sub About() Dim hWnd As Long Dim x As Long hWnd = GetActiveWindow() x = ShellAbout(hWnd, strApp, Chr(13) & Chr(169) & strMyDetails _ & Chr(13), 0) End Sub" Lİstbox & textbox da verİ gÖrme "BU KOD LİSTBOX'A YAZILACAK Private Sub ListBox1_Change() Dim sira sira = ""veri!b$"" & ListBox1.ListIndex + 1& veri.textbox1.ControlSource = sira End Sub BU KOD LİSTBOX' AYAZILACAK Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Select Case KeyCode Case vbKeyEscape veri.Hide End Select End Sub BU KOD TEXTBOX'A YAZILACAK Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Select Case KeyCode Case vbKeyEscape veri.Hide End Select End Sub " Listbox A dakileri listeler a ya göre b dekini textboxta listele command butonla sil "Private Sub CommandButton1_Click() For X = 1 To Sheets(""sayfa1"").[A65536].End(3).Row If Left(Sheets(""sayfa1"").Cells(X, 1), 100) = TextBox1.Value Then Sheets(""sayfa1"").Rows(X).Delete MsgBox ""SİLİNDİ"" TextBox1.SetFocus End If Next UserForm_Activate End Sub Private Sub ListBox1_Change() X = ListBox1.ListIndex TextBox1.Text = Sheets(""SAYFA1"").Cells(X + 1, 1) End Sub Private Sub UserForm_Activate() For X = 1 To Sheets(""SAYFA1"").[A65536].End(3).Row c = c + 1 ListBox1.AddItem ListBox1.List(c - 1, 0) = Sheets(""SAYFA1"").Cells(X, 1) Next End Sub" Listbox a dan veri alır, tıklayınca textbox b dekini yazar "Private Sub TextBox1_Change() Dim MyRange As Range Dim noA As Integer ListBox1.Clear noA = WorksheetFunction.CountA(Sheets(""Sayfa1"").Range(""A:A"")) For Each MyRange In Sheets(""Sayfa1"").Range(""A1:A"" & noA) If Left(LCase(MyRange), Len(TextBox1)) = LCase(TextBox1) Then ListBox1.AddItem (MyRange) Next End Sub Private Sub ListBox1_Click() Dim x As Integer x = Sheets(""Sayfa1"").Range(""A:A"").Cells.Find(what:=ListBox1, LookIn:=xlValues).Row TextBox1.Value = ListBox1 TextBox2 = Sheets(""Sayfa1"").Cells(x, 2) End Sub" Listbox a for döngüsü ile additem ekleme "Private Sub CommandButton1_Click() Dim Freezer As New FreezeForm Freezer.Freeze Me Dim I As Integer For I = 1 To 1000 ListBox1.AddItem ""Item "" & I DoEvents Next I End Sub" Listbox a sadece dolu hücreleri alma "Private Sub UserForm_Initialize() Dim myrange As Range Dim myrange As Range Set myrange = Range(""A1:A200"") For Each c In myrange If c.Value = ListBox1.Value Then TextBox1.Value = ListBox1.Value & c.Value.Offset(1, 0).Value End If Next End Sub" Listbox a sayfa isimlerini alma "Sub sayfa_isimleri_yaz() Sheets.Add i = 1 s = ActiveSheet.Name For Each sht In ActiveWorkbook.Sheets Sheets(s).Cells(i, 1).Value = sht.Name ’ListBox1.AddItem sht.Name bu da listboxa yazar i = i + 1 Next sht End Sub" Listbox daki herhangi bir kolon değerlerinin toplamını textboxta gösterme "‘listbox1 in 4. kolonunun toplamını textbox1 de Private Sub UserForm_Initialize() For i = 1 To ListBox1.ListCount - 1 T1 = ListBox1.List(i - 1, 3) + T1 ’buradaki 3, 4.kolon numarasıdır. Ona göre 1 eksiğini alınız Next i TextBox1 = T1 End Sub" Lİstbox format sorunu "bu listbox'a değerleri nasıl aktardığınıza göre değişir. örneğin Private Sub UserForm_Initialize() ListBox1.RowSource = ""Sayfa1!a1: a10"" End Sub " Listbox hk "Private Sub CommandButton1_Click() ListBox1.RowSource = ""Sayfa1!a3:g8"" 'lisbox'ta gösterilecek hücre aralığı ListBox1.ColumnCount = 7 ' lisbox'ta ki sütun sayısı End Sub " Listbox index numarasını öğrenme "Private Sub ListBox1_Click() MsgBox ListBox1.ListIndex'sıra numaralı olarak sayfadan aldırıyorsanız eşit olması için +1 eklemelisiniz. End Sub" Listbox indexlerinin aynı anda seçilmesi "Private Sub Listbox1_Click() ListBox2.ListIndex = ListBox1.ListIndex End Sub Private Sub UserForm_Initialize() Sheets(""sayfa9"").Activate ListBox1.RowSource = ""Sayfa9!B1:B5"" ListBox2.RowSource = ""Sayfa9!C1:C5"" End Sub" Listbox özellikleri "Private Sub UserForm_Initialize() ListBox1.RowSource = ""Sayfa1!A1:A10"" 'lisbox'ta gösterilecek hücre aralığı ListBox1.ColumnCount = 5 ' lisbox'ta ki sütun sayısı ListBox1.ColumnWidths = 100 & "";"" & 70 'lisbox'taki sütunların genişliği End Sub" Lİstbox tan seÇİlen hÜcreyİ sİlmek. "ListBoxa verileri RowSource özelliği ile alıyorsanız silmeniz birşey ifade etmiyecektir.Asıl Sayfadaki Bilgileri silmeniz gerekmektedir.Bunun İçin Ã�öyle yapmanı tavsiye ederim.Kodları kendine düzenlersin. Kod: 'ListBox özellikleri belirleniyor Private Sub UserForm_Initialize() a = WorksheetFunction.CountA(Sheets(""Sayfa1"").Range(""A2:A65536"")) + 1 ListBox1.RowSource = ""Sayfa1!A2:D"" & a ListBox1.ColumnCount = 4 ListBox1.ColumnHeads = True ListBox1.ColumnWidths = ""50;100;150;200"" End Sub 'ListBox'dan seçilen aktif hücre oluyor Private Sub ListBox1_Click() Dim i As Integer For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) = True Then Sheets(""Sayfa1"").Select Sheets(""Sayfa1"").Range(""A"" & ListBox1.ListIndex + 2).Select End If Next End Sub 'ListBox Çift Tıklandığında Aktif Satır Siliniyor Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Selection.EntireRow.Delete End Sub " Lİstbox ve combobox a verİ gİrmek "Bunun için userforma aşağıdaki kodu yazmak gerekir,combobox a veri almak tek satırda rowsource komutu ile halledilir. Buna karşın listboxta alınacak veri aralığını tanımlamak yetmez,en azından veri sayısınında belirtilmesi gerekir. Ayrıca ekteki örneğide inceleyiniz. visual basic kodu: Private Sub UserForm_Initialize() ComboBox1.RowSource = ""sayfa1!A1:A10"" 'combobox1'e sayfa1 deki A1:A10 aralığındaki değerleri atar ListBox1.RowSource = ""sayfa1!A2:B10"" 'listbox1'e sayfa1 deki A2:B10 aralığındaki değerleri atar ListBox1.ColumnHeads = True 'listboxta sütun başlıklarını görünür hale getirir burada başlık A1:B1 aralığıdır. ListBox1.ColumnCount = 2 'sütun sayısı-kaç veri varsa o kadar sütun açılmalıdır ListBox1.ColumnWidths = ""40;40"" 'açılan sütunların genişlikleri. End Sub" Lİstbox ve combobox'takİ boŞluklar "Private Sub UserForm_Initialize() For i = 1 To [b65536].End(3).Row If Cells(i, 2) = """" Then GoTo 10 ListBox1.AddItem (Cells(i, 2)) 10 Next End Sub Yine rowsource ile almak isterseniz aşağıdaki gibi en son dolu hücreyide tanıtabilirsiniz. visual basic kodu: Private Sub UserForm_Initialize() listbox1.rowsource=""sayfa1!b1:b"" & [sayfa1!b65536].end(3).row End Sub " Lİstbox veya combobox baŞlik formati "combobox için görünecek satır sayısı için aşağıdaki kodu kullanın. ComboBox1.ListRows = 5 Listebox açılır kutu olmadığı için böyle bir özellik yoktur,sadece yüksekliğini aşağıdaki kod ile değiştirebilirsiniz. ListBox1.Height = 50 her iki koduda UserForm_Initialize olayına yazabilirsiniz." Lİstbox1 İn İÇİndekİ bÜtÜn verİlerİ excel sayfasina yazdirma "Aşağıdaki kodu deneyin. Listboxtaki verileri sayfa2 ye aktarır. visual basic kodu: Private Sub CommandButton1_Click() Set s1 = Sheets(""sayfa2"") sat = ListBox1.ListCount sut = ListBox1.ColumnCount s1.Range(s1.Cells(1, 1), s1.Cells(sat, sut)) = ListBox1.List End Sub" Lİstbox1.Rowsource sorunu "Private Sub UserForm_Initialize() satır = Cells(65536, 1).End(xlUp).Row kolon = Cells(1, 256).End(xlToLeft).Column bbb = Cells(satır, kolon).Address ListBox1.RowSource = ""veri!A2:"" & bbb End Sub" Listbox1'de değişken "Private Sub ListBox1_Click() On Error Resume Next 'hata durumunda hatayı pas geçmesini sağlar TextBox1 = """" 'textbox1 deki veriyi siler a = Sheets(""PerBil"").Range(""D5:D34"").Find(ListBox1.Value).Row 'listbox1 de seçilen ismin, Perbil sayfasındaki D5:D34 aralığında yerini bulur ve satır değerini a değişkenine atar For sira = 8 To 52 'döngü başlangıcı Perbil sayfasının 8(H sütunu) den başlayarak 52(AZ sütunu) ye kadar sütunların taranmasını sağlar If sira <= 19 Then Cells(sira - 4, 7) = Sheets(""Perbil"").Cells(a, sira).Value 'Sicil bilgilerini kayıt dosyasındaki yerine taşır If sira >= 20 And sira < 24 Then Cells(sira - 2, 10) = Sheets(""Perbil"").Cells(a, sira).Value 'tazminat bilgilerini kayıt dosyasındaki yerine taşır If sira >= 24 And sira < 36 Then Cells(sira - 20, 10) = Sheets(""Perbil"").Cells(a, sira).Value 'terfi bilgilerini kayıt dosyasındaki yerine taşır If sira >= 36 And sira < 48 Then Cells(sira - 18, 7) = Sheets(""Perbil"").Cells(a, sira).Value 'kesinti bilgilerini kayıt dosyasındaki yerine taşır If sira >= 48 Then Cells(sira - 24, 10) = Sheets(""Perbil"").Cells(a, sira).Value 'diğer bilgilerini kayıt dosyasındaki yerine taşır Next sira 'döngünün tekrar For komutuna yani başa dönmesini sağlar End Sub" Listboxa alınan adreslerin başına ' karakteri koy "Private Sub UserForm_Initialize() Dim shttemp As Worksheet For Each shttemp In ActiveWorkbook.Worksheets ListBox1.AddItem ""'"" & shttemp.Name & ""'!A1"" Next End Sub" Listboxa çift tıklayarak satırdan ve listboxtan silme "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) ListBox1.RemoveItem ListBox1.ListIndex Rows(ListBox1.ListIndex + 1).Delete End Sub" Listboxa çift tıklayınca textboxa listbox kolonlarındaki değerleri alma "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = ListBox1.List(ListBox1.ListIndex, 0) 'ListBox'a tıkladığımızda değerleri textbox'lara alıyoruz. TextBox2 = ListBox1.List(ListBox1.ListIndex, 1) TextBox3 = ListBox1.List(ListBox1.ListIndex, 2) TextBox4 = ListBox1.List(ListBox1.ListIndex, 3) TextBox5 = ListBox1.List(ListBox1.ListIndex, 4) TextBox6 = ListBox1.List(ListBox1.ListIndex, 5) TextBox7 = ListBox1.List(ListBox1.ListIndex, 6) TextBox8 = ListBox1.List(ListBox1.ListIndex, 7) TextBox9 = ListBox1.List(ListBox1.ListIndex, 8) End Sub" Listboxa hücreden dolu olanları alma "Private Sub UserForm_Activate() X = WorksheetFunction.CountA(Sheets(""Sayfa1"").Range(""A2:A65536"")) + 1 ListBox1.RowSource = ""Sayfa1!b2:b"" & X End Sub" Listboxa sayfa ile birlikte hücre tam adresini alma "Private Sub UserForm_Initialize() Dim i As Long For i = 1 To Worksheets.Count With Me.ListBox1 .AddItem Sheets(i).Name & ""!A1"" End With Next i Me.ListBox1.ListIndex = 0 End Sub " Listboxa sütundan veri aldırma "Private Sub UserForm_Initialize() ListBox1.ColumnCount = 5 ListBox1.RowSource = ""TABLO!A2:S4"" ListBox1.ColumnHeads = True End Sub" Listboxa veri aldırma "ListBox'a aktarılacak veriler aktif sayfada A sütununda ise ve UserForm üzerinde 1 adet ListBox, 1 adet CommandButton varsa; Private Sub UserForm_Initialize() ListBox1.RowSource = ""A1:A"" & Cells(65536, 1).End(xlUp).Row ListBox1.MultiSelect = fmMultiSelectMulti ListBox1.ListStyle = fmListStyleOption End Sub Private Sub CommandButton1_Click() Dim i As Long, x As Long Dim MyArray() For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) = True Then ReDim Preserve MyArray(x) MyArray(x) = ListBox1.List(i) x = x + 1 End If Next For i = LBound(MyArray) To UBound(MyArray) MsgBox ""Secilen deger -"" & i + 1 & "": "" & MyArray(i) Next Erase MyArray End Sub " Lİstbox'in 2ncİ kolonunu nasil yazdirabİlİrİm? " Private Sub CommandButton1_Click() Range(""D1"") = ListBox1.Column(0) Range(""E1"") = ListBox1.Column(1) Range(""F1"") = ListBox1.Column(2) End Sub 'veya; Private Sub ListBox1_Click() Range(""D1"") = ListBox1.Column(0) Range(""E1"") = ListBox1.Column(1) Range(""F1"") = ListBox1.Column(2) End Sub" Listboxla dosya açma kapama silme "x = listbox1 Açma : Workbooks.Open (""Dosya yolu"" & x) Kapama : Workbooks(x).Close SaveChanges:=True/False Silme : Kill (""Dosya yolu"" & x)" Listboxla süzme işlemi "Private Sub CommandButton1_Click() Range(""a1"").AutoFilter Field:=1 End Sub Private Sub ListBox1_Change() Range(""A1"").AutoFilter Field:=1, Criteria1:=ListBox1.Value End Sub Private Sub UserForm_Initialize() Sheets(""Sayfa9"").Activate a = WorksheetFunction.CountA(Range(""A:A"")) For i = 2 To a ListBox1.AddItem Cells(i, 1) Next ListBox1.ColumnCount = 4 ListBox1.ColumnWidths = ""35,35,35,35"" ListBox1.RowSource = ""Sayfa9!a1:d5"" End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Range(""a1"").AutoFilter Field:=1 Selection.AutoFilter End Sub" Listboxta a, al şeklinde sıralama, textboxta sıralayarak "Private Sub TextBox1_Change() TextBox1.Value = UCase(TextBox1.Value) Dim i As Integer ListBox1.Clear For i = 1 To Worksheets.Count - 9 If Left(Worksheets(i).Name, Len(TextBox1)) = TextBox1 Then ListBox1.AddItem Worksheets(i).Name End If Next End Sub" Listboxta dolu hürecelwein listelenmesi "A:A200 Hücrelerindeki verilerden listbox a sadece dolu hücreleri alır. (boş hücreler gözükmez) Kod: Private Sub UserForm_Initialize() Dim myrange As Range Dim myrange As Range Set myrange = Range(""A1:A200"") For Each c In myrange If c.Value = ListBox1.Value Then TextBox1.Value = ListBox1.Value & c.Value.Offset(1, 0).Value End If Next End Sub" Listboxta ilk sayfanın görünmemesi "Private Sub UserForm_Initialize() On Error Resume Next Dim g As Integer Dim i As Integer For i = 2 To Worksheets.Count '3olursa ilk 2 sayfa gözükmez ListBox1.AddItem Worksheets(i).Name Next i End Sub" Listboxta kitaptaki sayfaların listelenmesi "Private Sub UserForm_Activate() For Each Ws In Worksheets frmlis.ListBox1.AddItem Ws.Name Next End Sub" Listboxta listeleme "Private Sub UserForm_Activate() Me.ListBox1.AddItem ""Deniz"" Me.ListBox1.AddItem ""Derya"" Me.ListBox1.AddItem ""İsmail"" Me.ListBox1.AddItem ""Hülya"" Me.ListBox1.AddItem ""Emel"" Me.ListBox1.AddItem ""Ayşe"" End Sub" Listboxta sayfadan veri alma "Private Sub UserForm_Initialize() ListBox1.RowSource = ""Sayfa1!A1:A10"" 'lisbox'ta gösterilecek hücre aralığı ListBox1.ColumnCount = 5 ' lisbox'ta ki sütun sayısı ListBox1.ColumnWidths = 100 & "";"" & 70 'lisbox'taki sütunların genişliği End Sub" Listboxta seçilen satırın silinmesi "ListBox özellikleri belirleniyor Private Sub UserForm_Initialize() a = WorksheetFunction.CountA(Sheets(""Sayfa1"").Range(""A2:A65536"")) + 1 ListBox1.RowSource = ""Sayfa1!A2:D"" & a ListBox1.ColumnCount = 4 ListBox1.ColumnHeads = True ListBox1.ColumnWidths = ""50;100;150;200"" End Sub 'ListBox'dan seçilen aktif hücre oluyor Private Sub ListBox1_Click() Dim i As Integer For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) = True Then Sheets(""Sayfa1"").Select Sheets(""Sayfa1"").Range(""A"" & ListBox1.ListIndex + 2).Select End If Next End Sub 'ListBox Çift Tıklandığında Aktif Satır Siliniyor Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Selection.EntireRow.Delete End Sub" Listboxta sütun ve hücrelerin gösterilmesi "Private Sub UserForm_Initialize() ListBox1.ColumnHeads = True ListBox1.ColumnCount = 50 ListBox1.RowSource = ""Sayfa1!A1:AG200"" End Sub" Listboxta tıklama ile textboxlara aldırma "‘A dan D ye kadar veri yaz ve gör Private Sub ListBox1_Click() Dim x As Integer x = Sheets(""Sayfa1"").Range(""a:a"").Cells.Find(What:=ListBox1, LookIn:=xlValues).Row TextBox1.Value = ListBox1 TextBox2 = Sheets(""Sayfa1"").Cells(x, 2) TextBox3 = Sheets(""Sayfa1"").Cells(x, 3) End Sub Private Sub UserForm_Initialize() ListBox1.RowSource = ""Sayfa1!A1: A500"" End Sub" Listboxta toplam alma "Private Sub çalıştır_Click() ListBox1.Clear ListBox2.Clear Dim i, r, y As Integer Dim s As String Dim q As Date q = ilk For r = 4 To WorksheetFunction.CountA(Range(""C4:C62"")) + 1 If Cells(r, 3).Value = q Then ListBox1.AddItem Cells(r, 6).Value ListBox2.AddItem Cells(r, 7).Value TotalCredit = TotalCredit + Cells(r, 7).Value End If Next r ListBox1.AddItem ""TOPLAM :"" & TotalCredit & "" KİŞİ KALACAK"" ListBox2.AddItem ""TOPLAM :"" & TotalCredit & "" KİŞİ KALACAK"" End Sub" Listboxtaki addıtem i yeniden adlandırma "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim Pos% Dim Neu$ Neu = InputBox(""Neuen Eintrag eingeben:"") If Neu = """" Then Exit Sub With ListBox1 Pos = .ListIndex .RemoveItem (.ListIndex) .AddItem Neu, Pos End With End Sub" Listboxtaki adrese çift tıklamayla gider ve form kapanır "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim addy As String addy = ListBox1.Text Unload Me Application.Goto Range(addy) End Sub" Listboxtaki adrese çift tıklamayla gider ve form kapanır2 "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim i As Long, Pos As Long Dim strSheet As String, strAddy As String With Me.ListBox1 For i = 0 To .ListCount - 1 If .Selected(i) Then Pos = i: Exit For Next i If i = .ListCount Then Exit Sub strSheet = Left(.List(i), InStr(1, .List(i), ""!"") - 1) strAddy = Right(.List(i), Len(.List(i)) - Len(strSheet) - 1) Sheets(strSheet).Activate Range(strAddy).Activate End With Unload Me End Sub" Listboxtaki adrese çift tıklamayla gitme "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) 'Check for range addresses If ListBox1.ListCount = 0 Then Exit Sub 'GoTo doubled clicked address Application.Goto Range(ListBox1.Text), True End Sub" Listboxtaki adrese çift tıklamayla gitme2 "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Application.Goto Range(ListBox1.List(ListBox1.ListIndex)) End Sub" Listboxtaki adrese tek tıklamayla gitme "Private Sub ListBox1_Click() 'Check for range addresses If ListBox1.ListCount = 0 Then Exit Sub 'GoTo doubled clicked address Range(ListBox1.Text).Parent.Activate Application.Goto Range(ListBox1.Text), True End Sub" Listboxtaki hücrenin bulunduğu satırı çift tıklamayla seçer gider ve form kapanır "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Application.Goto Range(ListBox1).EntireRow Unload Me End Sub" Listboxtaki kolonun tarih formatı Format(ListBox1.Column(8), "dd.mm.yyyy") Listboxtaki kolonun tarih formatı "On satırlık bir listboxta tarihlerin ilk sütunda olduğunu varsayarak yazıyorum. For i = 0 To 9 ListBox1.List(i, 0) = Format(ListBox1.List(i, 0), ""dd.mm.yyyy"") Next i 'Yukarıdaki kodda i satır numarasını, 0 sütun numarasını göstermektedir." Listboxtaki sayıların toplamı textboxta "Private Sub CommandButton8_Click() toplam = 0 For i = 1 To ListBox1.ListCount toplam = toplam + Val(ListBox1.List(i - 1)) Next i TextBox1 = toplam End Sub" Lİstboxtakİ verİlerİ ÇaliŞma sayfasina nasil aktaririm? " sat1=listbox1.listcount sut1=listbox1.columncount sonsat1=[i65536].end(3).row+1 range(cells(sonsat1,""i""),cells(sat1+sonsat1,sut1+9))=listbox1.list sat2=listbox2.listcount sut2=listbox2.columncount sonsat2=[b65536].end(3).row+1 range(cells(sonsat2,""b""),cells(sat2+sonsat2,sut2+2))=listbox2.list" Listboxtaki verileri sayfaya aktarma "Private Sub CommandButton1_Click() Set s1 = Sheets(""sayfa2"") sat = ListBox1.ListCount sut = ListBox1.ColumnCount s1.Range(s1.Cells(1, 1), s1.Cells(sat, sut)) = ListBox1.List End Sub" Listboxtaki veriyi enterla seçmek (faresiz yani) " Private Sub ListBox1_Change() TextBox1 = ListBox1 End Sub ' Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ListBox1.SetFocus End Sub" Listboxtakileri topla mesaj ver "Private Sub CommandButton1_Click() z = 0 For i = 1 To ListBox1.ListCount z = z + Val(ListBox1.List(i - 1)) Next i MsgBox z End Sub" Listboxtakilerin yeni kitaba kaydı "Private Sub CommandButton1_Click() Dim xlApp As Object Set xlApp = CreateObject(""Excel.Application"") xlApp.Visible = False Set NewWB = xlApp.Workbooks.Add Set MySh = NewWB.Worksheets(1) nRow = ListBox1.ListCount nColumn = ListBox1.ColumnCount MySh.Range(""A1"", Cells(nRow, nColumn).Address) = ListBox1.List WBname = ""C:\"" & (TextBox3.Text) & "".xls"" NewWB.SaveAs WBname MsgBox WBname & "" Adında Bir Excel Kitabı oluşturulmuştur "", _ vbInformation, ""AKD.YAZILIM"" xlApp.Quit Set xlApp = Nothing Set MySh = Nothing Set NewWB = Nothing End Sub " Lİstbox'tan combobox'a verİ almak "Private Sub ListBox1_Click() Userform1.ComboBox1.Value = Userform2.ListBox1.Column(0) End Sub " Lİstbox'tan textbox'a aktarilan deĞer ayni bİÇİmde Çik "Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""#,##0.00"") End Sub" Lİstboxtan verİ sİlmek "If MsgBox(""Seçtiginiz Veri Silinecek,Eminmisiniz?"",vbYesNo) = vbYes Then sil = Sheets(""DATA"").Columns(1).Find(ListBox1.Value).Row Sheets(""DATA"").Rows(sil).Delete End If" Listede 1 den fazla olanların 1 adet olarak listelenmesi "Private Sub CommandButton1_Click() On Error GoTo yanlis ListBox1.AddItem (Columns(2).Find(What:=TextBox1, LookAt:=xlWhole)) yanlis: If Err Then MsgBox ""Bulamadım!"" End Sub" Lİstedekİlerİ excelle gÖnder "Private Sub CommandButton1_Click() Dim xlApp As Object Set xlApp = CreateObject(""Excel.Application"") xlApp.Visible = False Set NewWB = xlApp.Workbooks.Add Set MySh = NewWB.Worksheets(1) nRow = ListBox1.ListCount nColumn = ListBox1.ColumnCount MySh.Range(""A1"", Cells(nRow, nColumn).Address) = ListBox1.List WBname = ""C:\"" & (TextBox3.Text) & "".xls"" NewWB.SaveAs WBname MsgBox WBname & "" Adında Bir Excel Kitabı oluşturulmuştur "", _ vbInformation, ""AKD.YAZILIM"" xlApp.Quit Set xlApp = Nothing Set MySh = Nothing Set NewWB = Nothing End Sub " Lİstenİn en sonuna yapiŞtirma "Bunun için benim bildiğim kadarıyla 3 yol mevcut, bunlar; 1-Makro içinde worksheetfunction.CountA kodu ile 2-Cells(65536, 1).End(xlUp).Row kodu ile 3-BAÃ�_DEÃ�_DOLU_SAY( ) formülünü bir hücreye yazarak burdan aldığınız veri ile " Llistede kaç kişi olduğunu bulmanın kısayolu. "Diyelimki Excelde hazırladığımız bir isim listemiz var ve biz bunları A1 hücresi ile A9000 hücreleri arasına kaydediyoruz. Kayıtlı (dolu) hücre sayısını programa aktarırken şu kodu kullanabiliriz: Sub DoluKayitSayisi() Sayi=WorksheetFunction.CountA(Range(""A1:A9000"")) 'Eğer mesajla almak isterseniz şu koduda ekleyin MsgBox Sayi End Sub" Macro Çalışırken İmlecin hareket etmemesini sağlayan kodlar "Sub imlecidondur() Application.EnableEvents = False Range(""a1"").Value = ""Aşkın"" Application.EnableEvents = True End Sub" Macro İle koŞullu sİlme "Sub sil() For i = Cells(65536, 1).End(xlUp).Row To 2 Step -1 If Trim(Cells(i, 1)) <> ""SARF FİÃ�İ"" And Trim(Cells(i, 1)) <> ""TOPTAN SATIÃ� İRSALİYESİ"" Then Rows(i & "":"" & i).Delete Shift:=xlUp End If Next i End Sub" Macro İle satir aÇma "Sub Test() Dim NoB As Long Dim ii As Long Dim i As Integer Dim j As Integer Dim MyRng As Range Application.ScreenUpdating = False For i = 1 To Worksheets.Count Sheets(i).Select ii = 0 j = 0 NoB = Cells(65536, 2).End(xlUp).Row For ii = NoB To 5 Step -1 If Trim(Cells(ii, 2)) = Trim(""Net Miktar"") Then Rows(ii + 1).Select For j = 1 To 6 Selection.Insert Shift:=xlDown Next End If Next For ii = 5 To Cells(65536, 2).End(xlUp).Row If Trim(Cells(ii, 2)) = Trim(""Smm Satış"") Then Rows(ii).Delete Next Next Application.ScreenUpdating = True End Sub " Maİl gÖnderİmİ outlok İle "Sub EmailSheet() Dim OutlookApp As Object, OutlookMsg As Object Dim FSO As Object, BodyText As Object Dim MyRange As Range, TempFile As String 'On Error Resume Next Set MyRange = ActiveSheet.UsedRange If MyRange Is Nothing Then Exit Sub Set FSO = CreateObject(""Scripting.FilesystemObject"") TempFile = ""C:\TempHTML.htm"" ActiveWorkbook.PublishObjects.Add _ (4, TempFile, MyRange.Parent.Name, MyRange.Address, 0, """", """").Publish True Set OutlookApp = CreateObject(""Outlook.Application"") Set OutlookMsg = OutlookApp.CreateItem(0) Set BodyText = FSO.OpenTextFile(TempFile, 1) OutlookMsg.HTMLBody = BodyText.ReadAll OutlookMsg.Subject = ""Merhaba !"" OutlookMsg.To = ""excalub@yahoo.com"" 'OutlookMsg.Display OutlookMsg.Send 'Kill TempFile Set BodyText = Nothing Set OutlookMsg = Nothing Set OutlookApp = Nothing Set FSO = Nothing End Sub" Makro bitince tekrar baştan aldırma (döngü) "for a=1 to 50 Sheets(""Ana Liste"").Select Rows(""1:1"").Select Selection.Insert Shift:=xlDown Sheets(""Sayfa"" & a).Select Range(""C3"").Select Selection.Copy next a" Makro çalıştırma 5 dakikada bir "Sub aralıklı_calıstır() Application.OnTime Now + TimeValue(""00:05:00""), ""makro1"" End Sub Sub makro1() msgbox(""transfer başlıyor"") ' sizin kodlarınız ' call aralıklı_calıstır End sub " Makro içinde tamsayı ve tavana yuvarlama "TavanaYuvarla için MsgBox WorksheetFunction.Ceiling(25.32, 1) Tamsayı için MsgBox Int(25.32) Aşağıdaki şekilde de kullanmanız mümkündür. ActiveCell = ""=INT(10.65)"" ActiveCell= ""=CEILING(25.32,1)""" Makro İÇİnde yazilan mesaj metnİnİ deĞİŞtİrmek "Private Sub CommandButton6_Click() sor = MsgBox(""SİLMEK İSTEDİĞİNİZDEN EMİNMİSİNİZ ?"", vbYesNo) If sor = vbNo Then Exit Sub Application.Wait Now + TimeValue(""00:00:02"") / 1.5 CommandButton6.Caption = ""SİL"" 'sat = ListBox1.ListIndex + 2 'Range(""B"" & sat & "":I"" & sat).Delete '[a65536].End(2).Delete Shift:=xlUp Sheets(""STOKLAR"").Rows(Sheets(""STOKLAR"").Columns(1).Find(ListBox1.Value).Row).Delete MsgBox ""SEÇİLEN KAYIT SİLİNMİŞTİR"" End Sub" Makro İle ayni olan hÜcrelerİ sİlme. "aşağıdaki makro sadece hücredeki değerleri siler. Sub Makro1() x = WorksheetFunction.CountA(Range(""A1:A65000"")) For a = 1 To x b = Cells(a, 1).Value For c = a + 1 To x d = Cells(c, 1).Value If b = d Then Cells(c, 1).ClearContents End If Next c Next a End Sub " Makro İle belİrlİ bİr hÜcreye sayfa sayisi yazdirma "Aşağıdaki kodu deneyin. Yazdırılacak sayfa sayısını verir. Sub sayfasay() Application.ScreenUpdating = False ActiveWindow.View = 2 say = ActiveSheet.HPageBreaks.Count + 1 ActiveWindow.View = 1 MsgBox say End Sub" Makro ile birleştir formülünü oluşturma "Çalışma sayfasının kod bölümüne girilecek kodlar: Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 1 And Target.Row = 1 Then X = [A1] & [A2] & [A3] & [A4] & [A5] [A1] = X End If End Sub " Makro İle dosya aÇma problemİ Workbooks.Open Filename:=activeworkbook.path & "\satis.xls" Makro ile form import etmek "Makro ile Import için; Sub import_form() Application.VBE.ActiveVBProject.VBComponents.Import (""C:\Documents and Settings\bulent\Desktop\UserForm1.frm"") End Sub 'C:\Documents and Settings\bulent\Desktop\UserForm1.frm - dosya yolunu kendinize uyarlayın" Makro ile geri al (undo) Application:Undo Makro İle gİzledİĞİmİz sheet İ aÇmak İÇİn yazacaĞimiz makraya Şİfre sormasini saĞlaya bİlİrmİyİz "VBA da thisworkbook kısmına Kod: Private Sub Workbook_SheetActivate(ByVal Sh As Object) If LCase(Sh.Name) = ""sheet1"" Or LCase(Sh.Name) = ""sheet2"" Then If InputBox(""şifreyi girin"") <> ""sifre"" Then Sh.Visible = False End If End Sub" Makro ile hücre birleştirme Range("A1:D1").Merge Makro İle kopyalama ve yapiŞtirma "Private Sub Worksheet_Activate() Set Sh1 = Sheets(""Sevk"") Set Sh2 = Sheets(""Anasayfa"") If Sh2.Range(""E8"").FormulaR1C1 <> """" Then Sh1.[C3] = Sh2.[Z2] 'Kurum Adı' Sh1.[D11] = Sh2.[Z3] 'Kurum Amiri' Sh1.[D12] = Sh2.[Z4] 'Kurum Amirinin Unvanı' Sh1.[C5] = Sh2.[Z5] 'Memurun Adı Soyadı' Sh1.[C7] = Sh2.[Z6] 'Memurun Unvanı' Sh1.[E5] = Sh2.[Z7] 'Hastanın Adı Soyadı' Sh1.[C15] = Sh2.[Z8] 'Sağlık Kurumu' Sh1.[F11] = Sh2.[Z9] 'Tarih' Sh1.[C9] = Sh2.[Z10] 'Adres' Sh1.[F3] = Sh2.[Z11] 'T.C. Kimlik No' Sh1.[E7] = Sh2.[Z12] 'Sicil No' Sh1.[F7] = Sh2.[Z13] 'Derece/Kadro' Sh1.[F13] = Sh2.[Z14] 'Sayı' End If Set Sh1 = Nothing Set Sh2 = Nothing End Sub " Makro İle sayfa sİlmek "Sub Sayfa_Sil() Dim sil As String Application.DisplayAlerts = False sil = ActiveSheet.Name Sheets.Add Sheets(sil).Select ActiveWindow.SelectedSheets.Delete Application.DisplayAlerts = True End Sub" Makro ile tarih çıkarma cevap gün olarak "Sub DatumVBA() MsgBox CLng(CDate(""29.11.2005"")) - CLng(CDate(""05.04.1978"")) End Sub" Makro istediğim tarihten sonra açılmasın "kodların başına If Date>=Cdate(""23.02.2006"") then Exit sub 'satırını ilave ediniz" Makro kodlarında hata mesajı verdirme "Sub ErrHand() On Error GoTo ErrorHandler n = 10 Selection.SpecialCells(xlConstants).Select x = Selection.Areas MsgBox (x) Exit Sub ErrorHandler: Select Case Err.Number Case 104 MsgBox (""104"") Exit Sub Case Else MsgBox ""Runtime Error: "" & Err.Number & vbNewLine & Err.Description Stop Resume End Select End Sub" Makroda bİr veya bİrden Çok deĞer dÖndÜrmek "bu dosyanın amacı sadece filtre yönetimini genelleştirmek olduğu için başka bir şeye ihtiyaç duymadım. yani marifet formda değil kodlarda. Anlaşılan hala anlatım zorluğu çekiyorum. bu modul tek kriterli olan tüm filtreler için kullanılabilir. kodlar aynen şöyle visual basic kodu: Global adres As String 'excel.web.tr'den 'Bu Makro genel filtre amaçlıdır. ' ***** ' AÇIKLAMA ' ***** // Örnekler 'KaynakSayfa : Filrelemenin yapılacağı sayfa // ""stok"" 'FiltreBaşlığı : Filtrelenmek istenen tablonun başlığı // ""A1:C1"" 'FiltreAlanı : Filtrenin uygulanacağı alan // 3 ""yani c1 hücresi"" 'Ölçüt : Büyüklük,küçüklük (>,<,=,<>..) // ""="" 'Kriter : Filtrelenen değer // Combobox1.text 'AdresAlanı : Filtre sonucu alınmak istenen verilerin alanı // ""A1:B1"" 'HedefSayfa : Filtrelenen verilerin kopyalanacağı sayfa // ""stok"" 'HedefAlan : Filtrelenen verilerin kopyalanacağı alan // ""H1:I1"" 'NOT:Hata denetim işlemleri henüz yapılmadı Sub AdresAl(KaynakSayfa, FiltreBaşlığı, Ölçüt, Kriter, AdresAlanı, HedefSayfa, HedefAlan As String, FiltreAlanı As Integer) Application.ScreenUpdating = False Sheets(HedefSayfa).Select Range(Range(HedefAlan), Range(HedefAlan).End(xlDown)).Clear Sheets(KaynakSayfa).Select Range(FiltreBaşlığı).AutoFilter Range(FiltreBaşlığı).AutoFilter Field:=FiltreAlanı, Criteria1:=Ölçüt & Kriter, Operator:=xlAnd Range(Range(AdresAlanı), Range(AdresAlanı).End(xlDown)).Copy Sheets(HedefSayfa).Select Range(HedefAlan).Select ActiveSheet.Paste Sheets(KaynakSayfa).AutoFilterMode = False Application.CutCopyMode = False adres = HedefSayfa & ""!"" & Range(Range(HedefAlan), Range(HedefAlan).End(xlDown)).Address End Sub kullanmak için örnek kodlar: visual basic kodu: Private Sub ComboBox1_Change() Call AdresAl(""stok"", ""A1:C1"", ""="", ComboBox1.Text, ""A1:B1"", ""stok"", ""H1:I1"", 3) ListBox1.RowSource = adres End Sub visual basic kodu: Private Sub ComboBox2_Change() Call AdresAl(""firma"", ""A1:C1"", ""="", ComboBox2.Text, ""A1:B1"", ""firma"", ""H1:I1"", 3) ListBox2.RowSource = adres End Sub " Makroda bul ve kopyala yapiŞtir "aşağıdaki örnek işinizi görür sanırım; Makroyu çalıştırdığın sayfada işlem yapar. Kod: Sub arabul() ara = Application.InputBox(prompt:=""Aranacak Veri?"", Type:=3) Range(""A3:A341"").Select Selection.Find(What:=ara, After:=ActiveCell, LookIn:=xlFormulas, LookAt _ :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ False, SearchFormat:=False).Activate satir = ActiveCell.Row Range(Cells(satir, 2), Cells(satir, 8)).Select Selection.Copy Sheets(""Sayfa1"").Select Range(""A2"").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True End Sub" Makroda hesaplanıyor mesajı "Private Sub Tamam_Click() Application.StatusBar = ""Hesaplama Yapılıyor"" Tamam.Enabled = False 'Hesaplama ile ilgili kodlar ' ' 'Hesaplama ile ilgili kodlar Application.StatusBar = ""Hesaplama Tamamlandı"" Tamam.Enabled = True End Sub" Makro'da kenarlik ? "Sub TestRng() Dim rng As Range Set rng = Range(""A2:b4"") 'Excel macro test code 'Note iRow = Start Row of Range and iRow2= Ending Row of Range 'Set rng = oXLApp.Range(Cells(iRow, 1), oXLApp.Cells(iRow2,1).End(xlToRight)) grid rng End Sub Sub grid(rng) rng.Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End Sub" Makrolar kutusu ve makrolar gÖrÜnsÜn "Aşağıdaki kodlarla makrolar kutusunun görünmemesini sağladım. Fakat şimdi tekrar eski konumuna dönsün istiyorum. Bu kodları henüz bitirmediğim bir çalışma dosyamda denedim.Daha sonra iptal etmek için araç çubukları üzerinde sağ tıklayıp modülden auto_open ve auto_close makrolarından bu kodları sildim ama yinede araç çubuklarında makrolar görünmüyor. Yardımcı olursanız sevinirim. Teşekkürler. Kod: Sub auto_open() Application.CommandBars(""Worksheet Menu Bar"").Controls(6).Controls(""Makro"").Enabled = False Application.OnKey ""%{F11}"", ""mesaj"" End Sub Sub auto_close() Application.CommandBars(""Worksheet Menu Bar"").Controls(6).Controls(""Makro"").Enabled = True Application.OnKey ""%{F11}"" End Sub Sub mesaj() MsgBox ""Makrolar gizli!!"" End Sub ' Başka bir dosyada sizin yukarıdaki auto_close prosedurunu yerleştirip, çalıştırın. Veya aşağıdakini deneyin; Kod: Sub Panzehir() Application.CommandBars(""Worksheet Menu Bar"").Reset Application.OnKey ""%{F11}"" End Sub Eğer kodları yerleştirmek için VBE kısmına ulaşamıyorsanız, aşağıdaki dosyayı indirip, açın. Bu arada ufak bir hatırlatma; İngilizce Office yüklü bir bilgisayarda kodlarınız hata verecektir çünkü, menülere ""etiket - başlık"" ile referans vermişiniz. Bunun yerine menünün ID özelliğini kullanırsanız İngilizce-Türkçe- bütün versiyonlarda kodlar çalışır. Ayrıca, menülerini özelleştiren birisinin bilgisayarında menü çubuğunda 6ncı menü ""Tools-Araçlar"" menüsü olmayabilir ve bu nedenle de yine hata verebilir. Bu yüzden menülere her zaman ID'leri ile referans vermekte fayda vardır. Aşağıdaki resimde görüldüğü gibi, ""Makro"" veya ""Makrolar"" menüsü/dialog kutusu veya kod sayfası yani VBE (Visual Basic Editor)'ün kendisi Excel'in çeşitli yerlerinden aktive edilebilir. Örneğin, sayfa sekmesi üzerinde farenin sağ tuşuna basarak, Excel'in menü çubuğundaki Excel ikonunun üzerinde farenin sağ tuşuna basarak, normal yollarlla menülerden, Visual Basic araç çubuğundan, . Bu durumda benim önerim aşağıdaki gibidir; Kod: Sub Auto_Open() Application.CommandBars.FindControl(ID:=30017).Enabled = False Application.CommandBars.FindControl(ID:=186).Enabled = False Application.CommandBars.FindControl(ID:=1561).Enabled = False Application.CommandBars(""Ply"").FindControl(ID:=1561).Enabled = False Application.CommandBars(""Document"").FindControl(ID:=1561).Enabled = False Application.CommandBars(""Visual Basic"").Enabled = False Application.CommandBars(""Control ToolBox"").Enabled = False Application.OnKey ""%{F11}"", ""Mesaj"" Application.OnKey ""%{F8}"", ""Mesaj"" End Sub ' Sub Auto_Close() Application.CommandBars.FindControl(ID:=30017).Enabled = True Application.CommandBars.FindControl(ID:=186).Enabled = True Application.CommandBars.FindControl(ID:=1561).Enabled = True Application.CommandBars(""Ply"").FindControl(ID:=1561).Enabled = True Application.CommandBars(""Document"").FindControl(ID:=1561).Enabled = True Application.CommandBars(""Visual Basic"").Enabled = True Application.CommandBars(""Control ToolBox"").Enabled = True Application.OnKey ""%{F11}"" Application.OnKey ""%{F8}"" End Sub ' Sub Mesaj() MsgBox ""Makrolar gizli!!"" End Sub Dip Not: Eğer amaç kullanıcıdan makroları gizlemekse; makroların olduğu modulün en üstüne aşağıdaki satırı yerleştirdiğinizde, kullanıcı bahsettiğiniz menüler aktifken bile sözkonusu moduldeki makrolar listelenmez. Çünkü o modül tıpkı sayfa veya UserForm modulleri gibi ""Private-Özel"" bir modül olacaktır. " Makroları otomatik açılması, çalışması, kapanması "Dim RunWhen As Double Const RunWhat = ""Info"" Sub Auto_Open() StartTimer End Sub Sub StartTimer() RunWhen = Now + TimeSerial(0, 0, 5) Application.OnTime earliesttime:=RunWhen, procedure:=RunWhat, schedule:=True End Sub Sub Info() ' Aşağıdaki satırda yer alan MsgBox fonksiyonu yerine, ' çalıştırılmasını istediğiniz başka bir makronun adını yazarak ' o makronun çalıştırılmasını sağlayabilirsiniz. MsgBox ""Dikkat, sayfayi güncelleyin !"" StartTimer End Sub Sub StopTimer() On Error Resume Next Application.OnTime earliesttime:=RunWhen, procedure:=RunWhat, schedule:=False End Sub Sub Auto_Close() StopTimer End Sub " Makroların istenilen sayfada çalışması "Sub Auto_Open() If ActiveSheet.Name = ""Sayfa1"" Then Range(""B3"") = ""Evren1"" 'Buraya Call::::::. makro ismi de yazılabilir End If End Sub Sub z() If ActiveSheet.Name = ""Sayfa1"" Then Range(""B4"") = ""Evren2"" 'Buraya Call::::::. makro ismi de yazılabilir End If End Sub" Makrolarınız gizli olsun diyorsanız " Sub auto_open() Application.CommandBars(""Worksheet Menu Bar"").Controls(6).Controls(""Makro"").Enabled = False Application.OnKey ""%{F11}"", ""mesaj"" End Sub Sub auto_close() Application.CommandBars(""Worksheet Menu Bar"").Controls(6).Controls(""Makro"").Enabled = True Application.OnKey ""%{F11}"" End Sub Sub mesaj() MsgBox ""Makrolar gizli!!"" End Sub " Makrolariniz gİzlİ olsun dİyorsaniz "kodları kopyala alt+F11-insert-module 'den sonra yapıştırarak kullanabilirsiniz Kolay gelsin Kod: Sub auto_open() Application.CommandBars(""Worksheet Menu Bar"").Controls(6).Controls(""Makro"").Enabled = False Application.OnKey ""%{F11}"", ""mesaj"" End Sub Sub auto_close() Application.CommandBars(""Worksheet Menu Bar"").Controls(6).Controls(""Makro"").Enabled = True Application.OnKey ""%{F11}"" End Sub Sub mesaj() MsgBox ""Makrolar gizli!!"" End Sub " Makronun ÇaliŞmasi a1 hÜcresİne 1000 yazip aŞaĞidakİ kodu ÇaliŞtirin "A1 hücresine 1000 yazıp aşağıdaki kodu çalıştırın. Kod: Sub sıfır() Do Until [a1] = 0 [a1] = [a1] - 1 Loop End Sub" Makronun otomatİk olarak acİlmasİ ve calİsmasİ "Aşağıdakileri sözkonusu dosyada yeni bir module yapıştırdıktan sonra kaydedin ve kapatın. Daha sonra dosyayı tekrar açın. Kod: Dim RunWhen As Double Const RunWhat = ""Info"" ' Sub Auto_Open() StartTimer End Sub ' Sub StartTimer() RunWhen = Now + TimeSerial(0, 0, 5) Application.OnTime earliesttime:=RunWhen, procedure:=RunWhat, schedule:=True End Sub ' Sub Info() ' Aşağıdaki satırda yer alan MsgBox fonksiyonu yerine, ' çalıştırılmasını istediğiniz başka bir makronun adını yazarak ' o makronun çalıştırılmasını sağlayabilirsiniz. MsgBox ""Dikkat, sayfayi güncelleyin !"" StartTimer End Sub ' Sub StopTimer() On Error Resume Next Application.OnTime earliesttime:=RunWhen, procedure:=RunWhat, schedule:=False End Sub ' Sub Auto_Close() StopTimer End Sub " Makronun sadece bulunulan dosyada çalışması "‘Yaptırdığınız işlemlerin başına Thisworkbook ekleyerek yapabilirsiniz. ThisWorkbook.Sheets(1) ." Makroyla buton eklemek "Sub butonekle() ActiveSheet.Buttons.Add(10, 5, 50, 20).Select Selection.OnAction = ""Makro1"" End Sub" Makroyla email gÖnderme "Sub sayfa_send() ActiveSheet.Select ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=""c:\Part of "" & ThisWorkbook.Name & "" "" & strdate ActiveSheet.Cells.Copy ActiveSheet.Cells.PasteSpecial xlPasteValues ActiveSheet.Cells.ClearComments ActiveSheet.Buttons.Delete ActiveSheet.Range(Columns(71), Columns(256)).Delete ActiveWorkbook.Save ActiveWorkbook.SendMail ""serdarguyuk@dianatravel.com.tr"", ""CAR HİRE"" fname = ActiveWorkbook.FullName ActiveWorkbook.Close Kill fname End Sub" Makroyu ÇaliŞtiran makro "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target = ""AHMET"" Then Run ""Module1.Makro3"" End If End Sub" Makroyu makro içinden çağırmak için "bir makronun içinden başka bir makroyu çağırmak için Application.Run ""kitap1.xls'!Sayfa1.baskamakro"" gibi bir komut kullanabilirsiniz:" Makroyu makro içinden çağırmak için 2 "run (""denememakrosu"") şeklindede olabilir:" Masaüstündeki xls uzantılıları yazar "Sub MostRecent() Dim J As Integer For J = 1 To Application.RecentFiles.Count Cells(J, 1) = Application.RecentFiles(J).Name Next J End Sub" Masaüstüne ikon oluşturma "Thisworkbooka 'Private Sub Workbook_Open() ' Call DShortCut(ThisWorkbook.FullName) 'End Sub 'Modüle Sub Dektop_Icon_anlegen() Call DShortCut(ThisWorkbook.FullName) End Sub Function DShortCut(strFullFilePathName As String) As Long ' Ursprüngliche Version von Myrna Larson in VBS ' Für VBA umgebaut von klausimausi64 ' Uses the Windows Scripting Host to create a .lnk ' shortcut on the user's desktop. ' Parameters: strFullFilePathName - String - The full name of ' the file to which the shortcut will point. ' Returns: 1 = success, 0 = target doesn't exist, -1 = other error ' Example: Call DShortCut (""C:\Program Files\Microsoft Office 97\Office\Examples\SAMPLES.XLS"") Dim WSHShell As Object Dim WSHShortcut As Object Dim strDesktopPath As String Dim strFileName As String Dim strPath As String On Error GoTo ErrHandler ' Create a Windows Shell Object Set WSHShell = CreateObject(""wscript.Shell"") ' Get the file's name and path strFileName = Dir(strFullFilePathName) strPath = Left(strFullFilePathName, Len(strFullFilePathName) - Len(strFileName)) ' Make sure file exists If Not Len(strFileName) = 0 Then ' Read desktop path using WshSpecialFolders object strDesktopPath = WSHShell.SpecialFolders.Item(""Desktop"") ' Create a shortcut object on the desktop Set WSHShortcut = WSHShell.CreateShortcut(strDesktopPath & ""\"" & strFileName & "".lnk"") ' Set shortcut object properties and save it With WSHShortcut .TargetPath = WSHShell.ExpandEnvironmentStrings(strFullFilePathName) .WorkingDirectory = WSHShell.ExpandEnvironmentStrings(strPath) .WindowStyle = 4 .IconLocation = WSHShell.ExpandEnvironmentStrings(Application.Path & ""\excel.exe , 0"") .Save End With DShortCut = 1 Else DShortCut = 0 End If Continue: Set WSHShell = Nothing Exit Function ErrHandler: DShortCut = -1 Resume Continue End Function" Masaüstüne kısayol oluşturma iconlu "Sub Dektop_Icon_anlegen() Call DShortCut(ThisWorkbook.FullName) End Sub Function DShortCut(strFullFilePathName As String) As Long Dim WSHShell As Object Dim WSHShortcut As Object Dim strDesktopPath As String Dim strFileName As String Dim strPath As String On Error GoTo ErrHandler ' Create a Windows Shell Object Set WSHShell = CreateObject(""wscript.Shell"") ' Get the file's name and path strFileName = Dir(strFullFilePathName) strPath = Left(strFullFilePathName, Len(strFullFilePathName) - Len(strFileName)) ' Make sure file exists If Not Len(strFileName) = 0 Then ' Read desktop path using WshSpecialFolders object strDesktopPath = WSHShell.SpecialFolders.Item(""Desktop"") ' Create a shortcut object on the desktop Set WSHShortcut = WSHShell.CreateShortcut(strDesktopPath & ""\"" & strFileName & "".lnk"") ' Set shortcut object properties and save it With WSHShortcut .TargetPath = WSHShell.ExpandEnvironmentStrings(strFullFilePathName) .WorkingDirectory = WSHShell.ExpandEnvironmentStrings(strPath) .WindowStyle = 4 .IconLocation = WSHShell.ExpandEnvironmentStrings(Application.Path & ""\excel.exe , 0"") .Save End With DShortCut = 1 Else DShortCut = 0 End If Continue: Set WSHShell = Nothing Exit Function ErrHandler: DShortCut = -1 Resume Continue End Function " Maskeleme kodu "Private sub userform activate Dim control For each control In form1.controls If TypeOf control Is MaskEdBox Then control.Mask= “##/##/####” Next End sub" Menu ve komutları etkin, seçilebilir "Sub menükomutlarıaç() Dim Ctrl As Office.CommandBarControl For Each Ctrl In Application.CommandBars.FindControls(Id:=847) Ctrl.Enabled = True 'True menüleri aktif yapar Next Ctrl For Each Ctrl In Application.CommandBars.FindControls(Id:=889) Ctrl.Enabled = True 'True menüleri aktif yapar Next Ctrl End Sub" Menu ve komutlarının iptali, seçilemez "Sub menükomutlarıiptal() Dim Ctrl As Office.CommandBarControl For Each Ctrl In Application.CommandBars.FindControls(Id:=847) Ctrl.Enabled = False 'True menüleri aktif yapar Next Ctrl For Each Ctrl In Application.CommandBars.FindControls(Id:=889) Ctrl.Enabled = False 'True menüleri aktif yapar Next Ctrl End Sub" Menü çubuğunu ve tam ekranı gizle "Sub Düğme1_Tıklat() Application.CommandBars.ActiveMenuBar.Enabled = True Application.DisplayFullScreen = True Application.CommandBars(""Full Screen"").Enabled = False End Sub" Menü çubuğunun silinmesi ve özel bir menünün oluşturulması "Sub Auto_Open() a = MenuBars(xlWorksheet).Menus.Count For i = a To 1 Step -1 MenuBars(xlWorksheet).Menus(i).Delete Next Dim AnaMenü As CommandBarControl, AnaAltMenü As CommandBarControl Sheets(""Sayfa1"").Select Range(""a1"").Select '.. 'Ana Menüye Menü ekler Set AnaMenü = Application.CommandBars(1).Controls.Add(msoControlPopup, , , , True) With AnaMenü .Caption = ""&Bordro"" .Tag = ""MyTag"" .BeginGroup = False End With If AnaMenü Is Nothing Then Exit Sub '.. 'Alt Menü 1 Set AnaAltMenü = AnaMenü.Controls.Add(msoControlPopup, 1, , , True) With AnaAltMenü .Caption = ""Sabit Bilgi Tanımlamaları"" End With 'Kurum Bilgileri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Kurum Bilgileri"" .OnAction = ""kurbil"" .Style = msoButtonIconAndCaption .FaceId = 1976 .State = msoButtonUp End With 'Ekders Bilgileri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Ekders Bilgileri"" .OnAction = ""ekderbil"" .Style = msoButtonIconAndCaption .FaceId = 1979 .State = msoButtonUp End With 'Nakit Fişi Bilgileri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Nakit Fişi Bilgileri"" .OnAction = ""nakfisbil"" .Style = msoButtonIconAndCaption .FaceId = 44 .State = msoButtonUp End With 'Sendika Bilgileri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Sendika Bilgileri"" .OnAction = ""senbil"" .Style = msoButtonIconAndCaption .FaceId = 1980 .State = msoButtonUp End With 'Özel Gider İndirimi/İlaç Kesintisi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Özel Gider İndirimi/İlaç Kesintisi"" .OnAction = ""ozgidkes"" .Style = msoButtonIconAndCaption .FaceId = 1987 .State = msoButtonUp End With 'Tazminat İsimleri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Tazminat İsimleri"" .OnAction = ""tazis"" .Style = msoButtonIconAndCaption .FaceId = 1981 .State = msoButtonUp End With 'Maaş Katsayı Bilgileri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Maaş Katsayı Bilgileri"" .OnAction = ""maaskatbil"" .Style = msoButtonIconAndCaption .FaceId = 1982 .State = msoButtonUp End With 'Fark Katsayı Bilgileri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Fark Katsayı Bilgileri"" .OnAction = ""farkatbil"" .Style = msoButtonIconAndCaption .FaceId = 1983 .State = msoButtonUp End With 'Gösterge Katsayı Bilgileri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Gösterge Katsayı Bilgileri"" .OnAction = ""goskatbil"" .Style = msoButtonIconAndCaption .FaceId = 1984 .State = msoButtonUp End With 'Emekli Tazminat Oranları With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Emekli Tazminat Oranları"" .OnAction = ""emetazor"" .Style = msoButtonIconAndCaption .FaceId = 1985 .State = msoButtonUp End With 'Lojman Taminat Tutarları With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Lojman Taminat Tutarları"" .OnAction = ""lojtaztut"" .Style = msoButtonIconAndCaption .FaceId = 1016 .State = msoButtonUp End With 'Gelir Vergisi Dilimleri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Gelir Vergisi Dilimleri"" .OnAction = ""gelverdil"" .Style = msoButtonIconAndCaption .FaceId = 1977 .State = msoButtonUp End With 'Yabancı Dil Tazminatı With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Yabancı Dil Tazminatı"" .OnAction = ""yabdiltaz"" .Style = msoButtonIconAndCaption .FaceId = 1988 .State = msoButtonUp End With 'Sakatlık İndirimleri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Sakatlık İndirimleri"" .OnAction = ""sakind"" .Style = msoButtonIconAndCaption .FaceId = 1995 .State = msoButtonUp End With 'Tayın Bedelleri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Tayın Bedelleri"" .OnAction = ""taybed"" .Style = msoButtonIconAndCaption .FaceId = 1996 .State = msoButtonUp End With 'Ünvan/Taziminat Bilgileri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Ünvan/Taziminat Bilgileri"" .OnAction = ""untazbed"" .Style = msoButtonIconAndCaption .FaceId = 1997 .State = msoButtonUp End With 'Özel Kesinti İsimleri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Özel Kesinti İsimleri"" .OnAction = ""ozkesis"" .Style = msoButtonIconAndCaption .FaceId = 1992 .State = msoButtonUp End With 'Diğer Kesinti İsimleri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Diğer Kesinti İsimleri"" .OnAction = ""dikesis"" .Style = msoButtonIconAndCaption .FaceId = 1993 .State = msoButtonUp End With 'Anlaşmalı Eczaneler With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Anlaşmalı Eczaneler"" .OnAction = ""anecz"" .Style = msoButtonIconAndCaption .FaceId = 1994 .State = msoButtonUp End With '.. 'Alt Menü 2 Set AnaAltMenü = AnaMenü.Controls.Add(msoControlPopup, 1, , , True) With AnaAltMenü .Caption = ""Memur Bilgileri Girişi"" End With '.. 'Alt Menü 3 Set AnaAltMenü = AnaMenü.Controls.Add(msoControlPopup, 1, , , True) With AnaAltMenü .Caption = ""Hesaplama İşlemleri ve Sonuçları"" End With 'Normal Maaş Hesabı/Sonucu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Normal Maaş Hesabı/Sonucu"" .OnAction = ""nmaashes"" .Style = msoButtonIconAndCaption .FaceId = 30 .State = msoButtonUp End With 'Kıstel Maaş Hesabı/Sonucu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Kıstel Maaş Hesabı/Sonucu"" .OnAction = ""kmaashes"" .Style = msoButtonIconAndCaption .FaceId = 31 .State = msoButtonUp End With 'Fark Maaş Hesabı/Sonucu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Fark Maaş Hesabı/Sonucu"" .OnAction = ""fmaashes"" .Style = msoButtonIconAndCaption .FaceId = 1950 .State = msoButtonUp End With 'Terfi Farkı Hesabı/Sonucu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Terfi Farkı Hesabı/Sonucu"" .OnAction = ""terfarkhes"" .Style = msoButtonIconAndCaption .FaceId = 1953 .State = msoButtonUp End With 'Ekders Hesabı/Sonucu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Ekders Hesabı/Sonucu"" .OnAction = ""ekdershes"" .Style = msoButtonIconAndCaption .FaceId = 1952 .State = msoButtonUp End With 'Emekli Kesintileri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Emekli Kesintileri"" .OnAction = ""emekes"" .Style = msoButtonIconAndCaption .FaceId = 1951 .State = msoButtonUp End With 'Vergi Matrahları With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Vergi Matrahları"" .OnAction = ""vermat"" .Style = msoButtonIconAndCaption .FaceId = 32 .State = msoButtonUp End With 'Özel Gider İndirimleri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Özel Gider İndirimleri"" .OnAction = ""ozgidin"" .Style = msoButtonIconAndCaption .FaceId = 33 .State = msoButtonUp End With 'Yurtiçi Geçici Görev Yolluğu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Yurtiçi Geçici Görev Yolluğu"" .OnAction = ""yiçigecgoryol"" .Style = msoButtonIconAndCaption .FaceId = 34 .State = msoButtonUp End With 'Yurtiçi Sürekli Görev Yolluğu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Yurtiçi Sürekli Görev Yolluğu"" .OnAction = ""yiçisurgoryol"" .Style = msoButtonIconAndCaption .FaceId = 35 .State = msoButtonUp End With 'Diğer Masraflar Nakit Fişi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Diğer Masraflar Nakit Fişi"" .OnAction = ""dmasnakfis"" .Style = msoButtonIconAndCaption .FaceId = 36 .State = msoButtonUp End With 'Disketten Reçete Aktarımı With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Disketten Reçete Aktarımı"" .OnAction = ""disrecak"" .Style = msoButtonIconAndCaption .FaceId = 37 .State = msoButtonUp End With 'Eczane Reçeteleri İşleme With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Eczane Reçeteleri İşleme"" .OnAction = ""ecrecis"" .Style = msoButtonIconAndCaption .FaceId = 38 .State = msoButtonUp End With '.. 'Alt Menü 4 Set AnaAltMenü = AnaMenü.Controls.Add(msoControlPopup, 1, , , True) With AnaAltMenü .Caption = ""Genel Raporlar"" End With 'Seçimli Listeler With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Seçimli Listeler"" .OnAction = ""seclis"" .Style = msoButtonIconAndCaption .FaceId = 39 .State = msoButtonUp End With 'Çarşaf Bordro(Hakedişler) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Çarşaf Bordro(Hakedişler)"" .OnAction = ""cbhaked"" .Style = msoButtonIconAndCaption .FaceId = 40 .State = msoButtonUp End With 'Çarşaf Bordro(Kesintiler) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Çarşaf Bordro(Kesintiler)"" .OnAction = ""cbkes"" .Style = msoButtonIconAndCaption .FaceId = 41 .State = msoButtonUp End With 'Çarşaf Maaş+Kıstel(Hakedişler) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Çarşaf Maaş+Kıstel(Hakedişler)"" .OnAction = ""cmkhaked"" .Style = msoButtonIconAndCaption .FaceId = 42 .State = msoButtonUp End With 'Çarşaf Maaş+Kıstel(Kesintiler) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Çarşaf Maaş+Kıstel(Kesintiler)"" .OnAction = ""cmkkes"" .Style = msoButtonIconAndCaption .FaceId = 43 .State = msoButtonUp End With 'Kıstel(Hakedişler) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Kıstel(Hakedişler)"" .OnAction = ""khaked"" .Style = msoButtonIconAndCaption .FaceId = 44 .State = msoButtonUp End With 'Kıstel(Kesintiler) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Kıstel(Kesintiler)"" .OnAction = ""kkes"" .Style = msoButtonIconAndCaption .FaceId = 45 .State = msoButtonUp End With 'Maaş+Terfi Hakedişler With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Maaş+Terfi Hakedişler"" .OnAction = ""mthaked"" .Style = msoButtonIconAndCaption .FaceId = 46 .State = msoButtonUp End With 'Maaş+Terfi Kesintiler With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Maaş+Terfi Kesintiler"" .OnAction = ""mtkes"" .Style = msoButtonIconAndCaption .FaceId = 47 .State = msoButtonUp End With 'Terfi Hakedişler With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Terfi Hakedişler"" .OnAction = ""thaked"" .Style = msoButtonIconAndCaption .FaceId = 48 .State = msoButtonUp End With 'Terfi Kesintiler With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Terfi Kesintiler"" .OnAction = ""tkes"" .Style = msoButtonIconAndCaption .FaceId = 49 .State = msoButtonUp End With 'Fark Hakedişler With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Fark Hakedişler"" .OnAction = ""fhaked"" .Style = msoButtonIconAndCaption .FaceId = 50 .State = msoButtonUp End With 'Fark Kesintiler With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Fark Kesintiler"" .OnAction = ""fkes"" .Style = msoButtonIconAndCaption .FaceId = 51 .State = msoButtonUp End With 'Tek Sayfa Maaş Bordrosu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Tek Sayfa Maaş Bordrosu"" .OnAction = ""tsmbord"" .Style = msoButtonIconAndCaption .FaceId = 1839 .State = msoButtonUp End With 'Tek Sayfa Maaş+Kıstel Bordrosu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Tek Sayfa Maaş+Kıstel Bordrosu"" .OnAction = ""tsmkbord"" .Style = msoButtonIconAndCaption .FaceId = 53 .State = msoButtonUp End With 'Tek Sayfa Kıstel Bordrosu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Tek Sayfa Kıstel Bordrosu"" .OnAction = ""tskbord"" .Style = msoButtonIconAndCaption .FaceId = 54 .State = msoButtonUp End With 'Tek Sayfa Maaş+Terfi Bordrosu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Tek Sayfa Maaş+Terfi Bordrosu"" .OnAction = ""tsmtbord"" .Style = msoButtonIconAndCaption .FaceId = 55 .State = msoButtonUp End With 'Tek Sayfa Terfi Bordrosu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Tek Sayfa Terfi Bordrosu"" .OnAction = ""tstbord"" .Style = msoButtonIconAndCaption .FaceId = 56 .State = msoButtonUp End With '.. 'Alt Menü 5 Set AnaAltMenü = AnaMenü.Controls.Add(msoControlPopup, 1, , , True) With AnaAltMenü .Caption = ""Diğer Raporlar"" End With 'Genel Nakit Fişi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Genel Nakit Fişi"" .OnAction = ""gennakfis"" .Style = msoButtonIconAndCaption .FaceId = 57 .State = msoButtonUp End With 'Personel Bildirim With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Personel Bildirim"" .OnAction = ""perbild"" .Style = msoButtonIconAndCaption .FaceId = 58 .State = msoButtonUp End With 'Özel Gider İndirimi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Özel Gider İndirimi"" .OnAction = ""ozgidind"" .Style = msoButtonIconAndCaption .FaceId = 59 .State = msoButtonUp End With 'Rapor Kesinti Listesi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Rapor Kesinti Listesi"" .OnAction = ""rapkeslis"" .Style = msoButtonIconAndCaption .FaceId = 60 .State = msoButtonUp End With 'Memur Nakil Bildirimi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Memur Nakil Bildirimi"" .OnAction = ""mnakbil"" .Style = msoButtonIconAndCaption .FaceId = 61 .State = msoButtonUp End With 'Hasta Sevk Kağıdı With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Hasta Sevk Kağıdı"" .OnAction = ""hsevk"" .Style = msoButtonIconAndCaption .FaceId = 62 .State = msoButtonUp End With 'Maaş Defteri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Maaş Defteri"" .OnAction = ""mdeft"" .Style = msoButtonIconAndCaption .FaceId = 63 .State = msoButtonUp End With 'Yıllık Emeklilik Bordrosu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Yıllık Emeklilik Bordrosu"" .OnAction = ""yemekbord"" .Style = msoButtonIconAndCaption .FaceId = 64 .State = msoButtonUp End With 'Eczane Reçete Listesi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Eczane Reçete Listesi"" .OnAction = ""eczreçl"" .Style = msoButtonIconAndCaption .FaceId = 65 .State = msoButtonUp End With 'Maliye Disketi Oluşturma With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Maliye Disketi Oluşturma"" .OnAction = ""mdisko"" .Style = msoButtonIconAndCaption .FaceId = 66 .State = msoButtonUp End With 'Memur Maaş Bilgi Listesi(Form1) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Memur Maaş Bilgi Listesi(Form1)"" .OnAction = ""mmblform1"" .Style = msoButtonIconAndCaption .FaceId = 67 .State = msoButtonUp End With 'Memur Maaş Bilgi Listesi(Form2) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Memur Maaş Bilgi Listesi(Form2)"" .OnAction = ""mmblform2"" .Style = msoButtonIconAndCaption .FaceId = 68 .State = msoButtonUp End With 'Memur Maaş Bilgi Listesi(Form3) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Memur Maaş Bilgi Listesi(Form3)"" .OnAction = ""mmblform3"" .Style = msoButtonIconAndCaption .FaceId = 69 .State = msoButtonUp End With 'Kademe Terfisi Gelenler Listesi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Kademe Terfisi Gelenler Listesi"" .OnAction = ""kadtergel"" .Style = msoButtonIconAndCaption .FaceId = 106 .State = msoButtonUp End With '2003 ve Öncesi Nakit Fişi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""2003 ve Öncesi Nakit Fişi"" .OnAction = ""2003öncnf"" .Style = msoButtonIconAndCaption .FaceId = 107 .State = msoButtonUp End With 'Çok Amaçlı Raporlama With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Çok Amaçlı Raporlama"" .OnAction = ""carap"" .Style = msoButtonIconAndCaption .FaceId = 108 .State = msoButtonUp End With '.. 'Alt Menü 6 Set AnaAltMenü = AnaMenü.Controls.Add(msoControlPopup, 1, , , True) With AnaAltMenü .Caption = ""SSK Raporları"" End With 'SSK İşe İlk Giriş Bildirgesi(Normal) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""SSK İşe İlk Giriş Bildirgesi(Normal)"" .OnAction = ""iseilkgirn"" .Style = msoButtonIconAndCaption .FaceId = 109 .State = msoButtonUp End With 'SSK İşe İlk Giriş Bildirgesi(Emekli) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""SSK İşe İlk Giriş Bildirgesi(Emekli)"" .OnAction = ""iseilkgire"" .Style = msoButtonIconAndCaption .FaceId = 110 .State = msoButtonUp End With 'SSK Aylık Bildirge(Normal) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""SSK Aylık Bildirge(Normal)"" .OnAction = ""aybiln"" .Style = msoButtonIconAndCaption .FaceId = 111 .State = msoButtonUp End With 'SSK Aylık Bildirge(Emekli) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""SSK Aylık Bildirge(Emekli)"" .OnAction = ""aybile"" .Style = msoButtonIconAndCaption .FaceId = 112 .State = msoButtonUp End With 'SSK 4 Aylık Bordro With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""SSK 4 Aylık Bordro"" .OnAction = ""4aybord"" .Style = msoButtonIconAndCaption .FaceId = 113 .State = msoButtonUp End With '.. 'Alt Menü 7 Set AnaAltMenü = AnaMenü.Controls.Add(msoControlPopup, 1, , , True) With AnaAltMenü .Caption = ""Özel Servis İşlemleri"" End With 'Memur Kayıt İptali With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Memur Kayıt İptali"" .OnAction = ""memkayip"" .Style = msoButtonIconAndCaption .FaceId = 201 .State = msoButtonUp End With 'Memur Sıra No Düzenleme With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Memur Sıra No Düzenleme"" .OnAction = ""memsnduz"" .Style = msoButtonIconAndCaption .FaceId = 202 .State = msoButtonUp End With 'Maaş Hesapları İptal Etme With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Maaş Hesapları İptal Etme"" .OnAction = ""mhesip"" .Style = msoButtonIconAndCaption .FaceId = 203 .State = msoButtonUp End With 'Ay Kapama Açma With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Ay Kapama Açma"" .OnAction = ""aykapac"" .Style = msoButtonIconAndCaption .FaceId = 204 .State = msoButtonUp End With 'Yeni Aya Aktarma İşlemleri With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Yeni Aya Aktarma İşlemleri"" .OnAction = ""yaaktris"" .Style = msoButtonIconAndCaption .FaceId = 205 .State = msoButtonUp End With 'Yıl Sonu İşlemi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Yıl Sonu İşlemi"" .OnAction = ""yılsonis"" .Style = msoButtonIconAndCaption .FaceId = 206 .State = msoButtonUp End With 'Öğr.Dev-Dev.Ekders Aktar With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Öğr.Dev-Dev.Ekders Aktar"" .OnAction = ""ögrdevekakt"" .Style = msoButtonIconAndCaption .FaceId = 207 .State = msoButtonUp End With 'El İle Emekli Kesintisi İşlemi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""El İle Emekli Kesintisi İşlemi"" .OnAction = ""eemkkesis"" .Style = msoButtonIconAndCaption .FaceId = 208 .State = msoButtonUp End With 'Tasarruf Teşvik Nema Ödeme With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Tasarruf Teşvik Nema Ödeme"" .OnAction = ""ttnemaod"" .Style = msoButtonIconAndCaption .FaceId = 209 .State = msoButtonUp End With 'Fiili/İtibari Hizmet Zammı With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Fiili/İtibari Hizmet Zammı"" .OnAction = ""fiithizzam"" .Style = msoButtonIconAndCaption .FaceId = 210 .State = msoButtonUp End With 'Toplu Diğer Kesinti İşleme With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Toplu Diğer Kesinti İşleme"" .OnAction = ""tdkesis"" .Style = msoButtonIconAndCaption .FaceId = 211 .State = msoButtonUp End With 'Toplu Özel Kesinti İşleme With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Toplu Özel Kesinti İşleme"" .OnAction = ""tökesis"" .Style = msoButtonIconAndCaption .FaceId = 212 .State = msoButtonUp End With 'Maaş Kontrol(Önceki Ayla) With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Maaş Kontrol(Önceki Ayla)"" .OnAction = ""makont"" .Style = msoButtonIconAndCaption .FaceId = 213 .State = msoButtonUp End With 'Toplu Bilgi İşleme With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Toplu Bilgi İşleme"" .OnAction = ""tbilis"" .Style = msoButtonIconAndCaption .FaceId = 214 .State = msoButtonUp End With 'Eğitime Hazırlık Bordrosu With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Eğitime Hazırlık Bordrosu"" .OnAction = ""ehazbord"" .Style = msoButtonIconAndCaption .FaceId = 215 .State = msoButtonUp End With 'Memur Hizmet Belgesi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Memur Hizmet Belgesi"" .OnAction = ""memhizbel"" .Style = msoButtonIconAndCaption .FaceId = 216 .State = msoButtonUp End With 'Yazı Yazma With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Yazı Yazma"" .OnAction = ""yyazma"" .Style = msoButtonIconAndCaption .FaceId = 217 .State = msoButtonUp End With '.. 'Alt Menü 8 Set AnaAltMenü = AnaMenü.Controls.Add(msoControlPopup, 1, , , True) With AnaAltMenü .Caption = ""Teknik Servis İşlemleri"" End With 'Rapor Dizaynı Oluşturma With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Rapor Dizaynı Oluşturma"" .OnAction = ""rapdiz"" .Style = msoButtonIconAndCaption .FaceId = 114 .State = msoButtonUp End With 'Memur Sıra No Taraması With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Memur Sıra No Taraması"" .OnAction = ""msntar"" .Style = msoButtonIconAndCaption .FaceId = 115 .State = msoButtonUp End With 'Dosyaların Teknik Bakımı With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Dosyaların Teknik Bakımı"" .OnAction = ""tekbak"" .Style = msoButtonIconAndCaption .FaceId = 116 .State = msoButtonUp End With '.. 'Alt Menü 9 Set AnaAltMenü = AnaMenü.Controls.Add(msoControlPopup, 1, , , True) With AnaAltMenü .Caption = ""Yedekleme İşlemleri"" End With 'Yedek Alma İşlemi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Yedek Alma İşlemi"" .OnAction = ""yedal"" .Style = msoButtonIconAndCaption .FaceId = 117 .State = msoButtonUp End With 'Yedek Geri Dönme İşlemi With AnaAltMenü.Controls.Add(msoControlButton, 1, , , True) .Caption = ""Yedek Geri Dönme İşlemi"" .OnAction = ""yedgerd"" .Style = msoButtonIconAndCaption .FaceId = 118 .State = msoButtonUp End With On Error Resume Next End Sub Sub auto_close() MenuBars(xlWorksheet).Reset End Sub " Menü ekleme "Sub AjouteMenus() MenuBars(xlWorksheet).Menus.Add Caption:=""&MonMenu"", before:=9 '(before:=9)modifié cette valeur pour placer le menu où vous voulez MenuBars(xlWorksheet).Menus(""&MonMenu"").MenuItems.Add _ Caption:=""&SousMenu1"", before:=1, OnAction:=""Nom de la macro 1"" 'Exécute la macro 1 MenuBars(xlWorksheet).Menus(""&MonMenu"").MenuItems.Add _ Caption:=""&SousMenu2"", before:=1, OnAction:=""Nom de la macro 2"" 'Exécute la macro 2 End Sub Sub SupprimeMenus() For Each MenuName In MenuBars(xlWorksheet).Menus If MenuName.Caption = ""&MonMenu"" Then MenuName.Delete End If Next End Sub" Menü ekleme "Thisworkbooka Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error Resume Next Application.CommandBars(""Symbolleiste_Klaus"").Delete End Sub Private Sub Workbook_Open() On Error Resume Next Application.CommandBars.Add(Name:=""Symbolleiste_Klaus"").Visible = True Set myControl1 = Application.CommandBars(""Symbolleiste_Klaus"").Controls.Add(msoControlButton) With myControl1 .FaceId = 71 'HIER FACE-ID ANPASSEN .OnAction = ""Klaus1"" 'HIER DEINEN MAKRONAMEN ANPASSEN .Caption = ""Klaus´ Makro 1"" 'HIER DEINEN INFOTEXT ANPASSEN End With Set myControl2 = Application.CommandBars(""Symbolleiste_Klaus"").Controls.Add(msoControlButton) With myControl2 .FaceId = 72 'HIER FACE-ID ANPASSEN .OnAction = ""Klaus2"" 'HIER DEINEN MAKRONAMEN ANPASSEN .Caption = ""Klaus´ Makro 2"" 'HIER DEINEN INFOTEXT ANPASSEN End With End Sub 'Modüle Sub Klaus1() MsgBox ""http://www.excel-lex.de.vu"" End Sub Sub Klaus2() MsgBox ""http://www.kmbuss.de"" End Sub" Menü ekleme ve silme "Sub Menue_ein() Set ML = Application.CommandBars(""Worksheet Menu Bar"") ' Name für neues Menü anlegen Set U1 = ML.Controls.Add(Type:=msoControlPopup, Before:=10) U1.Caption = ""&EXCEL-LEX"" U1.Tag = ""MeinMenü"" ' dient zur eindeutigen Identifizierung des Menüs ' 1. Menüpunkt anlegen Set Punkt = U1.Controls.Add(Type:=msoControlButton) With Punkt .Caption = ""&1. Menüpunkt"" .OnAction = ""MsgBox1"" .Style = msoButtonIconAndCaption .FaceId = 3278 End With ' neues Untermenü wird hinzugefügt Set Punkt = U1.Controls.Add(Type:=msoControlPopup) With Punkt .Caption = ""1.Untermenü"" End With Set U2 = Punkt ' Variable für das 2. Untermenü wird gesetzt ' Neuer Menüeintrag im 2.Untermenü Set Punkt = U2.Controls.Add(Type:=msoControlButton) With Punkt .Caption = ""&2.Menüpunkt"" .OnAction = ""MsgBox2"" .Style = msoButtonIconAndCaption .FaceId = 488 End With Set Punkt = U2.Controls.Add(Type:=msoControlButton) With Punkt .Caption = ""&3.Menüpunkt"" .OnAction = ""MsgBox3"" .Style = msoButtonIconAndCaption .FaceId = 1715 End With ' Weiterer Eintrag im 1.Untermenü Set Punkt = U1.Controls.Add(Type:=msoControlButton) With Punkt .Caption = ""&4.Menüpunkt"" .OnAction = ""MsgBox4"" .Style = msoButtonIconAndCaption .FaceId = 3200 End With End Sub Sub Menue_aus() Set ML = Application.CommandBars(""Worksheet Menu Bar"") On Error Resume Next ' Fehlerbehandlung ML.FindControl(Tag:=""MeinMenü"").Delete End Sub" Menü ekleme ve silme "Private Sub Workbook_Open() Dim cbMenu As CommandBar Dim cbSpecialMenu As CommandBarPopup Dim cbCommand As CommandBarControl Set cbMenu = Application.CommandBars(""Worksheet Menu Bar"") Set cbSpecialMenu = cbMenu.Controls.Add(Type:=msoControlPopup) cbSpecialMenu.Caption = ""Mein Spezialmenu"" Set cbCommand = cbSpecialMenu.Controls.Add(Type:=msoControlButton) cbCommand.Caption = ""Mein Befehl"" cbCommand.OnAction = ""sil"" End Sub Sub sil() Dim cbSpecialMenu As CommandBarControl On Error Resume Next Set cbSpecialMenu = Application.CommandBars(""Worksheet Menu Bar"").Controls(""Mein Spezialmenu"") cbSpecialMenu.Delete End Sub" Menü index numaraları "Sub ID_anzeigen() Dim intZ%, objY As CommandBar, objX As CommandBarControl [a1] = ""ID"": [b1] = ""Name"": [c1] = ""Index"": [d1] = ""Symbolleiste"" intZ = 2 For Each objY In CommandBars For Each objX In CommandBars(objY.Name).Controls Cells(intZ, 1) = objX.ID Cells(intZ, 2) = objX.Caption Cells(intZ, 3) = objX.Index Cells(intZ, 4) = objY.Name intZ = intZ + 1 Next Next End Sub" Menü olarak saat ekleme (en güvenilir) "Sayfaların kod bölümüne ve Thisworkbooka Option Explicit 'Modüle1 e Option Explicit Sub StartClock() StartClockinMenu End Sub Sub StopClock() StopClockinMenu End Sub 'Modüle2 ye Option Explicit Private Declare Function FindWindow _ Lib ""user32"" _ Alias ""FindWindowA"" _ ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String _ ) _ As Long Private Declare Function SetTimer _ Lib ""user32"" _ ( _ ByVal hWnd As Long, _ ByVal nIDEvent As Long, _ ByVal uElapse As Long, _ ByVal lpTimerFunc As Long _ ) _ As Long Private Declare Function KillTimer _ Lib ""user32"" _ ( _ ByVal hWnd As Long, _ ByVal nIDEvent As Long _ ) _ As Long Private Declare Function GetCurrentVbaProject _ Lib ""vba332.dll"" _ Alias ""EbGetExecutingProj"" _ ( _ hProject As Long _ ) _ As Long Private Declare Function GetFuncID _ Lib ""vba332.dll"" _ Alias ""TipGetFunctionId"" _ ( _ ByVal hProject As Long, _ ByVal strFunctionName As String, _ ByRef strFunctionID As String _ ) _ As Long Private Declare Function GetAddr _ Lib ""vba332.dll"" _ Alias ""TipGetLpfnOfFunctionId"" _ ( _ ByVal hProject As Long, _ ByVal strFunctionID As String, _ ByRef lpfnAddressOf As Long _ ) _ As Long Private WindowsTimer As Long Private ClockCBControl As CommandBarButton Sub StartClockinMenu() Set ClockCBControl = _ Application.CommandBars(1).Controls.Add( _ Type:=msoControlButton, Temporary:=True) ClockCBControl.Style = msoButtonCaption ClockCBControl.Caption = Format(Now, ""Long Time"") fncWindowsTimer 1000 End Sub Sub StopClockinMenu() fncStopWindowsTimer ClockCBControl.Delete End Sub Private Function fncWindowsTimer( _ TimeInterval As Long _ ) As Boolean Dim WindowsTimer As Long WindowsTimer = 0 If Val(Application.Version) > 8 Then WindowsTimer = SetTimer _ ( _ hWnd:=FindWindow(""XLMAIN"", Application.Caption), _ nIDEvent:=0, _ uElapse:=TimeInterval, _ lpTimerFunc:=AddrOf_cbkCustomTimer _ ) Else WindowsTimer = SetTimer _ ( _ hWnd:=FindWindow(""XLMAIN"", Application.Caption), _ nIDEvent:=0, _ uElapse:=TimeInterval, _ lpTimerFunc:=AddrOf(""cbkCustomTimer"") _ ) End If fncWindowsTimer = CBool(WindowsTimer) End Function Private Function fncStopWindowsTimer() KillTimer _ hWnd:=FindWindow(""XLMAIN"", Application.Caption), _ nIDEvent:=WindowsTimer End Function Private Function cbkCustomTimer _ ( _ ByVal Window_hWnd As Long, _ ByVal WindowsMessage As Long, _ ByVal EventID As Long, _ ByVal SystemTime As Long _ ) _ As Long Dim CurrentTime As String On Error Resume Next ClockCBControl.Caption = Format(Now, ""Long Time"") End Function Private Function AddrOf _ ( _ CallbackFunctionName As String _ ) _ As Long Dim aResult As Long Dim CurrentVBProject As Long Dim strFunctionID As String Dim AddressOfFunction As Long Dim UnicodeFunctionName As String UnicodeFunctionName = StrConv(CallbackFunctionName, vbUnicode) If Not GetCurrentVbaProject(CurrentVBProject) = 0 Then aResult = GetFuncID _ ( _ hProject:=CurrentVBProject, _ strFunctionName:=UnicodeFunctionName, _ strFunctionID:=strFunctionID _ ) If aResult = 0 Then aResult = GetAddr _ ( _ hProject:=CurrentVBProject, _ strFunctionID:=strFunctionID, _ lpfnAddressOf:=AddressOfFunction _ ) If aResult = 0 Then AddrOf = AddressOfFunction End If End If End If End Function Private Function AddrOf_cbkCustomTimer() As Long AddrOf_cbkCustomTimer = vbaPass(AddressOf cbkCustomTimer) End Function Private Function vbaPass(AddressOfFunction As Long) As Long vbaPass = AddressOfFunction End Function" Menülerin İngilizce ve türkçeleri "Public Sub Me_006() Dim CmdB As CommandBar Dim i As Integer 'Dim i% i = 1 With ActiveSheet .[A:B].ClearContents .[A1].Value = ""Name"" .[B1].Value = ""Lokaler Name"" End With For Each CmdB In Application.CommandBars If CmdB.Type = msoBarTypeNormal Then i = i + 1 With ActiveSheet .Cells(i, 1).Value = CmdB.Name .Cells(i, 2).Value = CmdB.NameLocal End With End If Next CmdB ActiveSheet.Columns(""A:B"").AutoFit End Sub" Mesaj alt alta birleştirme "Sub TwoLines() MsgBox ""Line 1"" & vbCrLf & ""Line 2"" End Sub" Mesaj ile saati öğrenme "Sub Heure() Dim i As Byte For i = 0 To 23 Application.OnTime TimeValue(i & "":00:00""), ""Affiche_Heure"" Next i End Sub Sub Affiche_Heure() MsgBox ""Il est "" & Time End Sub" Mesaj kutusu caption "Sub mesaj() MsgBox ""İyisinizdir İnşaallah"", , ""nasılsınız"" End Sub " Mesaj kutusu çift satırlı 1 MsgBox "Mesaj boxlarda satır başı yapamıyorum." & vbCrlf & "Bunun bir yolu olmalı !" & vbCrlf & "Acaba vbCrlf kullanırsam ne olur?", vbinformation Mesaj kutusu çift satırlı 2 "Yada Alt+Enter'in Ascii kodu olan chr(10) kullanılabilir. Sub A() MsgBox ""A"" & Chr(10) & ""B"" & Chr(10) & ""C"" & Chr(10) & ""D"" & Chr(10) End Sub" Mesaj kutusu çift satırlı 3 "Sub MsgAscii() Dim sayi1 As Integer For sayi1 = 1 To 255 msg = msg & (sayi1) & Chr(58) & Chr(sayi1) & Space(1) Next sayi1 MsgBox msg, 64, Chr(83) & Chr(252) & Chr(108) & Chr(101) _ & Chr(121) & Chr(109) & Chr(97) & Chr(110) & Chr(32) & Chr(85) _ & Chr(90) & Chr(85) & Chr(78) & Chr(75) & Chr(214) & Chr(80) & _ Chr(82) & Chr(220) End Sub" Mesaj kutusu ile sayfa yazdırma adedi gir (sayfa boş bile olsa yazdırır) "Sub Changing_Section_Headers() Dim c As Range, rngSection As Range Dim cFirst As Range, cLast As Range Dim rowLast As Long, colLast As Integer Dim r As Long, iSection As Integer Dim iCopies As Variant Dim strCH As String Set c = Range(""A1"").SpecialCells(xlCellTypeLastCell) rowLast = c.Row colLast = c.Column iCopies = InputBox( _ ""Number of Copies"", ""Changing Section Headers"", 1) If iCopies = """" Then Exit Sub Set cFirst = Range(""A1"") ' initialization start cell For r = 2 To rowLast ' from first row to last row If ActiveSheet.Rows(r).PageBreak = xlPageBreakManual Then Set cLast = Cells(r - 1, colLast) Set rngSection = Range(cFirst, cLast) iSection = iSection + 1 Select Case iSection ' substitute your CenterSection Header data Case 1: strCH = ""Section 1"" Case 2: strCH = ""Section 2"" ' etc ' Case n: strCH = ""Section n"" End Select ActiveSheet.PageSetup.CenterHeader = strCH rngSection.PrintOut _ Copies:=iCopies, Collate:=True Set cFirst = Cells(r, 1) End If Next r ' Last Section ++++++++++++++++++++++++++++ Set rngSection = Range(cFirst, c) iSection = iSection + 1 ' substitute your Center Header data strCH = ""Last Section "" ' or strCH = ""Section "" & iSection ActiveSheet.PageSetup.CenterHeader = strCH rngSection.PrintOut _ Copies:=iCopies, Collate:=True End Sub" Mesaj kutusu örnekleri "Sub MyMessage() MsgBox ""Merhaba 1"" MsgBox ""Merhaba 2"", vbInformation MsgBox ""Merhaba 3"", vbExclamation, ""Burası Başlık Kısmı"" MsgBox ""Merhaba 4"", vbCritical, ""Burası Başlık Kısmı"" MsgBox ""Merhaba 5"", vbDefaultButton1 MsgBox ""Merhaba 6"", vbDefaultButton2 MsgBox ""Merhaba 7"", vbDefaultButton3 MsgBox ""Merhaba 8"", vbDefaultButton4 MsgBox ""Merhaba 9"", vbMsgBoxHelpButton MsgBox ""Merhaba 10"", vbApplicationModal MsgBox ""Merhaba 11"", vbMsgBoxRight MsgBox ""Merhaba 12"", vbMsgBoxRtlReading MsgBox ""Merhaba 13"", vbMsgBoxSetForeground MsgBox ""Merhaba 14"", vbOKCancel MsgBox ""Merhaba 15"", vbOKOnly MsgBox ""Merhaba 16"", vbQuestion MsgBox ""Merhaba 17"", vbRetryCancel MsgBox ""Merhaba 18"", vbSystemModal MsgBox ""Merhaba 19"", vbYesNo MsgBox ""Merhaba 20"", vbYesNoCancel End Sub" Mesaj kutusunda evet hayır a makro atama "Sub msg_yes_no() iResult = MsgBox(""Evet mi, Hayır mı?"", vbYesNo) If iResult = vbYes Then 'Evet için buraya kod yazabilirsiniz MsgBox ""Evet i seçtin"" Else 'Hayır için buraya kod yazabilirsiniz MsgBox ""Hayır ı seçtin"" End If End Sub" Mesaj kutusunda gün, tarih, saat "Sub MsgBox() Dim WshShell Dim intAntwort As Integer Set WshShell = CreateObject(""WScript.Shell"") intAntwort = WshShell.Popup(WeekdayName(Weekday(Date, vbMonday)) _ & Chr(13) & _ Day(Date) & "". "" & _ MonthName(Month(Date)) & "" "" & _ Year(Date) & Chr(13) & _ Time, 3, ""pir"") End Sub " Mesaj kutusuyla formül girme "Sub Adjust() Dim Target As Range Dim J As Integer Dim sForm As String Dim sMod As String Set Target = ActiveSheet.Range(ActiveWindow.Selection.Address) sMod = InputBox(""Formula to add?"") If sMod > """" Then For J = 1 To Target.Cells.Count If Target.Cells(J).HasFormula Then sForm = Target.Cells(J).Formula sForm = ""=("" & Mid(sForm, 2, 500) & "")"" sForm = sForm & sMod Target.Cells(J).Formula = sForm Else sForm = ""="" & Target.Cells(J).Value & sMod Target.Cells(J).Formula = sForm End If Next J End If End Sub" Mesaj örnekleri "Sub msg1() MsgBox ""Test MSG1"", vbInformation, ""Information fichier"" End Sub Sub msg11() MsgBox ""Test MSG11"", 64, ""Information fichier"" End Sub 'Indique un message d'exclamation Sub msg2() MsgBox ""Test MSG2"", vbExclamation, ""Information fichier"" End Sub 'Idem avec la valeur 48 Sub msg22() MsgBox ""Test MSG22"", 48, ""Information fichier"" End Sub 'En plus clair Sub msg3() MsgBox prompt:=""Il est l'heure de votre RDV"", _ Buttons:=vbExclamation, Title:=""ATTENTION"" End Sub" Mesaj verdirip kapatma "Sub Send_Excel_Message() Dim MyMessage As Object, MyOutApp As Object 'InitializeOutlook = True Set MyOutApp = CreateObject(""Outlook.Application"") Set MyMessage = MyOutApp.CreateItem(0) With MyMessage .To = ""mahmut_bayram@mynet.com"" .Subject = ""Testmeldung von Excel2000 "" & Date & Time '.body = ""Selamun Aleyküm"" & vbCrLf & ""Nasılsınız Mahmut Bey"" .HTMLBody = ""Afiyettesinizdir"" & vbCrLf & ""İnşaallah."" .Display .Save SendKeys ""%S"" End With 'MyOutApp.Quit ‘ baştaki işaretş kaldırırsanız mesaj gönderen uygulamayı kapatır. Set MyOutApp = Nothing Set MyMessage = Nothing End Sub" Mesajdan sonra makro "Sub Macro1() MsgBox (""This is Macro1"") Call Macro2 End Sub" Mesajla boş olup olmadığını kontrol etme "Sub TestValeurVide() Dim MaValeur, MonTest MaValeur = Empty 'il y a une valeur MonTest = IsEmpty(MaValeur) ' Test si ma valeur est vide MsgBox MonTest 'Retourne Vrai MaValeur = Null 'il n'y a pas de valeur MonTest = IsEmpty(MaValeur)' Test si ma valeur est vide (EstVide) MsgBox MonTest 'Retourne Faux MaValeur = Null 'il n'y a pas de valeur MonTest = Not IsEmpty(MaValeur) ' Test si ma valeur n'est pas vide (Non EstVide) MsgBox MonTest 'Retourne Vrai End Sub" Mesajla numerik veya numerik olmadığını kontrol etme "Sub Valeurnum() Dim MaValeur, MaValeur2, MonTest, MonTest2 MaValeur = ""4578"" MonTest = IsNumeric(MaValeur) 'Retourne Vrai MsgBox MonTest MaValeur = ""4578,456"" MonTest = IsNumeric(MaValeur) 'Retourne Vrai MsgBox MonTest MaValeur2 = ""daniel"" MonTest2 = IsNumeric(MaValeur2) 'Retourne Faux MsgBox MonTest2 End Sub" Mesajla tarih formatı olup olmadığını kontrol etme "Sub ValeurDate() Dim MaDate, NonDate, TestDate, TestDate2 MaDate = ""02 Mai 2002"": NonDate = ""Daniel"" TestDate = IsDate(MaDate) 'Retourne Vrai MsgBox TestDate TestDate2 = IsDate(NonDate) 'Retourne Faux MsgBox TestDate2 End Sub" Metİn kutusuna gİrlİlen yazinin para bİrİmİ Şeklİnde olmasi "TextBox nesnesine girildiğinde bu işin yapılması için biraz daha uzun kod yazmak lazım. Onun yerine, TextBox nesnesinden ""cursor - imleç"" çıktığında bu işin yapılmasını istersen; Kod: Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""#,### TL"") End Sub Ve, eğer az önce rastladığım senin diğer bir mesajında bu işin yapılmasını istersen; Kod: Private Sub TextBox1_Change() RefreshTxtBx End Sub Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""#,### TL"") End Sub ' Private Sub TextBox2_Change() RefreshTxtBx End Sub ' Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox2 = Format(TextBox2, ""#,### TL"") End Sub ' Private Sub RefreshTxtBx() Dim Val1 As Double, Val2 As Double On Error Resume Next Val1 = TextBox1 Val2 = TextBox2 On Error GoTo 0 TextBox3 = Format(Val1 + Val2, ""#,### TL"") End Sub " Metİn kutusunun formatini ayarlamak "Sadece sayı yazmak içinde aşağıdaki linki inceleyiniz. visual basic kodu: Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""###-### ## ##"") End Sub tutarda sadece sayısal değer (sayının 1.234,56 şeklinde) yazılması için visual basic kodu: Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If IsNumeric(TextBox1) = True Then TextBox1 = Format(TextBox1, ""###,###.##"") Exit Sub End If TextBox1 = ""GİRİLEN DEÃ�ER HATALIDIR"" End Sub " Metinleri büyük & küçük harfe çevirir "Metni büyük harfli yapmak için şu makroyu kullanın: Sub BuyukHarf() For Each c In Selection.Cells c.Value=Ucase$(c.Value) Next c End Sub Metni küçük harf yapmak içinse şu makroyu kullanın: Sub KucukHarf() For Each c In Selection.Cells c.Value=Lcase$(c.Value) Next c End Sub 'VERİLEN HÜCRE ÖLÇÜTÜNE GÖRE SAYFAYA YAZILANLARI BÜYÜK HARFE ÇEVİRİR. Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim RaBereich As Range, RaZelle As Range Application.EnableEvents = False Set RaBereich = Range(""a1:ı1000"") Application.EnableEvents = False For Each RaZelle In Range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then RaZelle.Value = UCase(RaZelle.Value) End If Next RaZelle Application.EnableEvents = True Set RaBereich = Nothing End Sub 'VERİLEN HÜCRE ÖLÇÜTÜNE GÖRE SAYFAYA YAZILANLARIN BAŞ HARFİNİ BÜYÜK HARFE ÇEVİRİR. Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim RaBereich As Range, RaZelle As Range Application.EnableEvents = False Set RaBereich = Range(""a1:ı1000"") Application.EnableEvents = False For Each RaZelle In Range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then If RaZelle <> """" Then RaZelle.Value = UCase(Mid(RaZelle.Value, 1, 1)) _ & LCase(Mid(RaZelle.Value, 2, Len(RaZelle.Value) - 1)) End If End If Next RaZelle Application.EnableEvents = True Set RaBereich = Nothing End Sub " Metİnlerİ bÜyÜk&kÜÇÜk harfe Çevİrİr "Metni büyük harfli yapmak için şu makroyu kullanın: Sub BuyukHarf() For Each c In Selection.Cells c.Value=Ucase$(c.Value) Next c End Sub Metni küçük harf yapmak içinse şu makroyu kullanın: Sub KucukHarf() For Each c In Selection.Cells c.Value=Lcase$(c.Value) Next c End Sub 'VERİLEN HÜCRE ÖLÇÜTÜNE GÖRE SAYFAYA YAZILANLARI BÜYÜK HARFE ÇEVİRİR. Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim RaBereich As Range, RaZelle As Range Application.EnableEvents = False Set RaBereich = Range(""a1:ı1000"") Application.EnableEvents = False For Each RaZelle In Range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then RaZelle.Value = UCase(RaZelle.Value) End If Next RaZelle Application.EnableEvents = True Set RaBereich = Nothing End Sub 'VERİLEN HÜCRE ÖLÇÜTÜNE GÖRE SAYFAYA YAZILANLARIN BAŞ HARFİNİ BÜYÜK HARFE ÇEVİRİR. Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim RaBereich As Range, RaZelle As Range Application.EnableEvents = False Set RaBereich = Range(""a1:ı1000"") Application.EnableEvents = False For Each RaZelle In Range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then If RaZelle <> """" Then RaZelle.Value = UCase(Mid(RaZelle.Value, 1, 1)) _ & LCase(Mid(RaZelle.Value, 2, Len(RaZelle.Value) - 1)) End If End If Next RaZelle Application.EnableEvents = True Set RaBereich = Nothing End Sub " Mİcrosoft outlookdan uyari e-maİlİ gÖndersİn "Biliyorsunuzdur mutlaka John Walkenbachın bir api si var.Aşağıdaki gibi. Kod: 'Windows API function declaration Private Declare Function PlaySound Lib ""winmm.dll"" _ Alias ""PlaySoundA"" (ByVal lpszName As String, _ ByVal hModule As Long, ByVal dwFlags As Long) As Long Function Alarm(Cell, Condition) Dim WAVFile As String Const SND_ASYNC = &H1 Const SND_FILENAME = &H20000 On Error GoTo ErrHandler If Evaluate(Cell.Value & Condition) Then WAVFile = ThisWorkbook.Path & ""\sound.wav"" 'Edit this statement Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME) Alarm = True Exit Function End If ErrHandler: Alarm = False End Function Kod: =Alarm(A1;"">=1000"") Ã�imdi benim sorunum şöyle , E sütununda tarihler var.Bu tarihlerden 10 gün önce alarm versin ve F sütunundaki kişilere Microsoft Outlookdan uyarı e-maili göndersin. Bu mümkün mü acaba? __ Haluk Moderatör Excel ile e-mail gönderilecekse e-mail client olarak MS Outlook'un kullanılması her zaman daha iyidir. Çünkü MS Outlook da bir Office programı olduğu için, Excel VBA'de MS Outlook'a referans vererek bazı işler daha kolay yapılabilir. Aşağıdaki kodu çalıştırmadan önce Excel VBE'de Tools | References kısmından MS Outlook 9.0 Object Libray referansının eklenmesi gerekir. (MS Outlook versiyonuna göre 10 veya 11 de olabilir.) PC'nin tarihi ile E sütunundaki tarihleri kontrol edip, 10 günlük farkı gördüğü yerde F sütunundaki geçerli e-mail adresine bir e-mail, MS Outlook ile aşağıdaki gibi bir kodla gönderilebilir. Kod: Sub MultiEmail() Dim OutApp As Outlook.Application Dim NewMail As Outlook.MailItem Dim noE As Integer, i As Integer noE = Cells(65536, 5).End(xlUp).Row For i = 1 To noE If Cells(i, 5) = Date - 10 Then Set OutApp = New Outlook.Application Set NewMail = CreateItem(olMailItem) With NewMail .To = Cells(i, 6).Text .Subject = ""Deneme"" .Body = ""Bu e-mail deneme amacıyla gönderilmiştir."" .Save .Send End With Set NewMail = Nothing Set OutApp = Nothing End If Next End Sub Eğer bu kodun çalıştırıldığı PC'de ilgili güvenlik yaması kurulmuş ise Windows kullanıcıyı ikaz eder ve başka bir programın e-mail göndermeye çalıştığına dair kullanıcıyı uyarır. Bu yama kurulu değilse, böyle bir problem olmaz " Midi çalma "Sub PlayMIDI() Dim Player Player = Shell(""C:\Program Files\Windows Media Player\wmplayer.exe"") C:\Songs\regypti.mid"", 6) AppActivate Player End Sub" Midi çalma "Sub Play_Sound() Dim Player Player = Shell(""C:\Program Files\Windows Media Player\wmplayer.exe,C:\canyon.mid"", 6) AppActivate Player End Sub" Midi dosyası çalma "Sub PlayMIDI() Dim Player Player = Shell(""C:\Progra~1\Window~1\mplayer2.exe C:\Songs\regypti.mid"", 6) AppActivate Player End Sub" Mini email "Sub Mini_Mail() Shell ""C:\Program Files\Microsoft Office\Office10\OUTLOOK.exe"" ActiveWorkbook.SendMail Recipients:=""mahmut_bayram@mynet.com"", Subject:=""Test"" End Sub" Modül gizleme "Sub ModulGizle() Module(1).Visible = xlVeryHidden End Sub Sub ModulGoster() Module(1).Visible = True End Sub" Modül silme "Sub Loeschen() With Workbooks(""Kitap1.xls"").VBProject .VBComponents.Remove .VBComponents(""Modul1"") End With End Sub" Modüle yazılan kodun sayfada aktif yapılması "BU KOD MODÜL İÇİNE YAZILAN KODU SAYFA İÇİNDE AKTİF HALE GETİRİR. Private Sub Worksheet_SelectionChange(ByVal Target As Range) Call Makro1 End Sub " ModÜle yazilan kodu sayfada aktİf yapar "BU KOD MODÜL İÇİNE YAZILAN KODU SAYFA İÇİNDE AKTİF HALE GETİRİR. Private Sub Worksheet_SelectionChange(ByVal Target As Range) Call Makro1 End Sub " Mouse tıklayınca hesaplama "Private Sub TextBox25_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) On Error Resume Next If TextBox5 = Empty Then : Exit Sub Else TextBox25.Value = WorksheetFunction.Round((TextBox5.Value * 0.7), 2) End If End Sub" Mp3 dosyası çalma "Public Declare Function mciSendString Lib ""winmm.dll"" Alias ""mciSendStringA"" _ (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _ ByValuReturnLength As Long, ByVal hwndCallback As Long) As Long Public Declare Function GetShortPathName Lib ""kernel32"" Alias _ ""GetShortPathNameA"" (ByVal lpszLongPath As String, ByVal lpszShortPath As _ String, ByVal cchBuffer As Long) As Long Sub LanceMP3() X = ThisWorkbook.Path joueMP3 (X & ""\monfichier.mp3"") End Sub Public Sub joueMP3(ByVal Mp3 As String) Dim Tmp As Long, Tmp2 As String 'Screen.MousePointer = vbHourglass Tmp2 = NomCourt(Mp3) Tmp = mciSendString(""close MP3_Device"", vbNullString, 0&, 0&) Tmp = mciSendString(""open "" & Tmp2 & "" type MPEGVideo alias MP3_Device"", _ vbNullString, 0&, 0&) If Tmp = 0 Then Tmp = mciSendString(""play Mp3_Device"", vbNullString, 0&, 0&) If Tmp <> 0 Then Screen.MousePointer = 0 MsgBox ""Incapable de jouer ce Mp3"" 'Else ' Tmp = mciSendString(""close MP3_Device"", vbNullString, 0&, 0&) End If Else 'Screen.MousePointer = 0 MsgBox ""Incapable de jouer ce Mp3"" End If 'Screen.MousePointer = 0 End Sub Public Sub StopMP3() Dim Tmp As Long Tmp = mciSendString(""close MP3_Device"", vbNullString, 0&, 0&) End Sub Private Function NomCourt(ByVal Fichier As String) As String Dim Tmp As String * 255, Tmp2 As Byte Tmp2 = GetShortPathName(Fichier, Tmp, Len(Tmp)) If Tmp2 > 0 Then NomCourt = Left(Tmp, Tmp2) End If End Function" Mp3 dosyasının süresini hesaplatın (dosya yolunu yazın ve o hücreyi seçin) "örneğin A5 hücresine C:\zeynel.mp3 yazın ve a5 hücresini seçin Option Explicit ' Modul ' benötigte API-Deklarationen Private Declare Function mciSendString Lib ""winmm.dll"" _ Alias ""mciSendStringA"" ( _ ByVal lpstrCommand As String, _ ByVal lpstrReturnString As String, _ ByVal uReturnLength As Long, _ ByVal hwndCallback As Long) As Long Private Declare Function GetShortPathName Lib ""kernel32"" _ Alias ""GetShortPathNameA"" ( _ ByVal lpszLongPath As String, _ ByVal lpszShortPath As String, _ ByVal cchBuffer As Long) As Long ' Ermittelt die Länge einer MP3-Datei Sub Länge_MP3() Dim song As String Dim zeile As Integer zeile = ActiveCell.Row song = Cells(zeile, 1).Value '""C:\My Music\MP3\ABBA - Mamma Mia.mp3"" MsgBox (""Titellänge: "" & Chr(13) & Chr(13) & FormatTime(GetMP3Length(song)) & "" min."") End Sub ' in Millisekunden Function GetMP3Length(ByVal strFileName As String) As Long Dim strBuffer As String Dim lRet As Long Dim sReturn As String ' Da die mciSendString Funktion mit langen Dateinamen ' nicht korrekt arbeitet, muss zuvor der kurze ' 8.3 Dateiname der MP3-Datei ermittelt werden. strBuffer = Space$(255) lRet = GetShortPathName(strFileName, strBuffer, Len(strBuffer)) If lRet <> 0 Then strFileName = Left$(strBuffer, InStr(strBuffer, vbNullChar) - 1) End If ' MP3-Datei öffnen mciSendString ""open "" & strFileName & _ "" type MPEGVideo alias mp3audio"", 0, 0, 0 ' Länge der Datei in Millisekunden auslesen sReturn = Space$(256) lRet = mciSendString(""status mp3audio length"", _ sReturn, Len(sReturn), 0&) ' MP3-Datei schliessen mciSendString ""close mp3audio"", 0, 0, 0 GetMP3Length = Val(sReturn) End Function ' Für das Umwandeln der Zeitrückgabe (Millisekunden) in ein besser ' lesbares Format (Minuten:Sekunden) können Sie zusätzlich nachfolgende ' Funktion einsetzen: ' Millisekunden in lesbares Zeitformat umwandeln Function FormatTime(ByVal lMSec As Long) _ As String Dim iMin As Integer Dim iSec As Integer iSec = Int(lMSec / 1000) iMin = Int(iSec / 60) iSec = iSec - (iMin * 60) FormatTime = Format$(iMin, ""00"") & "":"" & _ Format$(iSec, ""00"") End Function" Msgbox ikaz "Sub sonkezsor() soru = MsgBox(""Eminmisiniz?"", Buttons:=vbQuestion + vbYesNo) If soru = vbYes Then End If End Sub " Msgbox la a1 e veri girme "Sub EingabeUeberInputbox() Dim wert01 As String wert01 = InputBox(""Wert eingeben"", ""Bitte geben Sie einen Wert ein"") Range(""a1"").Value = wert01 End Sub" Msgbox'da - gÜn - tarİh - saat gÖsterİ "Msgbox'da - Gün - Tarih - Saat gösterir Sub MsgBox() Dim WshShell Dim intAntwort As Integer Set WshShell = CreateObject(""WScript.Shell"") intAntwort = WshShell.Popup(WeekdayName(Weekday(Date, vbMonday)) _ & Chr(13) & _ Day(Date) & "". "" & _ MonthName(Month(Date)) & "" "" & _ Year(Date) & Chr(13) & _ Time, 3, ""www.excel.web.tr"") End Sub " Msgbox'da - gün - tarih - saat gösterir "Sub MsgBox() Dim WshShell Dim intAntwort As Integer Set WshShell = CreateObject(""WScript.Shell"") intAntwort = WshShell.Popup(WeekdayName(Weekday(Date, vbMonday)) _ & Chr(13) & _ Day(Date) & "". "" & _ MonthName(Month(Date)) & "" "" & _ Year(Date) & Chr(13) & _ Time, 3, ""pir"") End Sub" Multipage de butonla geçiş "Private Sub CommandButton3_Click() MultiPage1.Value = MultiPage1.Value + 1 End Sub " Multipage de sayfa seçmek "Private Sub MultiPage1_Change() Select Case MultiPage1.SelectedItem.Caption Case ""Page1"": Sheets(""Sayfa1"").Select Case ""Page2"": Sheets(""Sayfa2"").Select Case ""Page3"": Sheets(""Sayfa3"").Select Case ""Page4"": Sheets(""Sayfa4"").Select End Select End Sub" Multipage' e tıklayınca makro çalışması "Öncelikle Page1'in index'inin 0 ve page2'nin index'inin 1 olduğunu bilmelisiniz. Aşağıdaki kodu yazın. Private Sub MultiPage1_Click(ByVal Index As Long) Select Case Index Case 0 makro1 Case 1 makro2 End Select End Sub " Multipage geçiş şifreli "Private Sub UserForm_Initialize() MultiPage1.Value = 0 End Sub Private Sub MultiPage1_Click(ByVal Index As Long) If Index = 1 Then CommandButton6.Enabled = False CommandButton7.Enabled = False sor = InputBox(""ŞİFREYİ GİRİNİZ"", ""ŞİFRE GİR"") If sor = ""şifre"" Then CommandButton6.Enabled = True CommandButton7.Enabled = True Exit Sub End If MsgBox ""HATALI ŞİFRE"" End If End Sub" Multipage geçişi "Private Sub CommandButton1_Click() MultiPage1.Value = MultiPage1.Value + 1 End Sub" Multipage te gezinti butonla " '// Birinci sayfayi gosterir MultiPage1.Value = 0 '// Ikinci sayfayi gosterir MultiPage1.Value = 1 " Multipage te gezinti scroll barla "Userforma bir scrollbar ekleyin ve aşağıdaki kodu scrollbara yazın. Private Sub ScrollBar1_Change() MultiPage1.Value = ScrollBar1.Value End Sub 'Eğer hep page üç açılsın diyorsanız, bu durumda hangi nesneyi kullanıyorsanız ona aşağıdaki kodu yazmak yeterlidir. MultiPage1.Value = 2 " Multipage zemin rengi "Gerçekten bu durum çok enterasan. Form üzerinde herşeyi yapabiliyorsunuz fakat MultiPage nesnesinin zemin rengini değiştirmek için bir özelliğin olmadığını fark ediyorsunuz. Bu durumda sorulan sorunun cevabını bir kurnazlık yaparak bulmak gerekiyor. Tüm kontrolleri yerleştirdikten sonra MultiPage nesnesi üzerine bir Image nesnesi yerleştirin ve tüm kontrollerin altına gönderin ve Image nesnesinin zemin rengini istediğiniz renk yapın. Böylece MultiPage nesnesinin değişmeyen zemin rengini örtmüş olursunuz. Bu işlemi en son yapın ki düzenlemelerde bir sorunla karşılaşmayın." MultiPageden sayfaya geçiş "Private Sub MultiPage1_Click(ByVal Index As Long) Select Case Index Case 0: Sheets(1).Select Case 1: Sheets(2).Select End Select End Sub" Multipageler de sayfaya geçiş "Private Sub MultiPage1_Click(ByVal Index As Long) Select Case Index Case 0: Sheets(1).Select Case 1: Sheets(2).Select End Select End Sub" Mükemmel menü ekleme, dosya menüsünde yazdır, baskı önizle, sayfa yapısı kalır "Private Sub Workbook_Open() Dim CmdB As CommandBar, nCmdB As CommandBar Dim nCtlP As CommandBarPopup, nCtlB As CommandBarButton For Each CmdB In Application.CommandBars If CmdB.Type = msoBarTypeMenuBar And _ CmdB.Name = ""Meine Menueleiste"" Then CmdB.Delete End If Next CmdB Set nCmdB = Application.CommandBars.Add _ (Name:=""Meine Menueleiste"", Position:=msoBarTop, _ MenuBar:=True, Temporary:=True) With nCmdB .Protection = msoBarNoMove .Protection = msoBarNoChangeDock .Protection = msoBarNoChangeVisible .Protection = msoBarNoCustomize .Protection = msoBarNoVerticalDock .Visible = True End With Set nCtlP = nCmdB.Controls.Add(Type:=msoControlPopup) With nCtlP .Caption = ""Mein Menue &1"" End With Set nCtlB = nCtlP.Controls.Add(ID:=247) With nCtlB .Style = msoButtonCaption End With Set nCtlB = nCtlP.Controls.Add(ID:=109) With nCtlB .Style = msoButtonAutomatic End With Set nCtlB = nCtlP.Controls.Add(ID:=4) With nCtlB .BeginGroup = True .Style = msoButtonAutomatic End With Set nCtlP = nCmdB.Controls.Add(Type:=msoControlPopup) With nCtlP .Caption = ""Mein Menue &2"" End With Set nCtlB = nCtlP.Controls.Add(ID:=1) With nCtlB .Caption = ""Mein VBA-Makro &1"" .OnAction = ""Me_001_Code01"" .Style = msoButtonCaption End With Set nCtlB = nCtlP.Controls.Add(ID:=1) With nCtlB .BeginGroup = True .FaceId = 239 .Caption = ""Mein VBA-Makro &2"" .OnAction = ""Me_001_Code02"" .Style = msoButtonIconAndCaption End With End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Call Me_001_Delete End Sub Public Sub Me_001_Code01() MsgBox ""Die Option 'Mein VBA-Makro 1' wurde gewählt!"", _ vbInformation, ""Code-Beispiel (Me_001)"" End Sub Public Sub Me_001_Code02() MsgBox ""Die Option 'Mein VBA-Makro 2' wurde gewählt!"", _ vbInformation, ""Code-Beispiel (Me_001)"" End Sub Public Sub Me_001_Delete() On Error Resume Next Application.CommandBars(""Meine Menueleiste"").Delete On Error GoTo 0 End Sub" Mükemmel mp3 çaldırma "Private Declare Function mciSendString Lib ""winmm.dll"" Alias _ ""mciSendStringA"" (ByVal lpstrCommand As String, ByVal _ lpstrReturnString As String, ByVal uReturnLength As Long, _ ByVal hwndCallback As Long) As Long Private isPlaying As Boolean Public Sub Ap_002_Play() Dim mp3File As String 'Dim mp3File$ mp3File = Chr$(34) & ""C:\mp3\muamma.mp3"" & Chr$(34) If isPlaying = True Then Call mciSendString(""Stop MM"", 0&, 0&, 0&) Call mciSendString(""Close MM"", 0&, 0&, 0&) Call mciSendString(""Open "" & mp3File & "" Alias MM"", 0&, 0&, 0&) Call mciSendString(""Play MM"", 0&, 0&, 0&) Else Call mciSendString(""Open "" & mp3File & "" Alias MM"", 0&, 0&, 0&) Call mciSendString(""Play MM"", 0&, 0&, 0&) isPlaying = True End If End Sub Public Sub Ap_002_Stop() If isPlaying = False Then Exit Sub Call mciSendString(""Stop MM"", 0&, 0&, 0&) Call mciSendString(""Close MM"", 0&, 0&, 0&) End Sub" Mükemmel sağ fareye menüsünü siler ve yazdır, baskı önizle, sayfa yapısını ekler "Private Sub Workbook_Open() Dim CmdB As CommandBar, nCmdB As CommandBar Dim nCtlB As CommandBarButton For Each CmdB In Application.CommandBars If CmdB.Type = msoBarTypePopup And _ CmdB.Name = ""Mein Kontextmenue"" Then CmdB.Delete End If Next CmdB Set nCmdB = Application.CommandBars.Add _ (Name:=""Mein Kontextmenue"", Position:=msoBarPopup, _ Temporary:=True) Set nCtlB = nCmdB.Controls.Add(ID:=1) With nCtlB .Caption = ""Mein VBA-Makro &1"" .OnAction = ""Me_002_Code"" .Style = msoButtonCaption End With Set nCtlB = nCmdB.Controls.Add(ID:=1) With nCtlB .FaceId = 239 .Caption = ""Mein VBA-Makro &2"" .OnAction = ""Me_002_Code"" .Style = msoButtonIconAndCaption End With Set nCtlB = nCmdB.Controls.Add(ID:=247) With nCtlB .BeginGroup = True .Style = msoButtonCaption End With Set nCtlB = nCmdB.Controls.Add(ID:=109) With nCtlB .Style = msoButtonAutomatic End With Set nCtlB = nCmdB.Controls.Add(ID:=4) With nCtlB .BeginGroup = True .Style = msoButtonAutomatic End With End Sub Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, _ ByVal Target As Excel.Range, Cancel As Boolean) Cancel = True On Error GoTo Fehler Application.CommandBars(""Mein Kontextmenue"").ShowPopup Exit Sub Fehler: Cancel = False End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Call Me_002_Delete End Sub Public Sub Me_002_Code() MsgBox ""Die Option 'Mein VBA-Makro "" & _ Application.CommandBars(""Mein Kontextmenue"") _ .Controls(Application.Caller(1)).Index & _ ""' wurde gewählt!"", _ vbInformation, ""Code-Beispiel (Me_002)"" End Sub Public Sub Me_002_Delete() On Error Resume Next Application.CommandBars(""Mein Kontextmenue"").Delete On Error GoTo 0 End Sub" Mükerrer kayıt var ikazı "Private Sub CommandButton2_Click() For Each ayni In Range(""b2:b1000"") If ayni.Value = CStr(TextBox2.Value) Then DUR4 = MsgBox(""GİRMİŞ OLDUĞUNUZ VERGİ NUMARASI KAYITLARDA BULUNMAKTADIR"", vbYes, ""YANLIŞ"") TextBox2.Value = """" Exit Sub End If Next End Sub" Mükerrer kayıtlarda yeniden kayıt yapılsın mı olayı "Private Sub CommandButton1_Click() If TextBox2.Value <> """" Then Sheets(""Sayfa1"").Activate Cells(1, 1).Select Do While ActiveCell.Value <> """" If Trim(ActiveCell.Value) = Trim(Me.TextBox1.Value) Then If MsgBox(Me.TextBox1 & "" isimli işçi kayıtlı"" & "" Yeniden kayıt yapılsın mı?"", vbYesNo) = vbNo Then Exit Sub End If ActiveCell.Offset(1, 0).Activate Loop ActiveCell.Value = TextBox1.Value ActiveCell.Offset(0, 1).Value = TextBox2.Value End If End Sub" Mükerrer kayıtları siler "Sub çift_kayıtları_kaldır() Cells.Sort Key1:=Range(""A1"") totalrows = ActiveSheet.UsedRange.Rows.Count Count = 1 For Row = totalrows To 2 Step -1 If Cells(Row, 1).Value = Cells(Row - 1, 1).Value Then Rows(Row).Delete Count = Count + 1 End If Next Row End Sub" Mükerrer kayıtları siler (mükerrer kayıt raporlar) "Sub RemoveDuplicates() Cells.Sort Key1:=Range(""A1"") totalrows = ActiveSheet.UsedRange.Rows.Count Count = 1 For Row = totalrows To 2 Step -1 If Cells(Row, 1).Value = Cells(Row - 1, 1).Value Then Rows(Row).Delete Count = Count + 1 Else Cells(Row, 3).Value = Count Count = 1 End If Next Row Cells(1, 3).Value = Count End Sub" Mükerrer olanları kırmızı ile tespit etmek "Sub mukerrer() For a = 1 To [a65536].End(xlUp).Row If WorksheetFunction.CountIf(Columns(1), Cells(a, 1)) > 1 Then Cells(a, 1).Interior.ColorIndex = 3 Next End Sub" Negetif sayıları toplama "Sub SommeNégative() For Each Cell In Range(""A1:A10"") If Cell.Value < 0 Then total = total + Cell End If Next MsgBox ""Total des valeurs négatives "" & total Range(""A11"") = total End Sub" Nesne ekleme penceresi "Sub Dialog_41() Application.Dialogs(xlDialogInsertObject).Show End Sub" Nesne ÖzellİĞİnİ tek seferde deĞİŞtİrme "Sorunuz üzerinde düşündüm tam bir çözüm olmasada şu şekilde yapılabilir. çok daha iyi öneriler çıkacaktır mutlaka. textboxların bulunduğu userformun içine aşağıdaki kodu yazınız. Fakat bunu sadece userform_click olayında gerçekleştirebildim. Yani formatların değiştirilmesi için userforma bir kere tıklamak gerekiyor. Kod: Private Sub UserForm_Click() For a = 1 To 16 UserForm1.Controls(""TextBox"" & a) = Format(UserForm1.Controls(""TextBox"" & a), ""###.#######"") Next a End Sub diğer bir çözümde;eğer textboxlardan sonra örneğin bir command buton seçilecekse aynı kodlar bu butonun içine yazılabilir. Kod: Private Sub CommandButton1_Enter() For a = 1 To 16 UserForm1.Controls(""TextBox"" & a) = Format(UserForm1.Controls(""TextBox"" & a), ""###.#######"") Next a End Sub Başka önerileri açıkçası bende merakla bekliyorum. " Networkteki yazıcı da yazdırır "Sub PrintToNetworkPrinterExample() Dim strCurrentPrinter As String, strNetworkPrinter As String strNetworkPrinter = GetFullNetworkPrinterName(""HP LaserJet 8100 Series PCL"") If Len(strNetworkPrinter) > 0 Then ' found the network printer strCurrentPrinter = Application.ActivePrinter ' change to the network printer Application.ActivePrinter = strNetworkPrinter Worksheets(1).PrintOut ' print something ' change back to the previously active printer Application.ActivePrinter = strCurrentPrinter End If End Sub Function GetFullNetworkPrinterName(strNetworkPrinterName As String) As String ' returns the full network printer name ' returns an empty string if the printer is not found ' e.g. GetFullNetworkPrinterName(""HP LaserJet 8100 Series PCL"") ' might return ""HP LaserJet 8100 Series PCL on Ne04:"" Dim strCurrentPrinterName As String, strTempPrinterName As String, i As Long strCurrentPrinterName = Application.ActivePrinter i = 0 Do While i < 100 strTempPrinterName = strNetworkPrinterName & "" on Ne"" & Format(i, ""00"") & "":"" On Error Resume Next ' try to change to the network printer Application.ActivePrinter = strTempPrinterName On Error GoTo 0 If Application.ActivePrinter = strTempPrinterName Then ' the network printer was found GetFullNetworkPrinterName = strTempPrinterName i = 100 ' makes the loop end End If i = i + 1 Loop ' remove the line below if you want the function to change the active printer Application.ActivePrinter = strCurrentPrinterName ' change back to the original printer End Function " Normal ekran için "Sub normal() Application.DisplayFullScreen = False End Sub" Not defterini açma ve kapama "Public id Sub starten() id = Shell(Range(""A1"").Value, vbNormalFocus) End Sub Sub beenden() AppActivate id SendKeys ""%{F4}"", True End Sub" Not defterini çağırma "NOT DEFTERİNİ ÇALIŞTIRIR Sub notdefteri() Call Shell(""notepad.exe."", 1) End Sub " Not defterİnİ ÇaĞirir "NOT DEFTERİNİ ÇALIŞTIRIR Sub notdefteri() Call Shell(""notepad.exe."", 1) End Sub " Not defterini veya diğer uygulamaları açma "Sub externesProgrammAusExcelAufrufen() Status = Shell(""notepad.exe"", 1) End Sub 'notepad.exe 'Calc.exe = 'MSPaint.exe 'sol.exe" Notepad ile txt dosyası açtırma Shell "notepad.exe c:\foldername\filename.txt", vbMaximizedFocus Numfact isimli hücrenin açılış ve kapanışta artırılması "Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim chemXlt As String chemXlt = Application.TemplatesPath & ""NumAuto.xlt"" If ActiveWorkbook.Path = """" Then Workbooks.Open (chemXlt) [NumFact] = [NumFact] - 1 ActiveWorkbook.Close True End If End Sub Private Sub Workbook_Open() If ActiveWorkbook.Path = """" Then [NumFact] = [NumFact] + 1 ActiveWorkbook.Saved = True ActiveWorkbook.SaveCopyAs _ Application.TemplatesPath & ""NumAuto.xlt"" End If End Sub" Numlock u açma, kapama "Declare Sub keybd_event Lib ""user32"" (ByVal bVk As Byte, ByValbScan As Byte, ByVal dwFlags As Long, _ ByVal dwExtraInfo As Long) Public Const VK_NUMLOCK = &H90 Sub Num_Lock_On() keybd_event VK_NUMLOCK, 1, 0, 0 End Sub Sub Num_Lock_Off() keybd_event VK_NUMLOCK, 0, 0, 0 End Sub" Office yardımcısına hello yazdırın "Sub assist() Application.Assistant.Visible = True Assistant.Animation = msoAnimationIdle Set SB = Assistant.NewBalloon SB.Animation = msoAnimationCheckingSomething SB.BalloonType = msoBalloonTypeButtons SB.Heading = "" H A L L O ! ! ! "" SB.Text = _ ""Ich bin Dein persönlicher Assistent"" If SB.Show = msoBalloonButtonOK Then Assistant.Visible = False End If End Sub" Ondalıklı toplam TextBox13.Value = TextBox1*1 + TextBox2*1 + TextBox3*1+. Optionbutonla seçilen verinin yazdirilmasi "Private Sub CommandButton2_Click() Application.Visible = True UserForm1.Hide ActiveSheet.PageSetup.PrintArea = ""$A$1:$H$20"" ActiveSheet.PrintPreview EnableChanges:=False ActiveSheet.PrintOut copies:=2, Preview:=False 'copies:=1 kopya sayısını artırmak için Application.Visible = False UserForm1.Show End Sub " Optİonbuttonlarin İŞaretİnİ kaldirmak "Aşağıdaki gibi bir kodla kaldırabilirsiniz. visual basic kodu: OptionButton1.Value = False OptionButton2.Value = False . . ." Optionbuttonun özelliğini textboxa yazdırmak "Private Sub OptionButton2_Click() If OptionButton2.Value = True Then 'işaretlediğinde manuel girmesinler diye TextBox10.Enabled = False TextBox10.Value = ""Döküman"" Else TextBox10.Value = Empty End If End Sub Private Sub OptionButton1_Click() 'manuel girmeleri için true TextBox10.Enabled = True TextBox10.Value = """" End Sub" Otomatİk cÜmle yazar "Açıklama: Çalışma Sayfanızda herhangi bir hücreye 1 yazdığınızda bire karşılık gelen Cümle otomatik yazılır (En hızlı siz yazacaksınız ) Kod: Private Sub Worksheet_Change(ByVal Target As Excel.Range) If IsEmpty(Target) Then Exit Sub If Target = ""1"" Then Target = ""İlçe Milli EĞitim Müdürlüğü"" If Target = ""2"" Then Target = ""Ahmet Aşkın KÜÇÜKKAYA"" If Target = ""3"" Then Target = ""Ordu İli Kabataş İlçesi"" If Target = ""4"" Then Target = ""Kabataş"" End Sub " Otomatik düzelt penceresi "Sub Dialog_07() Application.Dialogs(xlDialogAutoCorrect).Show End Sub" Otomatik hesaplama etkin-etkisiz "Sub Makro2() With Application .Calculation = xlManual End With End Sub Sub Makro3() With Application .Calculation = xlAutomatic End With End Sub Sub Makro4() Calculate End Sub" Otomatik makro her 10 saniyede "Dim RunWhen As Double Const RunWhat = ""Info"" ' Sub Auto_Open() StartTimer End Sub ' Sub StartTimer() RunWhen = Now + TimeSerial(0, 0, 5) Application.OnTime earliesttime:=RunWhen, procedure:=RunWhat, schedule:=True End Sub ' Sub Info() ' Aşağıdaki satırda yer alan MsgBox fonksiyonu yerine, ' çalıştırılmasını istediğiniz başka bir makronun adını yazarak ' o makronun çalıştırılmasını sağlayabilirsiniz. MsgBox ""Dikkat, sayfayi güncelleyin !"" StartTimer End Sub ' Sub StopTimer() On Error Resume Next Application.OnTime earliesttime:=RunWhen, procedure:=RunWhat, schedule:=False End Sub ' Sub Auto_Close() StopTimer End Sub" Otomatİk makro kayİt "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = ""$B$8"" And Target.Value = 20 Then Cells.Select Selection.Copy Worksheets.Add.Name = Range(""A4"") ActiveSheet.Paste ActiveWorkbook.Save End If End Sub " Otomatik süz ile alttoplam =ALTTOPLAM(9;B3:B1000) Otomatik süzü (filtreyi) aç "Sub FilterAufheben() If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData End Sub" Otomatik süzü açtırma "Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Range) CommandButton1.Caption = Range(""A1"").Value & Chr(13) & Chr(13) & "" gefilterte Zeilen"" End Sub 'sayfadaki buton bura ile ilişkilendirilecek Private Sub CommandButton1_Click() Filter_setzen CommandButton1.Caption = Range(""A1"").Value & Chr(13) & Chr(13) & "" gefilterte Zeilen"" End Sub 'modüle Sub Filter_setzen() Range(""c1"").Select SendKeys ""%{Down}"" Range(""D1"").Select Range(""C1"").Select End Sub" ÖNİzleme makrosu "Me.Hide Sheets(""test"").Select ActiveWindow.SelectedSheets.PrintPreview Me.Show " ÖNizlemesiz a5 kaüıttan çıktı alma "Private Sub CommandButton1_Click() Sheets(""Sayfa1"").Select With ActiveSheet.PageSetup .PaperSize = xlPaperA5: .CenterHorizontally = True: .Orientation = xlPortrait .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = 1 End With Unload Me ActiveWindow.SelectedSheets.PrintOut Copies:=1 End Sub" Önizlemesiz yazdırma "Private Sub CommandButton1_Click() Sheets(""Sayfa1"").Select With ActiveSheet.PageSetup .PaperSize = xlPaperA5: .CenterHorizontally = True: .Orientation = xlPortrait .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = 1 End With Unload Me ActiveWindow.SelectedSheets.PrintOut Copies:=1 End Sub" ÖZel altbilgi sayfa1 de sol alt köşede kitap ismi "Sub Dateipfad() Worksheets(1).PageSetup.LeftFooter = ThisWorkbook.FullName End Sub" Özel gider iİndirimi makrosu "Function iade2005(tutar) iade2005 = Round(Switch(tutar > 6600, (tutar - 6600) * 0.04 + 462, tutar > 3300, (tutar - 3300) * 0.06 + 264, tutar <= 3300, (tutar) * 0.08), 2) End Function" ÖZel görünümler penceresi "Sub Dialog_19() Application.Dialogs(xlDialogCustomViews).Show End Sub" ÖZelaltbilgi sağda dosya yolu, sağda kitap ismi "Sub Pied_Page() Dim Repert As String Dim Fichier As String Repert = ActiveWorkbook.Path Fichier = ActiveWorkbook.Name With ActiveSheet.PageSetup .LeftFooter = Repert .RightFooter = Fichier End With End Sub" Para formatı "Sub Euro() Selection.NumberFormat = ""#,##0.00 "" & ChrW(8364) End Sub Sub Euro0() Selection.NumberFormat = ""#,##0 "" & ChrW(8364) End Sub Sub EuroRot() Selection.NumberFormat = ""#,##0.00 "" & ChrW(8364) & "" ;[RED]-#,##0.00 "" & _ ChrW(8364) End Sub" ParÇa al fonksİyonu macro olarak hazirlamak "aşağıdaki kod işinizi görecektir. Kod: For i = 2 To Cells(65536, 1).End(xlUp).Row son = 1 For j = 2 To Cells(1, 1).End(xlToRight).Column Cells(i, j) = Mid(Cells(i, 1), son, Cells(1, j)) son = son + Cells(1, j) Next j Next i yapmanız gereken a2 den itibaren aşağı doğru verilerinizi yapıştırmak. ve b1, c1, d1, e1 gerektiği kadar alınması gereken parça boyutlarını girmek. yukarıdaki kodu şekilde görülen butonun içine yapıştırın." Parola değiştirme farklı kaydetle "Sub FarkliKaydet() 'Application.DisplayAlerts = False Workbooks(ActiveWorkbook.Name).SaveAs Filename:=ThisWorkbook.FullName, FileFormat:= _ xlNormal, Password:="""", WriteResPassword:="""", ReadOnlyRecommended:= _ False, CreateBackup:=True 'Application.DisplayAlerts = True End Sub" Partisyon belirt ne kadar dosya varsa listelesin "Option Explicit Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Const MAX_PATH = 260 Private Const FILE_ATTRIBUTE_DIRECTORY = &H10 Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Private Declare Function FindClose Lib ""kernel32"" (ByVal hFindFile As Long) As Long Private Declare Function FindFirstFile Lib ""kernel32"" Alias ""FindFirstFileA"" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib ""kernel32"" Alias ""FindNextFileA"" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Private nCount& 'Main code ================= Private Sub GetDirectoryListing(ByVal Root$) ' Function to calculate bytes used in Root$ and all subdirectories of Root$. ' Root$ should be entered in the form c:\Dir Dim FData As WIN32_FIND_DATA Dim fHand& Dim sPath$ Dim StillOK& Dim ByteTotal& Dim nPos% Dim DirName$, FileName$ sPath$ = Root$ + ""\*.*"" fHand& = FindFirstFile(sPath$, FData) If fHand& <= 0 Then Exit Sub End If ByteTotal& = 0 Do If (FData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then nPos% = InStr(FData.cFileName, Chr$(0)) DirName$ = Left$(FData.cFileName, nPos% - 1) If DirName$ <> ""."" And DirName$ <> "".."" Then GetDirectoryListing Root$ + ""\"" + DirName$ End If Else nCount& = nCount& + 1 nPos% = InStr(FData.cFileName, Chr$(0)) FileName$ = Left$(FData.cFileName, nPos% - 1) Cells(nCount&, 1).Value = Root$ + ""\"" + FileName$ _ '>>>>>>>>>>>>>>>>>>>> '& gt;> ' If you don't want the path just use: ' Cells(nCount&,1).value = FileName$ End If StillOK& = FindNextFile(fHand&, FData) Loop Until StillOK = 0 fHand& = FindClose(fHand&) End Sub Public Sub GetFileList() Dim Path$ nCount& = 0 Path$ = InputBox(""Enter the root for the file listing (e.g. 'c:\dir' orc:"") If Len(Path$) = 0 Then Exit Sub GetDirectoryListing Path$ End Sub" Pasİfİze olan excel ÇaliŞma kİtabinin aktİfleŞtİrİlmes "size iki ayrı seçenek öneriyorum örnek1: Sub Makro1() Range(""A2"").Select 10 ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate b = ActiveCell.Value satirno = ActiveCell.Row If b <> """" Then GoTo 10 End If Cells(satirno, 1) = Textbox1.Value End Sub örnek2: Sub Makro2() For a = 3 To 1000 b = Cells(a, 1).Value If b = """" Then Cells(a, 1) = Textbox1.Value GoTo 10 End If Next a 10 End Sub " Pasta diyagramı çizme "Sub kreisbogen() 'zeichnet Kreisbogen mit angegebenem Winkel Application.ScreenUpdating = False winkel = InputBox(""Winkel ?"") If winkel = Empty Or Not IsNumeric(winkel) Then Exit Sub ActiveSheet.Drawings.Add(100, 100, 100, 100, False) _ .Select For i = 0 To winkel k = 3.14159265358979 * i / 180 Selection.AddVertex 100 + 100 * Sin(k), 100 + 100 * Cos(k) i = i + 1 Next Selection.AddVertex 100, 100 Application.ScreenUpdating = True End Sub" Pc kapatma kodları "Declare Function ExitWindowsEx& Lib ""user32"" _ (ByVal uFlags&, ByVal wReserved&) Global Const EWX_FORCE = 8 Global Const EWX_LOGOFF = 0 Global Const EWX_REBOOT = 2 Global Const EWX_SHUTDOWN = 1 Sub calistir() Dim Kapatma_Zamani As Variant Kapatma_Zamani = InputBox(""Windows'un ne zaman kapanmasını istersiniz?"", , _ Format(Now + TimeSerial(0, 1, 0), ""hh:mm:ss"")) If Kapatma_Zamani = """" Then Exit Sub Application.OnTime TimeValue(Kapatma_Zamani), ""Windowsu_Kapat"" End Sub Sub Windowsu_Kapat() Dim LResult LResult = ExitWindowsEx(EWX_SHUTDOWN, 0&) End Sub" Pdf dosyası açma penceresi "Sub BrowsePDFDocument() Dim strDocument As String strDocument = Application.GetOpenFilename(""PDF Files,*.pdf,All Files,*.*"", 1, ""Open File"", , False) ' get pdf document name If Len(strDocument) < 6 Then Exit Sub ActiveWorkbook.FollowHyperlink strDocument End Sub" Pdf dosyası açma penceresi2 "Declare Function GetTempFileName Lib ""kernel32"" _ Alias ""GetTempFileNameA"" (ByVal lpszPath As String, _ ByVal lpPrefixString As String, ByVal wUnique As Long, _ ByVal lpTempFileName As String) As Long Declare Function FindExecutable Lib ""shell32.dll"" _ Alias ""FindExecutableA"" (ByVal lpFile As String, _ ByVal lpDirectory As String, ByVal lpResult As String) As Long Function GetExecutablePath(strFileType As String) As String Dim strFileName As String, f As Integer, strExecutable As String, r As Long If Len(strFileType) = 0 Then Exit Function ' no file type strFileName = String$(255, "" "") strExecutable = String$(255, "" "") GetTempFileName CurDir, """", 0&, strFileName ' get a temporary file name strFileName = Application.Trim(strFileName) strFileName = Left$(strFileName, Len(strFileName) - 3) & strFileType ' add the given file type f = FreeFile Open strFileName For Output As #f ' create the temporary file Close #f r = FindExecutable(strFileName, vbNullString, strExecutable) ' look for an associated executable Kill strFileName ' remove the temporary file If r > 32 Then ' associated executable found strExecutable = Left$(strExecutable, InStr(strExecutable, Chr(0)) - 1) Else ' no associated executable found strExecutable = vbNullString End If GetExecutablePath = strExecutable End Function Sub OpenPDFDocument() Dim strDocument As String, strExecutable As String strDocument = Application.GetOpenFilename(""PDF Files,*.pdf,All Files,*.*"", 1, ""Open File"", , False) ' get pdf document name If Len(strDocument) < 6 Then Exit Sub strExecutable = GetExecutablePath(""pdf"") ' get the path to Acrobat Reader If Len(strExecutable) > 0 Then Shell strExecutable & "" "" & strDocument, vbMaximizedFocus ' open pdf document End If End Sub" Pdf önizleme "Sub PrintingTest() Dim sFileName As String 'Change here to an appropriate file name sFileName = ""C:\V080506.pdf"" 'Prints three copies. PrintPDF2 sFileName, 3 MsgBox ""Data has been sent. "" & vbLf & _ ""Please close the instance of Acrobat Reader after printing."" End Sub Sub PrintPDF2(ByVal FileName As String, Optional Copies As Long = 1) '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ '++ Prints the PDF files using a command line. '++ Written by Masaru Kaji aka Colo '++ Syntax '++ FileName : Required String expression that specifies a file name '++ - may include directory or folder, and drive.. '++ Copies : Optional Long. The number of copies to print. '++ If omitted one copy is printed. '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Const PrinterName As String = """"""Microsoft Office Document Image Writer"""""" Const DriverName As String = """"""Microsoft Office Document Image Writer"""""" Const PortName As String = """"""Microsoft Office Document Image Writer port:"""""" Dim cnt As Long Set myShell = CreateObject(""WScript.Shell"") For cnt = 1 To Copies myShell.Run (""AcroRd32.exe /t "" & FileName & "" "" & PrinterName & "" "" & DriverName & "" "" & PortName) Next End Sub" Pencereleri yerleştir penceresi "Sub Dialog_06() Application.Dialogs(xlDialogArrangeAll).Show End Sub" Pencerelerin hepsi minimize "Sub ButunPencerelerMinimize() Dim Pencere As Window For Each Pencere In Windows If Pencere.Visible = False Then Pencere.Visible = True Pencere.WindowState = xlMinimized Next End Sub" Pencereyi dikey bölme "Sub GotoCol1() With Application ActiveWindow.FreezePanes = False Range(""H1"").Select ActiveWindow.FreezePanes = True .Goto Range(""IV1"") .Goto Range(""Z1"") End With End Sub" Pencereyi dikey bölme 2 "Sub GotoCol2() With Application ActiveWindow.FreezePanes = False Range(""H1"").Select ActiveWindow.FreezePanes = True .Goto Reference:=Range(""Z1""), Scroll:=True End With End Sub" Performans testi "Sub PerformanceTest() Dim i As Long Dim lngStart As Long lngStart = Timer With Workbooks(1).Sheets(1) For i = 1 To 65536 .Cells(i, 1).Value = ""Selamün Aleyküm!"" Next i End With MsgBox (Timer - lngStart) & "" saniye"" End Sub Sub performanstesti() Dim i As Long Dim lngStart As Long lngStart = Timer For i = 1 To 65536 ActiveWorkbook.Sheets(1).Cells(i, 1).Value = ""Mahmut BAYRAM"" Next i MsgBox (Timer - lngStart) & "" Saniye Vay be!"" End Sub Sub PerformanceTest() Dim i As Long Dim lngStart As Long Dim rngZellen As Range lngStart = Timer Set rngZellen = Workbooks(1).Sheets(1).Cells For i = 1 To 65536 rngZellen(i, 1).Value = ""Hello World!"" Next i MsgBox (Timer - lngStart) & "" Sekunden"" End Sub Sub PerformanceTest() Dim i As Long Dim lngStart As Long Dim rngZellen As Range lngStart = Timer Set rngZellen = Workbooks(1).Sheets(1).Range(""A1:A65536"").Rows rngZellen.Value = ""Hello World!"" MsgBox (Timer - lngStart) & "" Sekunden"" End Sub" Peşpeşe bul komutu "Global siparisler, sevkiyat, hammadde, emirler, kitap As Workbook Global rng, kosul As Range Global adres As String Function toplam(sht As Worksheet, malzeme As String, sart As String) Set rng = sht.Range(""C3:C5000"").Find(malzeme, Lookat:=xlWhole) Do If rng.Offset(0, 1) = sart Then toplam = toplam + rng.Offset(0, 2) Set rng = sht.Range(rng, Range(""C5000"")).FindNext If rng.Address = adres Then Exit Do adres = rng.Address Loop Set rng = Nothing End Function Sub güncelle() Dim ara As String Set kosul = Range(InputBox(""Güncellenecek tarihin hücre adresini girin"")) Application.ScreenUpdating = False ara = ActiveSheet.Name Set kitap = ThisWorkbook Set siparisler = Workbooks.Open(""G:\Deneme\Sipariş.xls"") Set sevkiyat = Workbooks.Open(""G:\Deneme\Sevkiyat.xls"") Set hammadde = Workbooks.Open(""G:\Deneme\Hammadde.xls"") Set emirler = Workbooks.Open(""G:\Deneme\Emirler.xls"") siparisler.Activate kosul.Offset(0, 1) = toplam(siparisler.Sheets(""Günlük""), ara, kosul.Value) hammadde.Activate kosul.Offset(0, 2) = toplam(hammadde.Sheets(""Günlük""), ara, kosul.Value) sevkiyat.Activate kosul.Offset(0, 3) = toplam(sevkiyat.Sheets(""Günlük""), ara, kosul.Value) emirler.Activate kosul.Offset(0, 4) = toplam(emirler.Sheets(""Günlük""), ara, kosul.Value) siparisler.Close False hammadde.Close False sevkiyat.Close False emirler.Close False kitap.Activate End Sub" Pİvot table sum - count hakkinda "Sub Makro2() Dim tablo As PivotTable Dim alan As PivotField For Each tablo In ActiveSheet.PivotTables For Each alan In tablo.DataFields alan.Function = xlCount Next Next End Sub" Pivot table verileri yineleme "Private Sub Worksheet_Change(ByVal Target As Range) ActiveSheet.PivotTables(""PivotTable4"").RefreshTable End Sub" Pivot table yenileme "Sub Refresh_Pivot() ActiveSheet.PivotTables(""PivotTable"").PivotSelect ""b"", xlDataAndLabel ActiveSheet.PivotTables(""PivotTable"").RefreshTable End Sub" Pivot tables veri yineleme ActiveSheet.PivotTables("PivotTable").RefreshTable Pivot tablo bilgilerinin güncellenmesinin açık olduğunu bildirir "Private Sub ConnectionApp_PivotTableOpenConnection(ByVal Target As PivotTable) MsgBox ""The PivotTable connection has been opened."" End Sub" Pivot tablo bilgilerinin güncellenmesinin kapalı olduğunu bildirir "Private Sub ConnectionApp_PivotTableCloseConnection(ByVal Target As PivotTable) MsgBox ""The PivotTable connection has been closed."" End Sub" Pivot tablodaki bilgileri yenileme 1 "Sub RefreshAllPivots() Dim wks As Worksheet Dim pt As PivotTable For Each wks In Worksheets For Each pt In wks.PivotTables pt.RefreshTable Next pt Next wks End Sub" Pivot tablodaki bilgileri yenileme 2 "Sub Refresh_Pivot() ActiveSheet.PivotTables(""PivotTable"").PivotSelect ""b"", xlDataAndLabel ActiveSheet.PivotTables(""PivotTable"").RefreshTable End Sub" Prİnt alinmiŞsa sayiyi bİr artir "Sub Düğme1_Tıklat() Range(""A1"") = Range(""A1"") + 1 ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate _ :=True Range(""A1"") = Range(""A1"") + 1 ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate _ :=True End Sub" Program açıldığında merhaba "Sub Auto_Open() Msgbox ""Hello"" End Sub" Program kapar "Sub kapa() MsgBox ""Bu programı pir düzenlemiştir."", , ""KAPATILIYOR"" ActiveWorkbook.Close True End Sub" Rakamı metne çevirme "Function yaz$(sayi) Dim b$(9) Dim y$(9) Dim m$(4) Dim v(15) Dim c(3) b$(0) = """" b$(1) = ""Bir"" b$(2) = ""İki"" b$(3) = ""Üç"" b$(4) = ""Dört"" b$(5) = ""Beş"" b$(6) = ""Altı"" b$(7) = ""Yedi"" b$(8) = ""Sekiz"" b$(9) = ""Dokuz"" y$(0) = """" y$(1) = ""On"" y$(2) = ""Yirmi"" y$(3) = ""Otuz"" y$(4) = ""Kırk"" y$(5) = ""Elli"" y$(6) = ""Altmış"" y$(7) = ""Yetmiş"" y$(8) = ""Seksen"" y$(9) = ""Doksan"" m$(0) = ""Trilyon"" m$(1) = ""Milyar"" m$(2) = ""Milyon"" m$(3) = ""Bin"" m$(4) = """" a$ = Str(sayi) If Left$(a$, 1) = "" "" Then pozitif = 1 Else pozitif = 0 a$ = Right$(a$, Len(a$) - 1) For x = 1 To Len(a$) If (Asc(Mid$(a$, x, 1)) > Asc(""9"")) Or (Asc(Mid$(a$, x, 1)) < Asc(""0"")) Then GoTo hata Next x If Len(a$) > 15 Then GoTo hata a$ = String(15 - Len(a$), ""0"") + a$ For x = 1 To 15 v(x) = Val(Mid$(a$, x, 1)) Next x s$ = """" For x = 0 To 4 c(1) = v((x * 3) + 1) c(2) = v((x * 3) + 2) c(3) = v((x * 3) + 3) If c(1) = 0 Then e$ = """" ElseIf c(1) = 1 Then e$ = ""Yüz"" Else e$ = b$(c(1)) + ""Yüz"" End If e$ = e$ + y$(c(2)) + b$(c(3)) If e$ <> """" Then e$ = e$ + m$(x) If (x = 3) And (e$ = ""BirBin"") Then e$ = ""Bin"" s$ = s$ + e$ Next x If s$ = """" Then s$ = ""Sıfır"" If pozitif = 0 Then s$ = ""Eksi"" + s$ yaz$ = s$ GoTo tamam hata: yaz$ = ""Hata"" tamam: End Function" Rakamı metne çevirme 2 " Yaziyla Fonksiyonu ' Fonksiyonu kullanmak için bu modül dosyasını ' projenize ekleyin ' ' Mesut AKCAN ' http://www.mesut.web.tr ' akcan@mesut.web.tr Function yaziyla(sayi As Currency) As String Dim b(9) As String Dim y(9) As String Dim m(4) As String Dim v(15) Dim c(3) b(0) = """" b(1) = ""Bir"" b(2) = ""İki"" b(3) = ""Üç"" b(4) = ""Dört"" b(5) = ""Beş"" b(6) = ""Altı"" b(7) = ""Yedi"" b(8) = ""Sekiz"" b(9) = ""Dokuz"" y(0) = """" y(1) = ""On"" y(2) = ""Yirmi"" y(3) = ""Otuz"" y(4) = ""Kırk"" y(5) = ""Elli"" y(6) = ""Altmış"" y(7) = ""Yetmiş"" y(8) = ""Seksen"" y(9) = ""Doksan"" m(0) = ""Trilyon "" m(1) = ""Milyar "" m(2) = ""Milyon "" m(3) = ""Bin "" m(4) = """" a$ = Str(sayi) If Left$(a$, 1) = "" "" Then pozitif = 1 Else pozitif = 0 a$ = Right$(a$, Len(a$) - 1) For x = 1 To Len(a$) If (Asc(Mid$(a$, x, 1)) > Asc(""9"")) Or (Asc(Mid$(a$, x, 1)) < Asc(""0"")) Then GoTo hata Next x If Len(a$) > 15 Then GoTo hata a$ = String(15 - Len(a$), ""0"") + a$ For x = 1 To 15 v(x) = Val(Mid$(a$, x, 1)) Next x s$ = """" For x = 0 To 4 c(1) = v((x * 3) + 1) c(2) = v((x * 3) + 2) c(3) = v((x * 3) + 3) If c(1) = 0 Then e$ = """" ElseIf c(1) = 1 Then e$ = ""Yüz"" Else e$ = b(c(1)) + ""Yüz"" End If e$ = e$ + y(c(2)) + b(c(3)) If e$ <> """" Then e$ = e$ + m(x) If (x = 3) And (e$ = ""BirBin "") Then e$ = ""Bin"" s$ = s$ + e$ Next x If s$ = """" Then s$ = ""Sıfır"" If pozitif = 0 Then s$ = ""Eksi "" + s$ yaziyla = s$ GoTo tamam hata: yaziyla = ""Hata"" tamam: End Function " Rakamı yazıya çevirme makrosu "Function yaziyacevir(rakam) Dim grup(5), sayi(10, 3), basamak(5), oku(3) sayi(0, 1) = """": sayi(0, 2) = """": sayi(0, 3) = """" sayi(1, 1) = ""YÜZ"": sayi(1, 2) = ""ON"": sayi(1, 3) = ""BİR"" sayi(2, 1) = ""İKİYÜZ"": sayi(2, 2) = ""YİRMİ"": sayi(2, 3) = ""İKİ"" sayi(3, 1) = ""ÜÇYÜZ"": sayi(3, 2) = ""OTUZ"": sayi(3, 3) = ""ÜÇ"" sayi(4, 1) = ""DÖRTYÜZ"": sayi(4, 2) = ""KIRK"": sayi(4, 3) = ""DÖRT"" sayi(5, 1) = ""BEŞYÜZ"": sayi(5, 2) = ""ELLİ"": sayi(5, 3) = ""BEŞ"" sayi(6, 1) = ""ALTIYÜZ"": sayi(6, 2) = ""ALTMIŞ"": sayi(6, 3) = ""ALTI"" sayi(7, 1) = ""YEDİYÜZ"": sayi(7, 2) = ""YETMİŞ"": sayi(7, 3) = ""YEDİ"" sayi(8, 1) = ""SEKİZYÜZ"": sayi(8, 2) = ""SEKSEN"": sayi(8, 3) = ""SEKİZ"" sayi(9, 1) = ""DOKUZYÜZ"": sayi(9, 2) = ""DOKSAN"": sayi(9, 3) = ""DOKUZ"" basamak(5) = ""TRİLYON"" basamak(4) = ""MİLYAR"" basamak(3) = ""MİLYON"" basamak(2) = ""BİN"" basamak(1) = """" lira = Int(rakam) kurus = Round(rakam - lira, 2) * 100 If Len(lira) > 15 Then MsgBox (""Bu fonksiyon en fazla 15 haneli sayılar için çalışır."") End End If kalan = lira yaziyacevir = """" For x = 1 To 5 a = 15 - 3 * x If Len(lira) > a Then grup(6 - x) = Int(kalan / 10 ^ a) kalan = kalan - (grup(6 - x) * 10 ^ a) End If Next x If grup(5) > 0 Then oku(1) = Int(grup(5) / 100) baskalan = grup(5) - oku(1) * 100 oku(2) = Int(baskalan / 10) oku(3) = baskalan - oku(2) * 10 yaziyacevir = sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(5) End If If grup(4) > 0 Then oku(1) = Int(grup(4) / 100) baskalan = grup(4) - oku(1) * 100 oku(2) = Int(baskalan / 10) oku(3) = baskalan - oku(2) * 10 yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(4) End If If grup(3) > 0 Then oku(1) = Int(grup(3) / 100) baskalan = grup(3) - oku(1) * 100 oku(2) = Int(baskalan / 10) oku(3) = baskalan - oku(2) * 10 yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(3) End If If grup(2) = 1 Then yaziyacevir = yaziyacevir + ""BİN"" End If If grup(2) > 1 Then oku(1) = Int(grup(2) / 100) baskalan = grup(2) - oku(1) * 100 oku(2) = Int(baskalan / 10) oku(3) = baskalan - oku(2) * 10 yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(2) End If If grup(1) > 0 Then oku(1) = Int(grup(1) / 100) baskalan = grup(1) - oku(1) * 100 oku(2) = Int(baskalan / 10) oku(3) = baskalan - oku(2) * 10 yaziyacevir = yaziyacevir + sayi(oku(1), 1) + sayi(oku(2), 2) + sayi(oku(3), 3) + basamak(1) End If yaziyacevir = yaziyacevir + "" YTL."" If kurus > 0 Then oku(2) = 0 If Len(kurus) > 1 Then oku(2) = Int(kurus / 10) End If oku(3) = kurus - oku(2) * 10 yaziyacevir = yaziyacevir + sayi(oku(2), 2) + sayi(oku(3), 3) + "" YKR."" End If End Function" Rakamı yazıyaçevirmek(ingilizce) "‘Kullanılışı ‘=SpellNumber(A1) yada ‘=SpellNumber(250) şeklinde kullanabilirsini Option Explicit ' ** ' Main Function * ' ** Function SpellNumber(ByVal MyNumber) Dim Dollars, Cents, Temp Dim DecimalPlace, Count ReDim Place(9) As String Place(2) = "" Thousand "" Place(3) = "" Million "" Place(4) = "" Billion "" Place(5) = "" Trillion "" ' String representation of amount MyNumber = Trim(Str(MyNumber)) ' Position of decimal place 0 if none DecimalPlace = InStr(MyNumber, ""."") 'Convert cents and set MyNumber to dollar amount If DecimalPlace > 0 Then Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & ""00"", 2)) MyNumber = Trim(Left(MyNumber, DecimalPlace - 1)) End If Count = 1 Do While MyNumber <> """" Temp = GetHundreds(Right(MyNumber, 3)) If Temp <> """" Then Dollars = Temp & Place(Count) & Dollars If Len(MyNumber) > 3 Then MyNumber = Left(MyNumber, Len(MyNumber) - 3) Else MyNumber = """" End If Count = Count + 1 Loop Select Case Dollars Case """" Dollars = ""No Dollars"" Case ""One"" Dollars = ""One Dollar"" Case Else Dollars = Dollars & "" Dollars"" End Select Select Case Cents Case """" Cents = "" and No Cents"" Case ""One"" Cents = "" and One Cent"" Case Else Cents = "" and "" & Cents & "" Cents"" End Select SpellNumber = Dollars & Cents End Function ' * ' Converts a number from 100-999 into text * ' * Private Function GetHundreds(ByVal MyNumber) Dim Result As String If Val(MyNumber) = 0 Then Exit Function MyNumber = Right(""000"" & MyNumber, 3) 'Convert the hundreds place If Mid(MyNumber, 1, 1) <> ""0"" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & "" Hundred "" End If 'Convert the tens and ones place If Mid(MyNumber, 2, 1) <> ""0"" Then Result = Result & GetTens(Mid(MyNumber, 2)) Else Result = Result & GetDigit(Mid(MyNumber, 3)) End If GetHundreds = Result End Function ' *** ' Converts a number from 10 to 99 into text. * ' *** Private Function GetTens(TensText) Dim Result As String Result = """" 'null out the temporary function value If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19 Select Case Val(TensText) Case 10: Result = ""Ten"" Case 11: Result = ""Eleven"" Case 12: Result = ""Twelve"" Case 13: Result = ""Thirteen"" Case 14: Result = ""Fourteen"" Case 15: Result = ""Fifteen"" Case 16: Result = ""Sixteen"" Case 17: Result = ""Seventeen"" Case 18: Result = ""Eighteen"" Case 19: Result = ""Nineteen"" Case Else End Select Else ' If value between 20-99 Select Case Val(Left(TensText, 1)) Case 2: Result = ""Twenty "" Case 3: Result = ""Thirty "" Case 4: Result = ""Forty "" Case 5: Result = ""Fifty "" Case 6: Result = ""Sixty "" Case 7: Result = ""Seventy "" Case 8: Result = ""Eighty "" Case 9: Result = ""Ninety "" Case Else End Select Result = Result & GetDigit _ (Right(TensText, 1)) 'Retrieve ones place End If GetTens = Result End Function ' * ' Converts a number from 1 to 9 into text. * ' * Private Function GetDigit(Digit) Select Case Val(Digit) Case 1: GetDigit = ""One"" Case 2: GetDigit = ""Two"" Case 3: GetDigit = ""Three"" Case 4: GetDigit = ""Four"" Case 5: GetDigit = ""Five"" Case 6: GetDigit = ""Six"" Case 7: GetDigit = ""Seven"" Case 8: GetDigit = ""Eight"" Case 9: GetDigit = ""Nine"" Case Else: GetDigit = """" End Select End Function " Rakamlarin soluna sifir eklenmesİ "148 Nolu Dış Genelge ile ilgilyse çalışman,TextBoxlarda değil Hücrelerde bu işlemi yapmanı tavsiye ederim.İstediğin Kod; Kod: Private Sub TextBox1_Change() TextBox1.Text = Format(TextBox1.Text, ""0000"") End Sub " Raporlamadakİ sorun "Private Sub CommandButton1_Click() Dim a As Integer Sheets(""liste"").Select Columns(""a:m"").Copy Sheets(""raporlama"").Select Columns(""a"").PasteSpecial Application.CutCopyMode = False Sheets(""liste"").Select For a = 13 To 1 Step -1 If Controls(""checkbox"" & a).Value = False Then Sheets(""raporlama"").Columns(a).Delete Next End Sub" Rastgele (random) numara verme "Sub RandomNumbers() Dim Number() Dim MyRange As Range Dim c As Range Set MyRange = Selection LastNumber = 100000 ReDim Number(LastNumber) For i = 1 To LastNumber Number(i) = i Next i For Each c In MyRange Placement = Int(Rnd() * LastNumber + 1) c.Value = Number(Placement) dummy = Number(LastNumber) Number(LastNumber) = Number(Placement) Number(Placement) = dummy LastNumber = LastNumber - 1 Next c End Sub" Rastgele bir sayinin üretilmesi "Sub Kura_Sonuc() For i = 1 To 15 'Kuraya Katılacak Kişi sayısı Randomize MsgBox Int(Rnd(1) * 100) 'Kuraya Katılacak Kişi Sayısı Next End Sub" Rastgele sayı üretir 49 dan küçük "Sub RandomNo() Randomize MyNumber = Int((49 - 1 + 1) * Rnd + 1) MsgBox (""The random number is "") & (MyNumber) End Sub" Rastgele sayı üretme "Sub Aleatoire() Dim NbreAlea As Integer Randomize NbreAlea = Int((10 * Rnd) + 1) Range(""A1"") = NbreAlea End Sub" Rastgele sayı üretmek "Evvvel D1 hücresine üretmek istediğiniz rakamların üst sınırını yazınız. D2 hücresine ise kaç adet sayı üreteceğinizi yazınız. Sub rastgele() Dim i As Integer Dim bul As Range Randomize If Range(""D1"").Value < Range(""D2"") Then MsgBox ""D1 hücresinin değeri D2 hücresinden küçük olmamalı"" Exit Sub ElseIf Range(""D1"").Value = """" Or Range(""D2"") = """" Then MsgBox ""Ama olmaz ki D1 ya da D2 Hücreleri boş olmaz"" Exit Sub End If Cells(1, 1).Value = Int((Range(""D1"") * Rnd) + 1) For i = 2 To Range(""D2"") Cells(i, 1).Value = Int((Range(""D1"") * Rnd) + 1) For Each bul In Range(""A1:A"" & Cells(i - 1, 1).Row) If Cells(i, 1).Value = bul.Value Then Cells(i, 1).Value = Int((Range(""D1"") * Rnd) + 1) End If Next bul Next i End Sub" Rastgele sayı üretmek "Sub DEN() Dim MyValue MyValue = Int((6 * Rnd) + 1) MsgBox MyValue End Sub" Rastgele sayı üretmek 2 "Sub Kura_Sonuc() For i = 1 To 15 'Kuraya Katılacak Kişi sayısı Randomize MsgBox Int(Rnd(1) * 100) 'Kuraya Katılacak Kişi Sayısı Next End Sub" Rastgele sayılar üreten random "Sub RandomNumbers() Dim Number() Dim MyRange As Range Dim c As Range Set MyRange = Selection LastNumber = 100000 ReDim Number(LastNumber) For i = 1 To LastNumber Number(i) = i Next i For Each c In MyRange Placement = Int(Rnd() * LastNumber + 1) c.Value = Number(Placement) dummy = Number(LastNumber) Number(LastNumber) = Number(Placement) Number(Placement) = dummy LastNumber = LastNumber - 1 Next c End Sub" Rastgele seçer fakat seçtiğini bir daha seçmez "Sub rast1() Dim rastgele As Integer ilk: rastgele = Int(Rnd() * 11) If rastgele <= 0 Or rastgele > 11 Then GoTo ilk If Cells(rastgele, 1).Interior.ColorIndex = 6 Then GoTo ilk Cells(rastgele, 1).Select Cells(rastgele, 1).Interior.ColorIndex = 6 End Sub" Rastgele seçimi farklı hücrelerden başlayarak yapar "Sub Random() Dim Satir As Integer Static Say As Integer Static Dizi(1 To 10) If Say = 10 Then Say = 0: Erase Dizi devam: Randomize Satir = Int((Rnd * 10) + 1) If IsError(Application.Match(Satir, Dizi(), 0)) And Say < 10 Then Say = Say + 1 Dizi(Say) = Satir Cells(Satir, 1).Select Cells(Satir, 1).Interior.ColorIndex = 5 Else: GoTo devam End If End Sub " Rastgele seçme "Sub Rastgele() say = WorksheetFunction.CountA([A:A]) b = Int((say * Rnd) + 1) MsgBox Range(""A"" & b) Range(""A"" & b).EntireRow.Delete End Sub" References kontrolü "Sub referanskontrol() On Error GoTo 10 For a = 1 To ThisWorkbook.VBProject.References.Count aranan = ThisWorkbook.VBProject.References.Item(a).Name If aranan = ""Outlook"" Then MsgBox ""ARANAN REFERANS İŞARETLİDİR"" Exit Sub End If Next sor = MsgBox(""REFERANS BULUNARAK İŞARETLENSİN Mİ?"", vbYesNo) If sor = vbYes Then ThisWorkbook.VBProject.References.AddFromGuid ""{00062FFF-0000-0000-C000-000000000046}"", 1, 0 MsgBox ""REFERANS İŞARETLENDİ"" Exit Sub 10 MsgBox ""REFERANS MEVCUT DEĞİL"" End Sub" Regİster de yenİ anahtar oluŞturmak "Yazmak için; Kod: Sub WriteReg() Dim WSH_Shell As Object RegKey = ""HKCU\Software\Microsoft\Internet Explorer\Main\Ornek "" Set WSH_Shell = CreateObject(""WScript.Shell"") WSH_Shell.RegWrite RegKey, 1, ""REG_DWORD"" End Sub Silmek için; Kod: Sub DelReg() Dim WSH_Shell As Object RegKey = ""HKCU\Software\Microsoft\Internet Explorer\Main\Ornek "" Set WSH_Shell = CreateObject(""WScript.Shell"") WSH_Shell.RegDelete RegKey End Sub " Registry'den bilgi almak "This program needs 3 buttons Const REG_SZ = 1 ' Unicode nul terminated string Const REG_BINARY = 3 ' Free form binary Const HKEY_CURRENT_USER = &H80000001 Private Declare Function RegCloseKey Lib ""advapi32.dll"" (ByVal hKey As Long) As Long Private Declare Function RegCreateKey Lib ""advapi32.dll"" Alias ""RegCreateKeyA"" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegDeleteValue Lib ""advapi32.dll"" Alias ""RegDeleteValueA"" (ByVal hKey As Long, ByVal lpValueName As String) As Long Private Declare Function RegOpenKey Lib ""advapi32.dll"" Alias ""RegOpenKeyA"" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib ""advapi32.dll"" Alias ""RegQueryValueExA"" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long Private Declare Function RegSetValueEx Lib ""advapi32.dll"" Alias ""RegSetValueExA"" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long 'retrieve nformation about the key lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize) If lResult = 0 Then If lValueType = REG_SZ Then 'Create a buffer strBuf = String(lDataBufSize, Chr$(0)) 'retrieve the key's content lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize) If lResult = 0 Then 'Remove the unnecessary chr$(0)'s RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1) End If ElseIf lValueType = REG_BINARY Then Dim strData As Integer 'retrieve the key's value lResult = RegQueryValueEx(hKey, strValueName, 0, 0, strData, lDataBufSize) If lResult = 0 Then RegQueryStringValue = strData End If End If End If End Function Function GetString(hKey As Long, strPath As String, strValue As String) Dim Ret 'Open the key RegOpenKey hKey, strPath, Ret 'Get the key's content GetString = RegQueryStringValue(Ret, strValue) 'Close the key RegCloseKey Ret End Function Sub SaveString(hKey As Long, strPath As String, strValue As String, strData As String) Dim Ret 'Create a new key RegCreateKey hKey, strPath, Ret 'Save a string to the key RegSetValueEx Ret, strValue, 0, REG_SZ, ByVal strData, Len(strData) 'close the key RegCloseKey Ret End Sub Sub SaveStringLong(hKey As Long, strPath As String, strValue As String, strData As String) Dim Ret 'Create a new key RegCreateKey hKey, strPath, Ret 'Set the key's value RegSetValueEx Ret, strValue, 0, REG_BINARY, CByte(strData), 4 'close the key RegCloseKey Ret End Sub Sub DelSetting(hKey As Long, strPath As String, strValue As String) Dim Ret 'Create a new key RegCreateKey hKey, strPath, Ret 'Delete the key's value RegDeleteValue Ret, strValue 'close the key RegCloseKey Ret End Sub Private Sub Command1_Click() Dim strString As String 'Ask for a value strString = InputBox(""Please enter a value between 0 and 255 to be saved as a binary value in the registry."", App.Title) If strString = """" Or Val(strString) > 255 Or Val(strString) < 0 Then MsgBox ""Invalid value entered "", vbExclamation + vbOKOnly, App.Title Exit Sub End If 'Save the value to the registry SaveStringLong HKEY_CURRENT_USER, ""KPD-Team"", ""BinaryValue"", CByte(strString) End Sub Private Sub Command2_Click() 'Get a string from the registry Ret = GetString(HKEY_CURRENT_USER, ""KPD-Team"", ""BinaryValue"") If Ret = """" Then MsgBox ""No value found !"", vbExclamation + vbOKOnly, App.Title: Exit Sub MsgBox ""The value is "" + Ret, vbOKOnly + vbInformation, App.Title End Sub Private Sub Command3_Click() 'Delete the setting from the registry DelSetting HKEY_CURRENT_USER, ""KPD-Team"", ""BinaryValue"" MsgBox ""The value was deleted "", vbInformation + vbOKOnly, App.Title End Sub Private Sub Form_Load() 'KPD-Team 1998 'URL: http://www.allapi.net/ 'E-Mail: KPDTeam@Allapi.net Command1.Caption = ""Set Value"" Command2.Caption = ""Get Value"" Command3.Caption = ""Delete Value"" End Sub" Renk saydırma hangi renkten kaç tane var buldurma "Sub CountColors() y = 0 g = 0 p = 0 oth = 0 For Each cell In Selection Select Case cell.Interior.ColorIndex Case 36 'yellow y = y + 1 Case 35 'green g = g + 1 Case 38 'pink p = p + 1 Case Else oth = oth + 1 End Select Next cell msg = y & "" Yellow"" msg = msg & vbCrLf & g & "" Green"" msg = msg & vbCrLf & p & "" Pink"" msg = msg & vbCrLf & oth & "" Other"" msg