EXCEL Size Yeter

Ataşehir’de yer alan “Tübitem” adlı şirketimizde gruplara excel eğitimleri vermekteyiz. Standart 4 hafta olan eğitimlerimizde excel kullanımı ile birlikte excel makro eğitimleri vermekteyiz.

Bunlar ile birlikte doğrudan şirketlere de eğitimler vermekteyiz. Eğitimler sadece bizim kurumumuzda değil, dilediğiniz zaman başka yerlerde de verilebilir.

Eğitimlerin içerikleri isteğe göre ve sektöre göre değiştirilebilir.

Eğitim zamanları hafta sonları olabileceği gibi haftaiçi akşamlar da olabilmektedir.

4 haftalık eğitimlerimiz kişi başına 750 TL olup grup olarak katılanlar için indirimler yapılmaktadır. Ayrıca fiyatlarımız pazarlığa açıktır.

Kurumsal Eğitimler    

Eğitim

Özel dersler, ders almak isteyen kişilerin evinde verilmektedir. Adresinize gelerek eğitimler vermekteyiz. Özel ders ücretimiz saatlik 80 TL eğitim süresinin uzunluğuna göre bu ücret indirilmektedir. En ucuz tutar ise 3 saat için 150 TL’dir. Bu fiyatın uygulanabilmesi için en az 6 saat eğitim alınması gerekmektedir.

Özel Dersler

).Controls(""Kommentar einfügen"").Enabled = True End If " ActiveCell.SpecialCells(xlLastCell).Select "Son kaldığınız hücreyi ""Static"" bir değişkene atayabilirsiniz. Static sonhucre as Range Sub Kontrol() set sonhucre = ""kontrol edilen hücre"" ....  'geri döndüğünüzde sonhucre.select 'yazdığınızda bu hücre seçilecektir. " "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 " "Sub gününtarihi() Dim sFileName As String sFileName = Format(Now, ""dd_mm_yyyy"") + "".xls"" ActiveWorkbook.SaveAs sFileName  " "Sub Kayıtİsmi() ActiveWorkbook.SaveAs Filename:=""C:\Mahmut.xls""  " "Sub kayıt() ActiveWorkbook.Save  " "Sub Dialog_27() Application.Dialogs(xlDialogFileSharing).Show " "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 " "Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.DisplayAlerts = False ActiveWorkbook.Save " "Sub PrintAll() ThisWorkbook.PrintOut " "Sub SaveNow() SaveWithBackup ThisWorkbook.Save  Sub SaveWithBackup() On Error Resume Next Dim Proceed As Long Proceed = MsgBox(""Yedekleyip kaydetmek istiyor musunuz?"" & vbNewLine & _ ""Selecting No will save without Backup"", vbYesNo) If Proceed = vbYes Then Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.FullName, CreateBackup:=True Application.DisplayAlerts = True End If " "Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Not Application.Intersect(Target, Range(""A1:A100"")) Is Nothing Then Cells(ActiveCell.Row, 2).Select MsgBox ""Bu aralıktaki hücreler seçilemez!"" End If " "Sub BosSatirlariSil() Dim LastRow As Long, r As Long LastRow = ActiveSheet.UsedRange.Rows.Count LastRow = LastRow + ActiveSheet.UsedRange.Row  1 Application.ScreenUpdating = False For r = LastRow To 1 Step 1 If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete Next r " "Sub sayfayıkoru() ActiveSheet.Protect userinterfaceonly:=True ActiveSheet.EnableAutoFilter = True " "Sub auto_open() Static sayac As Integer Do If sayac = 3 Then ThisWorkbook.Close False Else If InputBox(""Şifreyi girin"") = ""Buraya koymak istediğiniz şifreyi yazacaksınız!"" Then GoTo devam Else sayac = sayac + 1 End If End If Loop devam: " "Sub kapat() ActiveWorkbook.Close " "Aşağıdaki kod, çalışma kitabında Sheet1 isimli sayfa modulunun Name özelliğini MySh olarak değiştirir. visual basic kodu:  Sub Test() Dim MyMod As Object For Each MyMod In ThisWorkbook.VBProject.VBComponents  If MyMod.Name = ""Sheet1"" Then MyMod.Name = ""MySh"" Next " "Açıklama:Çalışma Kitabınızın Başlığını istediğiniz şekilde değiştirin Sub test() Application.Caption = ""pir"" ActiveWindow.Caption = ""excel.web.tr"" 'Incorrect MsgBox Application.Caption & "" "" & ActiveWindow.Caption 'Correct MsgBox Application.Caption " "Sub gızle() For i = 1 To ActiveWorkbook.Sheets.Count Sheets(i).Select ActiveWindow.DisplayHeadings = False Next  göstermesi için: Sub goster() For i = 1 To ActiveWorkbook.Sheets.Count Sheets(i).Select ActiveWindow.DisplayHeadings = true Next  " "Sub SayfaKaydet()  Dim sayfa As Worksheet  For Each sayfa In Worksheets  sayfa.Copy ActiveWorkbook.SaveAs ""C:\Documents and Settings\pir\Desktop\"" & sayfa.Name & "".xls""  ActiveWorkbook.Close False Next sayfa " "Module bölümüne; Global WCnt Global Sh(1 To 100) As Worksheet Global ShNames(1 To 100) As String 'workbooka; Public Sub Workbook_Open() Dim i As Integer WCnt = Worksheets.Count For i = 1 To WCnt ShNames(i) = Sheets(i).Name Set Sh(i) = Sheets(ShNames(i)) Next i  Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim z As Integer For z = 1 To WCnt Sh(z).Name = ShNames(z) Next z " "Çalışma Sayfanızdaki Boş Satırları Siler Sub BosSatirlariSil() Dim LastRow As Long, r As Long LastRow = ActiveSheet.UsedRange.Rows.Count LastRow = LastRow + ActiveSheet.UsedRange.Row  1 Application.ScreenUpdating = False For r = LastRow To 1 Step 1 If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete Next r  " "Açıklama: Çalışma sayfanızdaki çalışma alanınızı belirleyen ve iptal eden macrolar. Kod: Sub LimiteDefilement() ActiveSheet.ScrollArea = ""A1:A10""   Sub RetablitDefilement() ActiveSheet.ScrollArea = """"  " "Açıklama: Çalışma sayfanızdaki hücrenin değerlerine göre hücreler renklerle dolar Kod:  Private Sub Worksheet_Change(ByVal Target As Range)  Select Case Target  Case "" "": Target.Interior.ColorIndex = 15 ' gri  Case ""A"": Target.Interior.ColorIndex = 3 ' kırmızı  Case ""B"": Target.Interior.ColorIndex = 3  Case ""A&B"": Target.Interior.ColorIndex = 3  Case """": Target.Interior.ColorIndex = 4 ' yeşil  Case Else: Target.Interior.ColorIndex = xlNone  End Select   " "Açıklama: Çalışma Sayfanızı korur ancak otomatik süzler çalışır  Kod: Sub sayfayıkoru()  ActiveSheet.Protect userinterfaceonly:=True ActiveSheet.EnableAutoFilter = True   " "ÇALIŞMA SAYFASINI KORUMAYA ALIR Sub sayfayıkoru() ActiveSheet.Protect userinterfaceonly:=True ActiveSheet.EnableAutoFilter = True  " "Aşağıdaki makroyu bir butona bağlarsanız taramanıza gerek kalmadan gizleme yapabilirsiniz.  Sub gizle() Columns(""K:IV"").Hidden = True Rows(""45:65536"").Hidden = True   tekrar göstermek için ise  Sub göster() Columns(""K:IV"").Hidden = False Rows(""45:65536"").Hidden = False  " "Private Sub CommandButton1_Click() If CommandButton1.Caption = ""Çalıştır"" Then CommandButton1.Caption = ""Sorgu Gir"" CommandButton1.Font.Bold = True CommandButton1.Font.Size = 15 Else CommandButton1.Caption = ""Çalıştır"" CommandButton1.Font.Bold = False CommandButton1.Font.Size = 20 End If  Private Sub UserForm_Initialize() CommandButton1.Caption = ""Sorgu Gir"" " MsgBox "Mesaj boxlarda satır başı yapamıyorum." & vbCrlf & "Bunun bir yolu olmalı !" & vbCrlf & "Acaba vbCrlf kullanırsam ne olur?", vbinformation "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) " "Sub msg() MsgBox ""A"" & Chr(13) & ""B"" & Chr(13) & ""C"" & Chr(13) & ""D"" & Chr(13) " "Option Explicit Sub AusEin() Dim S As Integer For S = 2 To Worksheets.Count Worksheets(S).Visible = Not Worksheets(S).Visible Next " "Private Sub Worksheet_Change(ByVal Target As Excel.Range)  ActiveSheet.Protect ""abc"" " "Private Sub Worksheet_Change(ByVal Target As Excel.Range) Target.NoteText ""Die Zelle wurde am "" & Format(Date, ""dd.mm.yy"") & "" um "" & Format(Now(), "" hh:mm:ss"") & "" durch "" & ActiveWorkbook.BuiltinDocumentProperties(7).Value & "" geändert."" " "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) sayfa = Target.Cells.Value Sheets(""sayfa3"").Select " "Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) ActiveCell = Date & "", "" & Time " "Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink) ' MsgBox ""destination: target.subaddress "" & Target.SubAddress ' MsgBox ""Source: Target.Range.Address "" & Target.Range.Address ' MsgBox ""Source: Target.Range.Value "" & Target.Range(1, 1).Value Range(Target.SubAddress) = Target.ActiveCell   Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Cancel = True 'Get out of edit mode ActiveCell = Target.Text On Error Resume Next ActiveCell.AddComment On Error GoTo 0 ActiveCell.Comment.Visible = False ActiveCell.Comment.Text Text:=""Value from: "" & Target.Address(0, 0) _ & Chr(10) & Format(Now, ""ddmmmyyyy hh:mm:ss"") Cancel = True ' no further need to edit the cell  " "Sub çift_kayıtlari_arala() totalrows = ActiveSheet.UsedRange.Rows.Count For Row = totalrows To 2 Step 1 If Cells(Row, 1).Value <> Cells(Row  1, 1).Value Then Rows(Row).Insert Next Row  " "kullanici = Application.UserName saat = Format(Now, ""hh:mm:ss"") tarih = Format(Date, ""d mmmm yyyy dddd"") sor = MsgBox("" GÖRÜŞMEK ÜZERE "" & kullanici & Chr(10) & Chr(10) & _ ""WWW.XXX.COM / +90 312 111 11 11"" & Chr(10) & Chr(10) & _ ""Tarih : "" & tarih & Chr(10) & Chr(10) _ & ""Saat : "" & saat & Chr(10) & Chr(10) _ & ""XXX A.Ş. İyi Çalışmalar Diler."" & Chr(10) & Chr(10) & _ ""dosyanın kaydedilmesini istiyormusunuz?"", 4, """") If sor = vbYes Then ActiveWorkbook.Save ActiveWorkbook.Close Else Application.DisplayAlerts = False ActiveWorkbook.Close End If " "Private Sub Command1_Click() pir = MsgBox(""Çıkmak istediğinizden emin misiniz?"", vbQuestion + vbYesNo, ""Çıkış"") Select Case pir Case vbYes End End Select " "Aşağıdaki kodu sayfanın kod sayfasına kopyalayarak deneyin.  visual basic kodu: Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Intersect(Target, [a:a]) Is Nothing Then Exit Sub say = WorksheetFunction.CountIf(Range(""a1:a"" & Target.Row  1), Target) If say > 0 Then MsgBox ""BU KAYIT MEVCUTTUR"" Target.Select Target = """" End If " "Aşağıdaki kod sadece a sütunu için geçerli, buna birde e sütununu nasıl eklerim? Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, [a:a]) Is Nothing Or Target = 0 Then Exit Sub UserForm1.Show  Kodu aşağıdaki gibi düzenleyin.  visual basic kodu: Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 Or Target.Column = 5 Then say = WorksheetFunction.CountIf([m:m], Target) If say > 0 Then Exit Sub UserForm1.Show End If  " "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If ListBox1.ListIndex = 1 Then Exit Sub cevap = MsgBox(ListBox1.List(, 0) & "" nolu kaydı silmek istiyor musunuz?"", vbYesNo) If cevap = vbYes Then Range(Cells(ListBox1.List(, 0) + 1, 2), Cells(ListBox1.List(, 0) + 1, 6)).Delete shift:=xlUp [a65536].End(3).Delete shift:=xlUp Call UserForm_Activate End If " "Hücreye Maus veya Tuşlarla Geldiğinide İstenilen sayfaya geçmesi için,bu kodları O sayfanın üzerinde sağ tuş ile Kod Görüntüle kısmına yazılacak.Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = ""$C$18"" Then Sheets(""Sayfa2"").Select   " "Hücreye Maus veya Tuşlarla Geldiğinide İstenilen sayfaya geçmesi için,bu kodları O sayfanın üzerinde sağ tuş ile Kod Görüntüle kısmına yazılacak. Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = ""$C$18"" Then Sheets(""Sayfa2"").Select  " "Declare Function GetClipCursor Lib ""user32"" (lprc As RECT) As Long Type RECT gauche As Long haut As Long droit As Long bas As Long End Type Dim oGCC As RECT Sub dimEcran() GetClipCursor oGCC With oGCC  MsgBox .droit & "" x "" & .bas End With " "Declare Function GetSystemMetrics32 Lib ""User32"" _ Alias ""GetSystemMetrics"" (ByVal nIndex As Long) As Long Sub DisplayMonitorInfo() Dim w As Long, h As Long w = GetSystemMetrics32(0) ' width in points h = GetSystemMetrics32(1) ' height in points MsgBox Format(w, ""#,##0"") & "" x "" & Format(h, ""#,##0""), _ vbInformation, ""Monitor Size (width x height)"" " "Declare Function GetSystemMetrics Lib ""user32"" (ByVal nIndex As Long) As Long  Sub Bild() MsgBox (""Çözünürlük Pixel Değerleri: "" & GetSystemMetrics(0) & "" x "" & GetSystemMetrics(1)) " "Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim iOffset As Integer On Error GoTo err_handler Application.EnableEvents = False If Not Application.Intersect(Target, Columns(""D:E"")) Is Nothing Then If Target.Column = 4 Then iOffset = 3 Else iOffset = 2 End If If IsEmpty(Target.Value) Then With Target .Font.Name = ""Wingdings"" .Value = Chr(252) End With Target.Offset(0, iOffset).Select Else Target.Value = """" Target.Offset(0, iOffset).Select End If End If err_handler: Application.EnableEvents = True " "Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Range) Zelle = Target.Address Select Case Zelle Case ""$D$2"" Range(""$D$2"").ColumnWidth = 52 'entspricht 369 Pixel Case Else Range(""$D$2"").ColumnWidth = 16.43 'entspricht 120 Pixel End Select " " Excel içinde bir sayfaya şifre verdikten sonra bu şifreyi unuttuysanız aşağıdaki kodu uygulayıp bu sorunu çözebilirsiniz.  Kod: Sub SifreAc() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66 For j = 65 To 66 For k = 65 To 66 For l = 65 To 66 For m = 65 To 66 For i1 = 65 To 66 For i2 = 65 To 66 For i3 = 65 To 66 For i4 = 65 To 66 For i5 = 65 To 66 For i6 = 65 To 66 For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) _ & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox ""One usable password is "" & Chr(i) & Chr(j) _ & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) _ & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next Next Next Next Next Next Next Next Next Next Next Next " "Dim dbs2 as Database Dim rst2 as Recordset Set dbs2 = OpenDatabase(datayolu) Set rst2 = dbs2.OpenRecordset(""Select  from cr Where tarih>=datevalue('"" & trh1.Value & ""') and tarih<=datevalue('"" & trh2.Value & ""')1 and crkod='"" & Text1 & ""'order by tarih"") If rst2.RecordCount > 0 Then rst2.MoveLast rst2.MoveFirst i = 1 fg5.Rows = rst2.RecordCount + 1 While Not rst2.EOF If Not IsNull(rst2(""tutar"")) Then fg5.TextMatrix(i, 2) = rst2(""tutar"") i = i + 1 rst2.MoveNext Wend End If " "Sub data_form() ActiveWorkbook.Names.Add Name:=""Database"", RefersTo:=""="" & Worksheets(1).Name & ""!"" & Range(""A15:F35"").Address Range(""A1:F11"").Select Worksheets(1).ShowDataForm " "Private Sub Workbook_Open() Sheets(""Sayfa1"").Select ActiveSheet.ShowDataForm " "Public Function DecControl(KeyAscii As Integer, Text As TextBox, ByVal NOOFDEC As Integer) As Integer If KeyAscii = 8 Then DecControl = KeyAscii Exit Function End If If NOOFDEC = 0 Then If InStr(1, ""0123456789"", Chr(KeyAscii)) = 0 Then  DecControl = 0  Exit Function Else  DecControl = KeyAscii  Exit Function End If Else If InStr(1, ""0123456789."", Chr(KeyAscii)) = 0 Then  DecControl = 0  Exit Function End If End If If Len(Text)  Text.SelStart > NOOFDEC And Chr(KeyAscii) = ""."" Then DecControl = 0 Exit Function End If If KeyAscii <> 8 Then If InStr(1, Text, ""."") <> 0 And Chr(KeyAscii) = ""."" Then DecControl = 0 Exit Function End If Dim pos As Integer Dim RET As Integer pos = InStr(1, Text.Text, ""."") If pos = 0 Then If InStr(1, ""0123456789."", Chr(KeyAscii)) = 0 Then  RET = 0 Else  RET = KeyAscii End If Else 'IF AFTER DECIMAL If Text.SelStart + 1 > pos Then  a = Len(Text.Text)  InStr(1, Text, ""."")  If a >= NOOFDEC Then RET = 0  Else RET = KeyAscii  End If Else  RET = KeyAscii End If End If Else RET = KeyAscii End If DecControl = RET " "Private Sub Worksheet_SelectionChange(ByVal Target As Range)  Dim i As Long  For i = 1 To WorksheetFunction.CountA(Range(""H:H"")) If Cells(i, 8).Value = ""A"" And Left(Cells(i, 9), 3) <> ""()"" Then Cells(i, 9) = ""()"" & Cells(i, 9).Value Cells(i, 9).HorizontalAlignment = xlRight End If  Next i " "Sub aynideger() Dim Cel1 As Range, Cel2 As Range Set Cel1 = Range(""A1:B1"") Set Cel2 = Workbooks(""Kitap1"").Worksheets(""Sayfa1"").Range(""D5"") Cel1.Copy Cel2 " "aşağıda bu çalışmayı gerçekleştirecek kodu ekliyorum. Bu kodu bir module içerisine değil Alt+F11 ile VBAyı açın. Project Explorerden ""This Workbook"" üzerine çift tıklayın ve kodu bu açılan sayfaya kopyalayın. Normal module sayfasına eklerseniz çalışmaz. Deneme sonrası sonucu bildirirseniz memnun olurum. Sonuca farklı şekilde giden arkadaşlar kodlarını paylaşırsa sevinirim. Kod: Private Sub yaz(deger, adres, yenideger) If deger = 0 Then yuzde = 1 ElseIf IsNumeric(deger) And IsNumeric(yenideger) Then yuzde = (deger  yenideger) / deger yuzde = yuzde  100  (1) yuzde = FormatNumber(yuzde, 2) End If If deger < 1 Then deger = 0 Range(adres).ClearComments Range(adres).AddComment "" "" Range(adres).Comment.Visible = False Range(adres).Comment.Text Text:=""Eski Değer: "" & deger & Chr(10) & ""Değişim: %"" & yuzde   Public Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) adres = Range(""IV1"").Value deger = Range(""IV2"").Value If adres > 0 Then yenideger = Range(adres).Value If deger <> yenideger Then Call yaz(deger, adres, yenideger) End If End If Range(""IV1"").Value = ActiveCell.Address Range(""IV2"").Value = ActiveCell.Value " "Project Explorerden ""This Workbook"" üzerine çift tıklayın ve kodu bu açılan sayfaya kopyalayın.  'Normal module sayfasına eklerseniz çalışmaz.  Private Sub yaz(deger, adres, yenideger) If deger = 0 Then yuzde = 1 ElseIf IsNumeric(deger) And IsNumeric(yenideger) Then yuzde = (deger  yenideger) / deger yuzde = yuzde  100  (1) yuzde = FormatNumber(yuzde, 2) End If  If deger < 1 Then deger = 0  Range(adres).ClearComments  Range(adres).AddComment "" ""  Range(adres).Comment.Visible = False  Range(adres).Comment.Text Text:=""Eski Değer: "" & deger & Chr(10) & ""Değişim: %"" & yuzde  Public Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) adres = Range(""IV1"").Value deger = Range(""IV2"").Value If adres > 0 Then yenideger = Range(adres).Value If deger <> yenideger Then Call yaz(deger, adres, yenideger) End If End If Range(""IV1"").Value = ActiveCell.Address Range(""IV2"").Value = ActiveCell.Value  " "Sub kopyala() Dim pir1 As Range, pir2 As Range Set pir1 = Range(""A1:B2"") Set pir2 = Range(""F1:G2"") pir2.Value = pir1.Value pir2.NumberFormat = pir1.NumberFormat " "Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Me.Cells(Target.Row, 1) = Now '1 steht für Spalte A, für Spalte H waere es die 8 Application.EnableEvents = True " "Sub Accumulate() Dim n As Integer Dim t As Integer For n = 1 To 10  t = t + n Next n MsgBox "" The total is "" & t " "Sub a() b = WorksheetFunction.Sum(Sheets(""sayfa1"").Range(""A1:A50""))   'bu kodda b değişkenine A1:A50 arasındaki değerlerin toplamı atanmıştır." "Sub Dialog_34() Application.Dialogs(xlDialogFormulaReplace).Show " "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 2 Then  Application.OnKey ""{Del}"", """" Else Application.OnKey ""{Del}"" End If " "Sub demo() Dim saat1 As Date Dim saat2 As Date saat1 = ""15/10/2005"" saat2 = Date If saat2 > saat1 Then  MsgBox (""Süreniz dolmuş üzgünüm."")  ActiveWorkbook.Close End If MsgBox (""Kullanım için "" & saat1  saat2 & "" gününüz kalmıştır."") If sure1 = sure2 Then MsgBox ""Bu gün SON GÜN"" End If " "1 ADET COMBO '1 ADET COMMAND '4 ADET TEXT '5 ADET LABEL Private Sub Command1_Click() Label5.Caption = (Val(Text1) + Val(Text2) + Val(Text3) + Val(Text4)) / 4  Private Sub UserForm_Activate() Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ""  Private Sub Text1_Change() If Val(Text1) > 100 Or 0 > Val(Text1) Then MsgBox ""GİRDİĞİNİZ SAYI 0 İLE 100 ARASI OLMALIDIR"" Text1.Text = """" End If  Private Sub Text2_Change() If Val(Text2) > 100 Or Val(Text2) < 0 Then MsgBox ""GİRDİĞİNİZ SAYI 0 İLE 100 ARASI OLMALIDIR"" Text2.Text = """" End If  Private Sub Text3_Change() If Val(Text3) > 100 Or 0 > Val(Text3) Then MsgBox ""GİRDİĞİNİZ SAYI 0 İLE 100 ARASI OLMALIDIR"" Text3.Text = """" End If  Private Sub Text4_Change() If Val(Text4) > 100 Or 0 > Val(Text4) Then MsgBox ""GİRDİĞİNİZ SAYI 0 İLE 100 ARASI OLMALIDIR"" Text4.Text = """" End If " "Private Sub yaz(deger, adres, yenideger) If deger = 0 Then yuzde = 1 ElseIf IsNumeric(deger) And IsNumeric(yenideger) Then yuzde = (deger  yenideger) / deger yuzde = yuzde  100  (1) yuzde = FormatNumber(yuzde, 2) End If  If deger < 1 Then deger = 0  Range(adres).ClearComments  Range(adres).AddComment "" ""  Range(adres).Comment.Visible = False  Range(adres).Comment.Text Text:=""Eski Değer: "" & deger & Chr(10) & ""Değişim: %"" & yuzde   Public Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) adres = Range(""IV1"").Value deger = Range(""IV2"").Value If adres > 0 Then yenideger = Range(adres).Value If deger <> yenideger Then Call yaz(deger, adres, yenideger) End If End If Range(""IV1"").Value = ActiveCell.Address Range(""IV2"").Value = ActiveCell.Value " "Sub Auto_Open() Application.StatusBar = "" LİDER GROUP ©2005 /  MALİYET ANALİZ LİSTELERİ "" Sheets(""ANA SAYFA"").Select Range(""A1"").Select  Dim kullanici As String Dim tarih As String Dim saat As String tarih = Now() kullanici = Application.UserName saat = Format(tarih, ""hh:mm:ss"") tarih = Format(tarih, ""d mmmm yyyy dddd"") MsgBox "" MERHABA "" & kullanici & "", HOŞ GELDİNİZ!"" & Chr(13) & Chr(13) & _ ""Tarih : "" & tarih & Chr(13) & Chr(13) _ & ""Saat : "" & saat & Chr(13) & Chr(13) _ & ""Kalite Yönetim Müdürlüğü İyi Çalışmalar Diler."" & Chr(13) & Chr(13), vbApplicationModal, "" LİDER GROUP 2005® ""  Sub Auto_Close() Dim kullanici As String Dim tarih As String Dim saat As String tarih = Now() kullanici = Application.UserName saat = Format(tarih, ""hh:mm:ss"") tarih = Format(tarih, ""d mmmm yyyy dddd"") MsgBox "" GÖRÜŞMEK ÜZERE "" & kullanici & Chr(13) & Chr(13) & _ ""Tarih : "" & tarih & Chr(13) & Chr(13) _ & ""Saat : "" & saat & Chr(13) & Chr(13) _ & ""Kalite Yönetim Müdürlüğü İyi Çalışmalar Diler."" & Chr(13) & Chr(13), vbApplicationModal, "" LİDER GROUP  2005® "" ActiveWorkbook.Save Application.DisplayAlerts = False ActiveWorkbook.Close False Application.Quit " "üzerindeki bir makinedeki bir excel kitabının içindeki makroyu kendi makinenizden çalıştırmak  Kod: Application.Run ""\\makineadi\klasoradi\kitapadi.xls!makroadi"" eğer kitaplar aynı makine üzerinde ise Kod: Application.Run ""c:\klasoradi\kitapadi.xls!makroadi"" " "Sub Essai() Run (""Kitap1.xls!Module1.MAkro1"") " "Form2 VBA  Public Sub Buton1_Click() Msgbox ""Merhaba""  'Form1 VBA 'da Private Sub Buton1_Click() userform2.buton1_click  " Application.Run "kitap2.xls!makro1" "Sub dortgen_sil() For Each Rectangle In ActiveSheet.Shapes Rectangle.Delete Next " "Declare Function SetVolumeLabel Lib ""kernel32"" Alias ""SetVolumeLabelA"" _ (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long Sub NommeDSK() retval = SetVolumeLabel(""a:\"", ""MaDisquette"") 'pour supprimer le label 'retval = SetVolumeLabel(""a:\"", vbNullString) " "Private Declare Function SHFormatDrive Lib ""shell32"" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long Private Declare Function FindWindow Lib ""user32"" Alias ""FindWindowA"" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private hWnd As Long Const SHFMT_DRV_A = 0 Const SHFMT_DRV_B = 1 Const SHFMT_ID_DEFAULT = &HFFFF Const SHFMT_OPT_QUICKFORMAT = 0 Const SHFMT_OPT_FULLFORMAT = 1 Const SHFMT_OPT_SYSONLY = 2 Const SHFMT_ERROR = 1 Const SHFMT_CANCEL = 2 Const SHFMT_NOFORMAT = 3 Private Sub format() Dim Res As Long  hWnd = FindWindow(vbNullString, Me.Caption)  Res = SHFormatDrive(hWnd, SHFMT_DRV_A, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT)  Select Case Res Case SHFMT_ERROR MsgBox ""Hata."", vbCritical Case SHFMT_CANCEL MsgBox ""İptal edildi."", vbInformation Case SHFMT_NOFORMAT MsgBox ""Formatlı değil."", vbInformation Case Else MsgBox ""Formatlama bitti."" End Select   Private Sub CommandButton1_Click() format " "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 " "Option Explicit '//The Shell function runs other programs asynchronously so what '//What you basically have to do is Open the existing Process '//for the running Application and, LOOP & WAIT for the processes return state '//ie when the specified process is in the signaled state '//or a timeout occurs. Private Declare Function OpenProcess Lib ""kernel32"" ( _ ByVal dwDesiredAccess As Long, _ ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) As Long  Private Declare Function WaitForSingleObject Lib ""kernel32"" ( _ ByVal hHandle As Long, _ ByVal dwMilliseconds As Long) As Long Private Declare Function CloseHandle Lib ""kernel32"" ( _ ByVal hObject As Long) As Long Private Declare Function GetExitCodeProcess Lib ""kernel32"" ( _ ByVal hProcess As Long, _ lpExitCode As Long) As Long '&HFFFF Private Const SYNCHRONIZE = &H100000 '// Note:SYNCHRONIZE Windows NT/2000 Private Const INFINITE = &HFFFF 'OR 1& '// INFINITE, the function’s timeout interval never elapses. Private Const STILL_ACTIVE = &H103 Public Function ShellAndWait(ByVal BatFile As String) ' ' Shells a new process and waits for it to complete. ' Calling application is totally nonresponsive while ' new process executes. ' Dim PID As Long Dim hProcess As Long Dim nRet As Long '// Unlike other Functions Shell generates an error '// instead of returning a 0 so handling the error '// = Application NOT started. On Error Resume Next PID = Shell(BatFile, vbMinimizedNoFocus) If Err Then '// handle the error here and End MsgBox ""Could NOT exercute:= "" & BatFile End End If On Error GoTo 0 '// SYNCHRONIZE For Windows NT/2000: '// Enables using the process handle in any of the wait '// functions to wait for the process to terminate. '// obviously with NT you need access rights. hProcess = OpenProcess(SYNCHRONIZE, False, PID) '// Just set the dwMilliseconds to INFINITE to initiate a Loop nRet = WaitForSingleObject(hProcess, INFINITE) Do GetExitCodeProcess hProcess, nRet DoEvents Loop While nRet = STILL_ACTIVE CloseHandle hProcess  Sub OpenFileAndWait() Dim sApp As String '// Define the Application FullPath here sApp = ""C:\A\Batch.bat"" 'sApp = ""C:\windows\system32\calc.exe"" '// Lets DoIt ShellAndWait sApp '// Tell me if Successful MsgBox ""Finished running task!"" " "Sub polygon() 'zeichnet Polygon Application.ScreenUpdating = False anzeck = InputBox(""Wieviele Ecken ?"") If anzeck = Empty Or Not IsNumeric(anzeck) Or anzeck < 3 Then Exit Sub seite = InputBox(""Seitenlänge ?"") If seite = Empty Or Not IsNumeric(seite) Then Exit Sub a = 200 ActiveSheet.Drawings.Add(a, a, a + seite, a, False) _  .Select winkel = 180  360 / anzeck gegenwinkel = 180  (winkel + 90) winkel1 = 3.14159265358979  winkel / 180 gegenwinkel1 = 3.14159265358979  gegenwinkel / 180 x = a + seite y = a k = 1 For i = 1 To anzeck  1 x = x  k  seite  Sin(gegenwinkel1) y = y + k  seite  Cos(gegenwinkel1) Selection.AddVertex x, y k = k  (1) gegenwinkel1 = gegenwinkel1  winkel1 Next Application.ScreenUpdating = True " "Sub sec() Worksheets(Array(1, 3, 5)).Select " "Sub Dizindeki_Son_İsim() Dim ds, a Set ds = CreateObject(""Scripting.FileSystemObject"") a = ds.GetBaseName(""C:\SXSİ\Deneme\Ben.txt"") MsgBox a " "Sub Sürücü_İsmi() Dim ds, a Set ds = CreateObject(""Scripting.FileSystemObject"") a = ds.GetDriveName(""C:\SXSİ\Deneme\Ben.txt"") MsgBox a " "Dim d_tarih Do d_tarih = InputBox(""Doğum Tarihiniz Ör:01/04/1979"", ""Doğum Tarihinizi Yazın Lütfen"") Loop While Not IsDate(d_tarih) MsgBox (WeekdayName(Weekday(d_tarih, 0), False, 0) + "" "" + ""Günü Doğmuşsunuz."")" "Function DollarText(vNumber) As Variant 'see also Function SpellNumber(ByVal MyNumber), PSS ID Number: Q140704 Dim sDollars As String Dim sCents As String Dim iLen As Integer Dim sTemp As String Dim iPos As Integer Dim iHundreds As Integer Dim iTens As Integer Dim iOnes As Integer Dim sUnits(2 To 5) As String Dim bHit As Boolean Dim vOnes As Variant Dim vTeens As Variant Dim vTens As Variant If Not IsNumeric(vNumber) Then Exit Function End If sDollars = Format(vNumber, ""###0.00"") iLen = Len(sDollars)  3 If iLen > 15 Then DollarText = CVErr(xlErrNum) Exit Function End If sCents = Right$(sDollars, 2) & ""/100 Dollars"" If vNumber < 1 Then DollarText = sCents Exit Function End If sDollars = Left$(sDollars, iLen) vOnes = Array("""", ""One"", ""Two"", ""Three"", ""Four"", ""Five"", _ ""Six"", ""Seven"", ""Eight"", ""Nine"") vTeens = Array(""Ten"", ""Eleven"", ""Twelve"", ""Thirteen"", ""Fourteen"", _ ""Fifteen"", ""Sixteen"", ""Seventeen"", ""Eighteen"", ""Nineteen"") vTens = Array("""", """", ""Twenty"", ""Thirty"", ""Forty"", ""Fifty"", _ ""Sixty"", ""Seventy"", ""Eighty"", ""Ninety"") sUnits(2) = ""Thousand"" sUnits(3) = ""Million"" sUnits(4) = ""Billion"" sUnits(5) = ""Trillion"" sTemp = """" For iPos = 15 To 3 Step 3 If iLen >= iPos  2 Then bHit = False If iLen >= iPos Then iHundreds = Asc(Mid$(sDollars, iLen  iPos + 1, 1))  48 If iHundreds > 0 Then sTemp = sTemp & "" "" & vOnes(iHundreds) & "" Hundred"" bHit = True End If End If iTens = 0 iOnes = 0 If iLen >= iPos  1 Then iTens = Asc(Mid$(sDollars, iLen  iPos + 2, 1))  48 End If If iLen >= iPos  2 Then iOnes = Asc(Mid$(sDollars, iLen  iPos + 3, 1))  48 End If If iTens = 1 Then sTemp = sTemp & "" "" & vTeens(iOnes) bHit = True Else If iTens >= 2 Then sTemp = sTemp & "" "" & vTens(iTens) bHit = True End If If iOnes > 0 Then If iTens >= 2 Then sTemp = sTemp & """" Else sTemp = sTemp & "" "" End If sTemp = sTemp & vOnes(iOnes) bHit = True End If End If If bHit And iPos > 3 Then sTemp = sTemp & "" "" & sUnits(iPos \ 3) End If End If Next iPos DollarText = Trim(sTemp) & "" and "" & sCents  'DollarText" "aktif sayfaya açılır kutu ekleyin. Referansını A sütununa verin. A sütunundakileri dolaylı olarak b14 te gösterir  Sub yaz() ActiveSheet.Shapes(""Drop Down 1"").Select [b14] = Evaluate(""=INDIRECT(""""A"" & Selection.Value & "" & "")"") [b13].Select " "Sub doluyazdir() ActiveSheet.UsedRange.Select Selection.PrintOut " "Sub doluhucre_sec() Dim range As range Sheets(""Sayfa1"").Activate ActiveSheet.UsedRange.Select For Each range In Selection If range.HasFormula = False Then range.Value = UCase(range.Value) End If Next " "Sub doluhucre_sec() Dim range As range Sheets(""Sayfa1"").Activate ActiveSheet.UsedRange.Select For Each range In Selection If range.HasFormula = False Then range.Value = LCase(range.Value) End If Next " "Sub DoluKayitSayisi() Sayi = WorksheetFunction.CountA(Range(""A1:A9000"")) 'Eğer mesajla almak isterseniz şu koduda ekleyin MsgBox Sayi " "Private Sub CommandButton1_Click() Dim MyRng As Range Dim NoA1 As Long Set sh1 = Sheets(""Sayfa1"") Set sh2 = Sheets(""Sayfa2"") NoA1 = sh1.Cells(65536, 1).End(xlUp).Row For Each MyRng In sh1.Range(""A1:A"" & NoA1)  NoA2 = sh2.Cells(65536, 1).End(xlUp).Row + 1 If MyRng <> ""m.cinsi"" And MyRng <> """" Then sh2.Range(""A"" & NoA2) = MyRng sh2.Range(""B"" & NoA2) = MyRng.Offset(0, 1) sh2.Range(""C"" & NoA2) = MyRng.Offset(0, 2) sh2.Range(""D"" & NoA2) = MyRng.Offset(0, 3) End If Next " "activesheet.usedrange.select  veya, C2 den başlayarak C sütunundaki son dolu hücreye kadar seçim: range(""c2:c"" & cells(65536, 3).end(xlup).row).select  başka bir yazım şekli de; range(""c2:c"" & range(""c65536"").end(xlup).row).select" "Sub SelAllData() Application.ScreenUpdating = False Dim myLastRow As Long Dim myLastColumn As Long Range(""A1"").Select On Error Resume Next myLastRow = Cells.Find("""", [A1], , , xlByRows, xlPrevious).Row myLastColumn = Cells.Find("""", [A1], , , xlByColumns, xlPrevious).Column myLastCell = Cells(myLastRow, myLastColumn).Address myRange = ""a1:"" & myLastCell Application.ScreenUpdating = True Range(myRange).Select " "Private Sub CommandButton1_Click() Dim say Dim ekle On Error Resume Next For say = 1 To UserForm1.Controls.Count If Mid(Controls(say).Name, 1, 7) = ""TextBox"" Then GoTo ileri Else GoTo gec End If ileri: If Controls(say).Text <> """" Then ekle = ekle + 1 End If gec: Next say MsgBox ekle " "Function LastCell(ws As Worksheet) As Range  Dim LastRow&, LastCol% On Error Resume Next With ws  LastRow& = .Cells.Find(What:="""", _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row  LastCol% = .Cells.Find(What:="""", _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByColumns).Column End With  Set LastCell = ws.Cells(LastRow&, LastCol%)  Sub RealLastCell() RLC = LastCell(ActiveSheet).Address(False, False) MsgBox (""The """"real"""" last cell is..."" & vbCrLf & vbLf & RLC)  Sub Used_Range() ActiveSheet.UsedRange.Select " "Function WorkbookOpen(WorkBookName As String) As Boolean  WorkbookOpen = False  On Error GoTo WorkBookNotOpen  If Len(Application.Workbooks(WorkBookName).Name) > 0 Then WorkbookOpen = True Exit Function  End If WorkBookNotOpen:   Sub AA() If Not WorkbookOpen(""C.xls"") Then  Workbooks.Open ""C.xls"" End If " "Sub auto_open() Sheets(""GİRİŞ"").Select Range(""a1"").Select MsgBox ""GİRİŞ Sayfasındaki gerekli bilgileri doldurun ""  'ThisWorkbook'a açıklama ekler(kitap açıldığında otomatik devreye girer. Private Sub Workbook_Open() Call MsgBox(""Programlayan : Mahmut BAYRAM"" & vbNewLine & vbNewLine & _ ""Sonuçları kontrol etmeyi unutmayın!"" & vbNewLine & vbNewLine & _ ""sayfaları kopyalayabilirsiniz. "", vbInformation, ""UYARI"") " "Sub auto_open() Sheets(""GİRİŞ"").Select Range(""a1"").Select MsgBox ""GİRİŞ Sayfasındaki gerekli bilgileri doldurun ""  'ThisWorkbook'a açıklama ekler(kitap açıldığında otomatik devreye girer. Private Sub Workbook_Open() Call MsgBox(""Programlayan : pir."" & vbNewLine & vbNewLine & _ ""Sonuçları kontrol etmeyi unutmayın!"" & vbNewLine & vbNewLine & _ ""sayfaları kopyalayabilirsiniz. "", vbInformation, ""UYARI"") " "Sub DateiAuswahl() Dim WB As Workbook Dim TB As Worksheet Dim i% Dim dName Dim dFilter$ dFilter = ""ExcelDateien(.xls), .xls"" ChDrive ""c"" ChDir ""c:\"" dName = Application.GetOpenFilename(dFilter) If dName = False Then Exit Sub Set WB = Workbooks.Open(dName) Set TB = WB.Worksheets(1) For i = 1 To 20  TB.Cells(i, 5) = ""Spalte E  Zeile "" & i Next i " "UYARI: Aşağıdaki işlevlerin sonuç verebilmesi için çalışma kitabının kaydedilmiş olması gerekmektedir. Çalışma kitabının tam yolunu, adını ve çalışma sayfası adını birlikte yazdırmak için; =HÜCRE(""DosyaAdı"") Çalışma kitabının yolunu yazdırmak için; =SOLDAN(HÜCRE(""DosyaAdı"");BUL(""["";HÜCRE(""DosyaAdı"");1)1) Çalışma kitabı adını dosya uzantısı ile birlikte yazdırmak için; =PARÇAAL(HÜCRE(""DosyaAdı"");MBUL(""["";HÜCRE(""DosyaAdı"");1)+1;MBUL(""]"";HÜCRE(""DosyaAdı"");1)MBUL(""["";HÜCRE(""DosyaAdı""))1) Çalışma kitabı adını dosya uzantısı olmaksızın yazdırmak için; =PARÇAAL(HÜCRE(""DosyaAdı"");MBUL(""["";HÜCRE(""DosyaAdı"");1)+1;MBUL(""]"";HÜCRE(""DosyaAdı"");1)MBUL(""["";HÜCRE(""DosyaAdı""))5) Çalışma sayfası adını yazdırmak için; =SAĞDAN(HÜCRE(""DosyaAdı"");UZUNLUK(HÜCRE(""DosyaAdı""))MBUL(""]"";HÜCRE(""DosyaAdı"");1))" "Tek başına bir işe yaramayan bir kod. Adı geçen dosya ismi hafızada tutuluyor ve işlemler bu dosya üzerinden yapılıyor. Örnekler ikinci bölümde 'verilecektir. Sub Dosya_Al() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") Set f = ds.GetFile(""D:\ExcelÖrnekleri\Soru.xls"") MsgBox f  'Bu kodda ise dosya değil,sadece ismi alınıyor. Sub Dosya_İsmi_Al() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") f = ds.GetFileName(""D:\ExcelÖrnekleri\Soru.xls"") 'Sadece Dosya ismi alındığı için SET tabiri kullanılmaz MsgBox f " "Sub ProcessBooks() Dim wkbk As Workbook Dim i As Long With Application.FileSearch .NewSearch .LookIn = ""C:\My Documents"" .SearchSubFolders = False .FileName = "".xls"" .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then " "Sub dosya_ara() Dim ds, a Set ds = CreateObject(""Scripting.FileSystemObject"") a = ds.FileExists(""C:\testfile.txt"") If a = True Then MsgBox ""Bu isimde bir dosya var"" Else MsgBox ""Bu isimde bir dosya yok"" End If " "Diskteki istediğiniz dosyaları (alt klasörler dahil) nasıl bulacağınız ve bir comboda nasıl listeleyeceğiniz yazıyor. 'Bir forma btnara ismli bir düğme ve comsonuc isimli bir combobox yerleştirmeniz yeterli. Private Sub btnara_Click() comsonuc.Clear comsonuc.Refresh Dim arama As Object Dim aradosya As Object Set arama = CreateObject(""FileSearch.Search"") Call arama.SearchFiles(""d:\"", "".mp3"", True) Call arama.SearchFiles(""C:\"", "".xls"", True) DoEvents If arama.Files.Count > 0 Then For Each aradosya In arama.Files comsonuc.AddItem aradosya.FileName Set aradosya = Nothing Next End If Set arama = Nothing comsonuc.text=""ARAMA BİTTİ"" " "Sub Existe() If Dir$(""c:\ajeter\test.xls"") = """" Then MsgBox "" Pas trouvé ce fichier :O("" Else MsgBox "" OK ! Trouvé :O)"" End If " "Sub auto_open() Dim fso, drv, cdr  Set fso = CreateObject(""Scripting.FileSystemObject"") For Each drv In fso.Drives  If drv.driveType = 4 Then Set cdr = drv Next  If cdr.volumename <> ""CD nin adı"" Then  MsgBox ""Lütfen program cd sini takmadan programı çalıştırmayınız""  ThisWorkbook.Close False End If " "Function FileExists(FullFileName As String) As Boolean  FileExists = Len(Dir(FullFileName)) > 0   Sub ss() If Not FileExists(""C:\f.xls"") Then  MsgBox ""Aradığınız dosya belirtilen dizinde yok"" Else  Workbooks.Open ""C:\f.xls"" End If " "Modüle Option Explicit Sub CreateMenu() ' creates a new menu. ' can also be used to create commandbarbuttons ' may be automatically executed from an Auto_Open macro or a Workbook_Open eventmacro Dim cbMenu As CommandBarControl, cbSubMenu As CommandBarControl RemoveMenu ' delete the menu if it already exists ' create a new menu on an existing commandbar (the next 6 lines) Set cbMenu = Application.CommandBars(1).Controls.Add(msoControlPopup, , , , True) With cbMenu  .Caption = ""&My menu""  .Tag = ""MyTag""  .BeginGroup = False End With ' or add to an existing menu (use the next line instead of the previous 6 lines) 'Set cbMenu = Application.CommandBars.FindControl(, 30007) ' Toolsmenu If cbMenu Is Nothing Then Exit Sub ' didn't find the menu... ' add menuitem to menu With cbMenu.Controls.Add(msoControlButton, 1, , , True)  .Caption = ""&Menu Item1""  .OnAction = ThisWorkbook.Name & ""!Macroname"" End With ' add menuitem to menu With cbMenu.Controls.Add(msoControlButton, 1, , , True)  .Caption = ""&Menu Item2""  .OnAction = ThisWorkbook.Name & ""!Macroname"" End With ' add a submenu Set cbSubMenu = cbMenu.Controls.Add(msoControlPopup, 1, , , True) With cbSubMenu  .Caption = ""&Submenu1""  .Tag = ""SubMenu1""  .BeginGroup = True End With ' add menuitem to submenu (or buttons to a commandbar) With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)  .Caption = ""&Submenu Item1""  .OnAction = ThisWorkbook.Name & ""!Macroname""  .Style = msoButtonIconAndCaption  .FaceId = 71  .State = msoButtonDown ' or msoButtonUp End With ' add menuitem to submenu (or buttons to a commandbar) With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)  .Caption = ""&Submenu Item2""  .OnAction = ThisWorkbook.Name & ""!Macroname""  .Style = msoButtonIconAndCaption  .FaceId = 72  .Enabled = False ' or True End With ' add a submenu to the submenu Set cbSubMenu = cbSubMenu.Controls.Add(msoControlPopup, 1, , , True) With cbSubMenu  .Caption = ""&Submenu2""  .Tag = ""SubMenu2""  .BeginGroup = True End With ' add menuitem to submenu submenu With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)  .Caption = ""&Submenu Item1""  .OnAction = ThisWorkbook.Name & ""!Macroname""  .Style = msoButtonIconAndCaption  .FaceId = 71  .State = msoButtonDown ' or msoButtonUp End With ' add menuitem to submenu submenu With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)  .Caption = ""&Submenu Item2""  .OnAction = ThisWorkbook.Name & ""!Macroname""  .Style = msoButtonIconAndCaption  .FaceId = 72  .Enabled = False ' or True End With ' add menuitem to menu With cbMenu.Controls.Add(msoControlButton, 1, , , True)  .Caption = ""&Remove this menu""  .OnAction = ThisWorkbook.Name & ""!RemoveMenu""  .Style = msoButtonIconAndCaption  .FaceId = 463  .BeginGroup = True End With Set cbSubMenu = Nothing Set cbMenu = Nothing  Sub RemoveMenu() ' may be automatically executed from an Auto_Close macro or a Workbook_BeforeClose eventmacro DeleteCustomCommandBarControl ""MyTag"" ' deletes the new menu  Private Sub DeleteCustomCommandBarControl(CustomControlTag As String) ' deletes ALL occurences of commandbar controls with a tag = CustomControlTag On Error Resume Next Do  Application.CommandBars.FindControl(, , CustomControlTag, False).Delete Loop Until Application.CommandBars.FindControl(, , CustomControlTag, False) Is Nothing On Error GoTo 0  Sub ShowHideMenu(MenuVisible As Boolean) ' may be automatically executed from an Workbook_Activate macro or a Workbook_Deactivate eventmacro ChangeControlVisibility ""MyTag"", MenuVisible ' toggles menu visibility  Private Sub ChangeControlVisibility(CustomControlTag As String, MenuVisible As Boolean) ' toggles menu visibility On Error Resume Next Application.CommandBars.FindControl(, , CustomControlTag, False).Visible = MenuVisible On Error GoTo 0  Sub Macroname() ' used by the menuitems created by the CreateMenu macro MsgBox ""This could be your macro running!"", vbInformation, ThisWorkbook.Name  'Thisworkbook a Private Sub Workbook_Activate() ShowHideMenu True  Private Sub Workbook_BeforeClose(Cancel As Boolean) RemoveMenu  Private Sub Workbook_Deactivate() ShowHideMenu False  Private Sub Workbook_Open() CreateMenu " "Sub MenuErstellen() Dim MB As CommandBar Dim Ctrl1 As CommandBarControl Dim Ctrl2 As CommandBarControl Dim Ctrl1a As CommandBarControl Dim Ctrl1b As CommandBarControl Set MB = CommandBars.Add(Name:=""Neues Menü"", MenuBar:=True) Set Ctrl1 = MB.Controls.Add(Type:=msoControlPopup) Ctrl1.Caption = ""Untermenü1"" Set Ctrl2 = MB.Controls.Add(Type:=msoControlPopup) Ctrl2.Caption = ""Untermenü2"" Set Ctrl1a = Ctrl1.Controls.Add(Type:=msoControlPopup) Ctrl1a.Caption = ""Daten"" Set Ctrl1b = Ctrl1.Controls.Add(Type:=msoControlPopup) Ctrl1b.Caption = ""Übertragen"" CommandBars(""Neues Menü"").Visible = True " "Private Sub Workbook_Activate() MenuBars(xlWorksheet).Menus.Add ""&Test Menü"" Set ml = MenuBars(xlWorksheet).Menus(""Test Menü"") With ml .MenuItems.Add Caption:=""&Daten erfassen"", _ OnAction:=""DatenSpeichern"" .MenuItems.AddMenu Caption:=""&Auswertungen"" With .MenuItems(""Auswertungen"") .MenuItems.Add Caption:=""&Auswertung1"", _ OnAction:="""" .MenuItems.Add Caption:=""A&uswertung2"", _ OnAction:="""" End With End With  Private Sub Workbook_Deactivate() MenuBars(xlWorksheet).Reset  Private Sub Workbook_Open() MenuBars(xlWorksheet).Menus.Add ""&Test Menü"" Set ml = MenuBars(xlWorksheet).Menus(""Test Menü"") With ml .MenuItems.Add Caption:=""&Daten erfassen"", _ OnAction:=""DatenSpeichern"" .MenuItems.AddMenu Caption:=""&Auswertungen"" With .MenuItems(""Auswertungen"") .MenuItems.Add Caption:=""&Auswertung1"", _ OnAction:="""" .MenuItems.Add Caption:=""A&uswertung2"", _ OnAction:="""" End With End With " "Sub Menueleiste_ausblenden() Application.CommandBars(""Worksheet Menu Bar"").Enabled = False  Sub Menueleiste_einblenden() Application.CommandBars(""Worksheet Menu Bar"").Enabled = True " "Sub supBA() For Each LaBarMenu In ActiveMenuBar.Menus LaBarMenu.Delete Next MsgBox ""Barre de menus supprimée !"" ActiveMenuBar.Reset MsgBox ""Barre de menus rétablie !""  Sub ac() Application.CommandBars(1).Enabled = True " "Sub Dosya_İsimleri() Dim ds, dc, f, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set f = ds.GetFolder(""C:\SXS"") Set dc = f.Files For Each dosya In dc s = s & vbCrLf & dosya.Name Next MsgBox s " "Sub Dosyalar()  Dim Klasor As String  Dim Dosya As String  Dim i As Integer  Klasor = ""C:\osman""  Dosya = Dir(Klasor & Application.PathSeparator & ""."", vbDirectory)  Do While Dosya <> """" Cells(i + 1, 1) = Dosya i = i + 1 Dosya = Dir  Loop " "ThisWorkbook'a Private Sub Workbook_Open() Worksheets(""Sayfa1"").Range(""A1"").Value = Worksheets(""Sayfa1"").Range(""A1"").Value + 1 MsgBox ""Bu dosya "" & Worksheets(""Sayfa1"").Range(""A1"").Value & "" kez açıldı"" & vbCrLf & ""En son açan : "" & Worksheets(""Sayfa1"").Range(""B1"") Worksheets(""Sayfa1"").Range(""B1"") = Application.UserName ThisWorkbook.Save " "Sub Auto_Open() 'belirtilen dizinde ""pir"" isimli bir klasör olup olmadığına bakar yoksa oluşturur On Error Resume Next If Dir(""C:\pir"") = """" Then MkDir ""C:\pir""  Sheets(""Sheet1"").Select   Sub dosyaekle() 'belirtilen dizine dosya ekler. aynı isimli dosya varsa öncekini siler yeniden ekler Dim Dosyam As String, Message As String Workbooks.Add 'çalışma kitabı ekler Dosyam = ""C:\pir.xls"" 'yeni eklenecek dosyamızın ismi On Error Resume Next Kill Dosyam 'önceki dosyayı kaldırır On Error GoTo 0 ActiveWorkbook.SaveAs Filename:=Dosyam 'dosyaya isim verir ActiveWorkbook.Close " "Sub Auto_Open() 'belirtilen dizinde ""mahmut"" isimli bir klasör olup olmadığına bakar yoksa oluşturur On Error Resume Next If Dir(""C:\mahmut"") = """" Then MkDir ""C:\pir"" Sheets(""Sheet1"").Select   Sub dosyaekle() 'belirtilen dizine dosya ekler. aynı isimli dosya varsa öncekini siler yeniden ekler Dim Dosyam As String, Message As String Workbooks.Add 'çalışma kitabı ekler Dosyam = ""C:\mahmut.xls"" 'yeni eklenecek dosyamızın ismi On Error Resume Next Kill Dosyam 'önceki dosyayı kaldırır On Error GoTo 0 ActiveWorkbook.SaveAs Filename:=Dosyam 'dosyaya isim verir ActiveWorkbook.Close " "Sub dosya_listeleme() Dim datename As String, i As Integer datename = Dir$(""C:\Documents and Settings\pir\Belgelerim\.xls"") Do While datename <> """" ActiveCell.Offset(i, 0) = datename i = i + 1 datename = Dir$() Loop " "Sub Verstecken() For Each tb in Toolbars tb.Visible = False Next tb " "Sub Dosya_Sayısı() Dim ds, dc, f, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set f = ds.GetFolder(""C:\SXS"") Set dc = f.Files s = dc.Count MsgBox s " "Sub sil() Kill ""C:\Documents And Settings\pir\Belgelerim\pir.xls"" " "Sub Dosya_Sistemi_Göster() Dim ds, d, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set d = ds.GetDrive(""C:\"") s = d.FileSystem MsgBox s " "Private Declare Function GetVolumeInformation Lib ""Kernel32"" Alias ""GetVolumeInformationA"" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long Sub Dosya_Sistemi()  Dim DosyaSistemi As String  DosyaSistemi = String$(255, Chr$(0))  GetVolumeInformation ""C:\"", 0, 255, 0, 0, 0, DosyaSistemi, 255  DosyaSistemi = Left$(DosyaSistemi, InStr(1, DosyaSistemi, Chr$(0))  1)  MsgBox DosyaSistemi " "Sub Dosya_Taşı() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") f = ds.MoveFile(""D:\ExcelÖrnekleri\Move.xls"", ""C:\"") " "Sub Uzantı_İsmi() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") f = ds.GetExtensionName(""D:\ExcelÖrnekleri\Soru.xls"") MsgBox f " "Sub Yedek()  '/_  Dismi= ActiveWorkbook.Name  ActiveWorkbook.SaveCopyAs ""D:\Alihan_Bordro\ "" & Dismi  ActiveWorkbook.Save " "Sub Enregistre_Sous() Réponse = MsgBox(""Voulezvous enregistrer ce classeur ?"", vbYesNo) If Réponse = vbYes Then Nom = InputBox(""Donnez un nom de fichier !"" & Chr(13) & ""Exemple: Rapport"") If Nom = """" Then Exit Sub Else GoTo continu End If continu: ChDrive ""c"" ChDir ""c:\"" 'Indiquez le répertoire ActiveWorkbook.SaveAs Filename:=(Nom) End If " "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 Private z! Function GetDirectory(Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer With bInfo .pidlRoot = 0& .lpszTitle = Msg .ulFlags = &H1 End With 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) Else GetDirectory = """" End If  Sub Dateisuche(Laufwerk, Dateien) Dim tmp, Wdhlg, Dateiname As String On Error Resume Next If Right(Laufwerk, 1) <> ""\"" Then Laufwerk = Laufwerk + ""\"" tmp = Dir(Laufwerk & Dateien) Do While Len(tmp) Dateiname = Laufwerk & tmp Application.StatusBar = Dateiname Cells(z, 1).Select Cells(z, 1) = Laufwerk & tmp 'Pfad Cells(z, 2) = FileLen(Laufwerk & tmp) 'Größe Cells(z, 3) = FileDateTime(Laufwerk & tmp) 'Datum/Zeit Cells(z, 4) = tmp 'nur Dateiname z = z + 1 tmp = Dir() Loop tmp = Dir(Laufwerk, vbDirectory) Do While Len(tmp) If (tmp <> ""."") And (tmp <> "".."") Then  If (GetAttr(Laufwerk & tmp) And vbDirectory) = vbDirectory Then Dateisuche Laufwerk & tmp, Dateien z = z  1 Wdhlg = Dir(Laufwerk, vbDirectory) z = z + 1 Do While Wdhlg <> tmp Wdhlg = Dir() Loop  End If End If tmp = Dir() Loop On Error GoTo 0 Application.StatusBar = False  Sub Suchen() Dim Laufwerk$, Dateien$ 'Ersze Zeile, in der eine Eintragung erfolgt z = 2 'Alte Eintragungen löschen [a1:e5000] = """" 'Ersatz: ... = ""C:\Eigene Dateien"" Laufwerk = GetDirectory(""Bitte einen Ordner wählen"") If Laufwerk = """" Then Exit Sub 'Ersatz: Dateien = ""."" Dateien = InputBox(""Nach welchen Dateien soll in"" & _ Chr(10) & "" "" & Laufwerk & Chr(10) & _ ""gesucht werden (z. B. .xls)?"", _ ""Dateityp"", ""."") If Dateien = """" Then Exit Sub Dateisuche Laufwerk, Dateien " "Sub a() Set xl = CreateObject(""Excel.Sheet"") xl.Application.Workbooks.Open Range(""K1"")  " "Sub ExcelDateienÖffnen() With Application.FileSearch .NewSearch .LookIn = ""C:\"" ‘\Belgelerim şeklinde de olabilir. .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks .Execute  For i = 1 To .FoundFiles.Count  Workbooks.Open .FoundFiles(i) Next i End With " "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] = """" 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  msg = ""Wählen Sie bitte einen Ordner aus:"" Pfad1 = getdirectory(msg) If Pfad1 = """" Then Exit Sub Name1 = Dir(Pfad1, vbDirectory) 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)  If Right(Pfad1, 1) <> ""\"" Then Pfad1 = Pfad1 & ""\""  Name1 = Dir(Pfad1, vbDirectory)  Verz = 0  Do While Name1 <> """"  If Name1 <> ""."" And Name1 <> "".."" Then  If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then  Anzahl = Anzahl + 1  TB1.Cells(Anzahl, 1) = Pfad1 & Name1 & ""\""  Verz = Verz + 1  End If  End If  Name1 = Dir  Loop  TB1.Cells(X2, 2) = Verz  Next X2  X0 = X1 + 1  X1 = X2 Loop 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"")  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& If IsMissing(msg) Then  bInfo.lpszTitle = ""Wählen Sie bitte einen Ordner aus."" 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) Else  getdirectory = """" End If " "Private Sub Workbook_Open() Dim cmb As CommandBar Dim cmbp As CommandBarPopup Set cmb = Application.CommandBars. _ Add(Name:=""MeineLeiste"", _  Position:=msoBarTop, _  Temporary:=True) Set cmbp = cmb.Controls.Add(Type:=msoControlPopup) cmb.Visible = True cmbp.Caption = ""Mein Submenü"" With cmbp.Controls.Add(Type:=msoControlButton, _  Temporary:=True) .Caption = ""Meine 1. Prozedur"" .BeginGroup = True .FaceId = 59 .OnAction = ""MeineProzedur1"" End With With cmbp.Controls.Add(Type:=msoControlButton, _  Temporary:=True) .Caption = ""Meine 2. Prozedur"" .FaceId = 49 .OnAction = ""MeineProzedur2"" End With Set cmb = Nothing Set cmbp = Nothing  Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim cmb As CommandBar Set cmb = Application.CommandBars(""MeineLeiste"") cmb.Delete Set cmb = Nothing  Sub MeineProzedur1() MsgBox Application.UserName  Sub MeineProzedur2() MsgBox Now() " "Sub MenueleisteAusblenden() Application.CommandBars(""Worksheet Menu Bar"").Enabled = False  Sub MenueleisteAusblenden() Application.CommandBars(""Worksheet Menu Bar"").Enabled = True " Application.CommandBars.ActiveMenuBar.Enabled = False "On Error GoTo hata If foto <> False Then Image1.Picture = LoadPicture(""E:\Office\WINDOWS\Resim\"" & foto & "".bmp"") 'BU SATIRIN ÇALIŞMASI İÇİN ""C"" BÖLÜMÜNE ""Resim"" adında bir klasör açıp içine resimleri kişilerin kendi isimleriyle kaydedin. Image1.PictureSizeMode = fmPictureSizeModeStretch End If End If Next bak Exit Sub hata: Image1.Picture =loadpicture("""")" "Sub dosyasil() On Error Resume Next RmDir ""C:\pir\xp\beyza"" " "Function WorkbookOpen(WorkBookName As String) As Boolean  WorkbookOpen = False  On Error GoTo WorkBookNotOpen  If Len(Application.Workbooks(WorkBookName).Name) > 0 Then WorkbookOpen = True Exit Function  End If WorkBookNotOpen:   Sub AA() If Not WorkbookOpen(""C.xls"") Then  Workbooks.Open ""C.xls"" End If " "Private Sub Workbook_Open()  Open ThisWorkbook.Path & ""\pirr.log"" For Append As #1  Print #1, Application.UserName, Now  Close #1 " "Sub Auto_Open() Dim exdate As Date exdate = ""11/30/2004"" If Date > exdate Then  MsgBox (""You have reached end of your trail period"")  ActiveWorkbook.Close End If MsgBox (""You have "" & exdate  Date & ""Days left"") " "Function CreateFileList(FileFilter As String, _ IncludeSubFolder As Boolean) As Variant Dim FileList() As String, FileCount As Long CreateFileList = """" Erase FileList If FileFilter = """" Then FileFilter = ""."" ' all files With Application.FileSearch  .NewSearch  .LookIn = CurDir  .Filename = FileFilter  .SearchSubFolders = IncludeSubFolder  .FileType = msoFileTypeAllFiles  If .Execute(SortBy:=msoSortByFileName, _ SortOrder:=msoSortOrderAscending) = 0 Then Exit Function  ReDim FileList(.FoundFiles.Count)  For FileCount = 1 To .FoundFiles.Count FileList(FileCount) = .FoundFiles(FileCount)  Next FileCount  .FileType = msoFileTypeExcelWorkbooks ' reset filetypes End With CreateFileList = FileList Erase FileList  Sub TestCreateFileList() Dim FileNamesList As Variant, i As Integer 'ChDir ""C:\My Documents"" FileNamesList = CreateFileList(""."", False) Range(""A:A"").ClearContents For i = 1 To UBound(FileNamesList)  Cells(i + 1, 1).Formula = FileNamesList(i) Next i " "Sub Yedek()  '/_  Dismi= ActiveWorkbook.Name  ActiveWorkbook.SaveCopyAs ""D:\Alihan_Bordro\ "" & Dismi  ActiveWorkbook.Save  " "A ya dosya ismini Bye Bayt cinsini Cye de tarihini yazar Kod: Sub Dateiname_Hyperlink() Dim StDateiname As String Dim Dateiform As String Dim InI As Long, TotFiles As Long Dim Suchpfad As String Dim OldStatus As Variant Suchpfad = InputBox(""Yolunu değiştirebilirsiniz"", ""Adres yolu"", Application.DefaultFilePath) If Suchpfad = """" Then Exit Sub Dateiform = InputBox(""Dosya uzantısını siz değiştiriniz"", ""Uzantı"", "".xls"") If Dateiform = """" Then Exit Sub Application.ScreenUpdating = True OldStatus = Application.StatusBar Sheets.Add After:=Worksheets(Worksheets.Count) With Application.FileSearch  .LookIn = Suchpfad  .SearchSubFolders = True  .Filename = Dateiform  If .Execute() > 0 Then TotFiles = .FoundFiles.Count Application.StatusBar = ""Total "" & TotFiles & "" gefunden"" For InI = 1 To .FoundFiles.Count Application.StatusBar = ""Datei: "" & InI & "" von "" & TotFiles StDateiname = Mid(.FoundFiles(InI), InStrRev(.FoundFiles(InI), ""\"") + 1) ActiveSheet.Hyperlinks.Add Anchor:=Cells(InI, 1), _  Address:=.FoundFiles(InI), TextToDisplay:=StDateiname Cells(InI, 2) = FileLen(.FoundFiles(InI)) Cells(InI, 3) = FileDateTime(.FoundFiles(InI)) Next InI  End If End With Application.StatusBar = OldStatus Application.ScreenUpdating = True " " Sub auto_close() sor = MsgBox(""Güle güle "" & Format(Now, ""dd.mmmm.yy hh:mm"") & Chr(10) & Chr(10) & ""dosyanın kaydedilmesini istiyormusunuz?"", 4, """") If sor = vbYes Then ActiveWorkbook.Save ActiveWorkbook.Close Else Application.DisplayAlerts = False ActiveWorkbook.Close End If " "Sub kapa() MsgBox ""Bu programı pir düzenlemiştir."", , ""KAPATILIYOR"" ActiveWorkbook.Close True " "ThisWorkBook yazılacak. 'Ayrıca C:\acılısarsiv.txt olarak ayrıca txt dosyası oluşturuyor..  Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String LastOpen = GetSetting(""xxrt"", ""Dosya"", ""Opened"", """") [a1] = ""En son açılış tarihi: "" & LastOpen [a2] = ""Dosyayı en son açan kullanıcı: "" & Application.UserName LastOpen = Date & "" "" & Time SaveSetting ""xxrt"", ""Dosya"", ""Opened"", LastOpen Dim LastRowA As Integer Dim veri1 As String Dim veri2 As String Dim i As Integer Open ""C:\acılısarsiv.txt"" For Output As #1 LastRowA = Cells(65536, 1).End(xlUp).Row For i = 1 To LastRowA veri1 = Cells(i, 1).Text veri2 = Cells(i, 2).Text Print #1, veri1; "" ""; veri2; Next i Close #1 'C Klasöründe txt hazırladı 'enson açan kişinin yazılı bulunduğuSayfa1 a1 ve a2 deki verileri siler.. 'eğer Sayfa1'de silmesini istemezseniz aşağıdakileri silin. Sheets(""Sayfa1"").Select Range(""A1:A2"").Select  Selection.ClearContents  Range(""A1"").Select  'Mesaj olarakta [a1] = ""En son açılış tarihi: "" & LastOpen [a2] = ""Dosyayı en son açan kullanıcı: "" & Application.UserName  'Kodlarının altına bunları yazın.  MsgBox ""En son açılış tarihi: "" & LastOpen MsgBox ""Dosyayı en son açan kullanıcı: "" & Application.UserName " "ThisWorkbook'a Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String LastOpen = GetSetting(""xxrt"", ""Dosya"", ""Opened"", """") [a1] = ""En son açılış tarihi: "" & LastOpen [a2] = ""Dosyayı en son açan kullanıcı: "" & Application.UserName MsgBox ""En son açılış tarihi: "" & LastOpen MsgBox ""Dosyayı en son açan kullanıcı: "" & Application.UserName LastOpen = Date & "" "" & Time SaveSetting ""xxrt"", ""Dosya"", ""Opened"", LastOpen Dim LastRowA As Integer Dim veri1 As String Dim veri2 As String Dim i As Integer Open ""C:\acılısarsiv.txt"" For Output As #1 LastRowA = Cells(65536, 1).End(xlUp).Row For i = 1 To LastRowA veri1 = Cells(i, 1).Text veri2 = Cells(i, 2).Text Print #1, veri1; "" ""; veri2; Next i Close #1 'C Klasöründe txt hazırladı 'enson açan kişinin yazılı bulunduğuSayfa1 a1 ve a2 deki verileri siler.. 'eğer Sayfa1'de silmesini istemezseniz aşağıdakileri silin. Sheets(""Sayfa1"").Select Range(""A1:A2"").Select Selection.ClearContents Range(""A1"").Select " "Private Sub Workbook_BeforeSave _ (ByVal SaveAsUI As Boolean, Cancel As Boolean) sifre = InputBox(""İşçi Maaş İcmali olduğundan Kayıt için Şifre Girmelisiniz."", _ ""Yetkili Kişi"", ""Kaydetmek İçin Şifre girin"") If sifre = ""123456"" Then'Örnek Şifre olarak 123456 MsgBox ""Kayıt işlemi tamamlandı"", vbInformation, _ ""KAYIT BAŞARILI"" Else MsgBox ""Yanlış şifre girdiniz."" & Chr(13) & _ ""Dosya kaydedilemedi"", vbCritical, ""HATALI ŞİFRE"" Cancel = True End If " "Option Explicit Sub DateAsFilename() Dim sFileName As String sFileName = Format(Now, ""dd.mm.yyyy"") + "".xls"" ' tarih formatını değiştirebilirsiniz (ddmmyy) gibi ActiveWorkbook.SaveAs sFileName " "Sanırım Dosyanız Çok gizli olsa gerek..Dosyanızda silinme riskini düşünerek bu kodlara ihtiyaç duyduğunuzu umarım.Yoksa Bilgilerinizi makrolarınızı sizde paylaşmak istersiniz..Neyse aşağıdaki kod tam çözüm olmamakla birlikte bu kodlar ThisWorkBook yazılacak. .Ayrıca C:\acılısarsiv.txt olarak ayrıca txt dosyası oluşturuyor.. Kod: Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String LastOpen = GetSetting(""xxrt"", ""Dosya"", ""Opened"", """") [a1] = ""En son açılış tarihi: "" & LastOpen [a2] = ""Dosyayı en son açan kullanıcı: "" & Application.UserName LastOpen = Date & "" "" & Time SaveSetting ""xxrt"", ""Dosya"", ""Opened"", LastOpen Dim LastRowA As Integer Dim veri1 As String Dim veri2 As String Dim i As Integer Open ""C:\acılısarsiv.txt"" For Output As #1 LastRowA = Cells(65536, 1).End(xlUp).Row For i = 1 To LastRowA veri1 = Cells(i, 1).Text veri2 = Cells(i, 2).Text Print #1, veri1; "" ""; veri2; Next i Close #1 'C Klasöründe txt hazırladı 'enson açan kişinin yazılı bulunduğuSayfa1 a1 ve a2 deki verileri siler.. 'eğer Sayfa1'de silmesini istemezseniz aşağıdakileri silin. Sheets(""Sayfa1"").Select Range(""A1:A2"").Select  Selection.ClearContents  Range(""A1"").Select  Mesaj olarakta Kod: [a1] = ""En son açılış tarihi: "" & LastOpen [a2] = ""Dosyayı en son açan kullanıcı: "" & Application.UserName  Kodlarının altına bunları yazın.Kod:  MsgBox ""En son açılış tarihi: "" & LastOpen MsgBox ""Dosyayı en son açan kullanıcı: "" & Application.UserName " "C1, C2, C3 veC4'e X değerlerini 'D1, D2,D3 ve D4'e Y değerlerini 'E1, E2, E3 ve E4'e Z değerlerini girin. Sub xyz() Dim i As Integer Dim j As Integer Dim k As Integer Dim satir As Integer satir = 1 For k = 1 To 4  For j = 1 To 4 For i = 1 To 4 Cells(satir, 1) = Cells(k, 3) & Cells(j, 4) & Cells(i, 5) satir = satir + 1 Next i  Next j Next k  " "Sub TableauAnTrimestre() For An = 1 To 5 Cells(1, An + 1).Value = 2000 + An Next An For Trimestre = 1 To 4 Cells(Trimestre + 1, 1).Value = ""Trim"" & Trimestre Next Trimestre " "Sub JourSemaine() Dim semaine(1 To 7) As String semaine(1) = ""Lundi"" semaine(2) = ""Mardi"" semaine(3) = ""Mercredi"" semaine(4) = ""Jeudi"" semaine(5) = ""Vendredi"" semaine(6) = ""Samedi"" semaine(7) = ""Dimanche"" For i = 1 To 7 Selection.Offset(i  1, 0).Formula = semaine(i) Next i " "a = Mid(Date, 3, 1) DTPicker1.Value = Format(Date, ""dd"" + a + ""mm"" + a + ""yyyy"")" "Private Sub DTPicker1_Change() [B3] = DTPicker1.Value " "Date = gunkontrol.Fields(""tarih"") a = Mid(Date, 3, 1) DTPicker1.Value = Format(Date, ""dd"" + a + ""mm"" + a + ""yyyy"") ancak bu kod yazıldığında bilgisayarın sistem tarihi de database den galen tarih olarak değişiyor. bunu önlemek içi şöyle bir kontrol uygulayabiliriz: sondate = Date Date = gunkontrol.Fields(""tarih"") a = Mid(Date, 3, 1) DTPicker1.Value = Format(Date, ""dd"" + a + ""mm"" + a + ""yyyy"") Date = sondate" "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _ ByVal Target As Excel.Range) Application.StatusBar = Sh.Name & "":"" & Target.Address " "Thisworkbook'a  Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Application.StatusBar = Application.UserName & """" & _ ThisWorkbook.Path & """" & Sh.Name & "":"" & Target.Address Application.Caption = ThisWorkbook.Path & """" & Sh.Name ActiveWindow.Caption = Target.Address " "Declare Function GetAsyncKeyState Lib ""User32"" _ (ByVal vKey As Integer) As Integer 'GetAsyncKeyState est asynchrone  La touche est mémorisée Sub testToucheA() For y = 1 To 10000 Application.StatusBar = y Next If (GetAsyncKeyState(65) <> 0) Then MsgBox ""Touche A frappée."" End If " "Sub tridoublon() Worksheets(""Feuil1"").Range(""A1"").Sort _ key1:=Worksheets(""Feuil1"").Range(""A2""), _ Order1:=xlAscending, Header:=xlGuess Set MaCell = Worksheets(""Feuil1"").Range(""A1"") Do While Not IsEmpty(MaCell) Set MaCellSuite = MaCell.Offset(1, 0) If MaCellSuite.Value = MaCell.Value Then MaCell.EntireRow.Delete End If Set MaCell = MaCellSuite Loop " "Sub Dialog_47() Application.Dialogs(xlDialogOptionsEdit).Show " "Sub GetSum()  [A1].Value = Application.Sum([E1:E15]) " "Declare Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long) Sub Rotieren() Dim C As Range Dim i% Set C = Range(""E10"") For i = 1 To 2000  C = Right(C, Len(C.Value)  1) + Left(C, 1)  Sleep 200 Next i " "Sub Düğme1_Tıklat() x = Cells(65536, 3).End(xlUp).Row Range(""E2"").AutoFill Destination:=Range(""E2:E"" & x) Application.Calculate " "Private Sub CommandButton1_Click() For Each yes In Range(""P:P"") If yes = ""evet"" Then  ListBox1.AddItem yes.Offset(0, 12) End If Next " "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Value = 1 Then  Dim sayfa As Worksheet  Dim önek As String  Dim sonek As Integer Set Sayfam = Worksheets.Add  önek = ""Sayfam""  SonEkim = 1 On Error Resume Next  Sayfam.Name = önek & sonek  If Err.Number <> 0 Then önek = sonek + 1 Sayfam.Name = önek & sonek  End If End If " "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = ""$A$1"" Then If Target.Value = ""1"" Then MsgBox ""ExcelPazarı"" End If " "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Range(""A1"") >= 1 Then MsgBox ""Aşkından Selamlar""  " "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target = Cells(1, 1) Then Cells(2, 1) = Now  'alternatif ŞİMDİ() or Bugün or Time" "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  Sub Macro1() MsgBox ""Selam"" " "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 " "Sub Action() If IsNumeric(ActiveCell) Then ActiveCell.Font.Bold = ActiveCell.Value >= 500 End If " "Sub SelCurRegCopy() Selection.CurrentRegion.Select Selection.Copy Range(""A17"").Select ' Substitute your range here ActiveSheet.Paste Application.CutCopyMode = False " "12 adet eğer formülünü araya + işlecini koyarak 2 ye bölmektir. Formül B1 hücresine yazılmış ve A1 hücresindeki veriyi kontrol etmektedir. =EĞER(A1=""OCAK"";OCAK!A1;EĞER(A1=""ŞUBAT"";ŞUBAT!A1;EĞER(A1=""MART"";MART!A1;EĞER(A1=""NİSAN"";NİSAN!A1;EĞER(A1=""MAYIS"";MAYIS!A1;EĞER(A1=""HAZİRAN"";HAZİRAN!A1))))))+EĞER(A1=""TEMMUZ"";TEMMUZ!A1;EĞER(A1=""AĞUSTOS"";AĞUSTOS!A1;EĞER(A1=""EYLÜL"";EYLÜL!A1;EĞER(A1=""EKİM"";EKİM!A1;EĞER(A1=""KASIM"";KASIM!A1;EĞER(A1=""ARALIK"";ARALIK!A1))))))" "Sub Datum_in_Fusszeile() Dim SeitenNummer%, X% Dim Zaehler As Boolean Zaehler = True X = ExecuteExcel4Macro(""get.document(50)"") For SeitenNummer = 1 To X If Zaehler = True Then With ActiveSheet.PageSetup .RightFooter = ""&D"" .LeftFooter = """" End With End If If Zaehler = False Then With ActiveSheet.PageSetup .RightFooter = """" .LeftFooter = ""&D"" End With End If ActiveWindow.SelectedSheets.PrintOut _ From:=SeitenNummer, To:=SeitenNummer, Copies:=1 Zaehler = Not Zaehler Next SeitenNummer " "Sub SelectFirstToLastInColumn() Set TopCell = Cells(1, ActiveCell.Column) Set BottomCell = Cells(16384, ActiveCell.Column) If IsEmpty(TopCell) Then Set TopCell = TopCell.End(xlDown) If IsEmpty(BottomCell) Then Set BottomCell = BottomCell.End(xlUp) If TopCell.Row = 16384 And BottomCell.Row = 1 Then ActiveCell.Select Else Range(TopCell, BottomCell).Select " "Sub SelectFirstToLastInRow() Set LeftCell = Cells(ActiveCell.Row, 1) Set RightCell = Cells(ActiveCell.Row, 256) If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight) If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft) If LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select " "Sub ExcelEger()  [B1] = ""=IF(A1>=50,""""Sınıf Geçer"""",""""Sınıfta Kalır"""")""   Sub VBAEger()  If [A1] >= 50 Then [B1] = ""Sınıf Geçer""  Else [B1] = ""Sınıfta Kalır"" End If " "Bu tür hata mesajlarının hepsinde aynı yöntemi uygulamak mümkündür. Unutulmamalıdır ki, hata mesajı olan hücrede bir formül bulunmaktadır. 'Farzedelim ki hatalı hücrede aşağıdaki gibi bir formül olsun. =DÜŞEYARA(B1;C1:D11;2;0) 'Düşeyara ile aranılan veri bulunamadığında hücrede #YOK hata değeri olacaktır. Dolayısı ile bu da o hücrenin içerisinde bulunduğu bir toplama 'dizisini hatalı olarak gösterecektir. O halde bu hücreye ya boşluk değeri ya da sıfır değeri atayabiliriz. Ama unutmayınız sıfır değeri çarpma 'işleminde sorun çıkartabilir. O halde boşluk değeri atayalım. Yukarıdaki formülü aşağıdaki gibi değiştiriniz. =EĞER(EHATALIYSA(DÜŞEYARA(B1;C1:D11;2;0));"""";DÜŞEYARA(B1;C1:D11;2;0)) 'Yaptığımız tek şey normal olarak bildiğimiz EĞER formülü ile birlikte EHATALIYSA formülünü kullanmaktır. Formülün anlaşılması için aşağıdaki 'açıklamayı inceleyiniz. =EĞER(HATALIYSA(formül);"""";formül)) '""Eğer formül hatalı sonuç veriyorsa hücreyi boş bırak, değil ise formül sonucunu yazdır.""" "Sub Eklenti()  Dim i As Integer  Dim Eklenti Cells(1, 1).Value = ""Eklenti Adı""  Cells(1, 2).Value = ""Eklenti Yolu""  Cells(1, 3).Value = ""Eklenti Boyutu""  Cells(1, 4).Value = ""Eklentiyi Oluşturma Tarihi""  Cells(1, 5).Value = ""Dosya Tipi"" Set Eklenti = CreateObject(""Scripting.FileSystemObject"") For i = 1 To Application.AddIns.Count Cells(i + 1, 1).Value = Application.AddIns(i).Name 'adı Cells(i + 1, 2).Value = Application.AddIns(i).Path 'Dosya Yolu Cells(i + 1, 3).Value = Int(Eklenti.GetFile(Application.AddIns(i).FullName).Size / 1024) & "" Kb"" Cells(i + 1, 4).Value =  Eklenti.GetFile(Application.AddIns(i).FullName).DateCreated Cells(i + 1, 5).Value = Eklenti.GetFile(Application.AddIns(i).FullName).Type If Application.AddIns(i).Installed = False Then Cells(i + 1, 6).Value = ""Aktif Değil"" Else Cells(i + 1, 6).Value = ""Aktif"" End If  Next i  Columns(""A:F"").EntireColumn.AutoFit " "Sub Dialog_38() Application.Dialogs(xlDialogInsert).Show " "Sub Dialog_03() Application.Dialogs(xlDialogAddinManager).Show " "Sub afficheComplement() For Each a In AddIns MsgBox a.FullName Next a " "Sub testUtilitAnalyse() If AddIns(""Query manager"").Installed = True Then MsgBox ""Utilitaire d'analyse installé"" Else MsgBox ""Utilitaire d'analyse non installé"" End If " "Private Declare Function EnumDisplaySettings Lib ""user32"" Alias ""EnumDisplaySettingsA"" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean Private Declare Function ChangeDisplaySettings Lib ""user32"" Alias ""ChangeDisplaySettingsA"" (lpDevMode As Any, ByVal dwflags As Long) As Long Const CCDEVICENAME = 32 Const CCFORMNAME = 32 Const DM_PELSWIDTH = &H80000 Const DM_PELSHEIGHT = &H100000 Type DEVMODE dmDeviceName As String  CCDEVICENAME dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName As String  CCFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Integer dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type Dim DevM As DEVMODE Private Sub ChangeScreenResolution(iWidth As Single, iHeight As Single) Dim a As Boolean Dim i& Dim b& i = 0 Do a = EnumDisplaySettings(0&, i&, DevM) i = i + 1 Loop Until (a = False) DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT DevM.dmPelsWidth = iWidth DevM.dmPelsHeight = iHeight b = ChangeDisplaySettings(DevM, 0)  Sub ChangeTo1024_768() Call ChangeScreenResolution(1024, 768) 'buradaki değerleri değiştirerek ayarlayabilirsiniz. " "Private Declare Function EnumDisplaySettings Lib ""user32"" Alias ""EnumDisplaySettingsA"" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean Private Declare Function ChangeDisplaySettings Lib ""user32"" Alias ""ChangeDisplaySettingsA"" (lpDevMode As Any, ByVal dwflags As Long) As Long Const CCDEVICENAME = 32 Const CCFORMNAME = 32 Const DM_PELSWIDTH = &H80000 Const DM_PELSHEIGHT = &H100000 Type DEVMODE dmDeviceName As String  CCDEVICENAME dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName As String  CCFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Integer dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type Dim DevM As DEVMODE Private Sub ChangeScreenResolution(iWidth As Single, iHeight As Single) Dim a As Boolean Dim i& Dim b& i = 0 Do a = EnumDisplaySettings(0&, i&, DevM) i = i + 1 Loop Until (a = False) DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT DevM.dmPelsWidth = iWidth DevM.dmPelsHeight = iHeight b = ChangeDisplaySettings(DevM, 0)  Sub ChangeTo1024_768() Call ChangeScreenResolution(1024, 768) " "Declare Function GetClipCursor Lib ""user32"" (lprc As RECT) As Long Type RECT gauche As Long haut As Long droit As Long bas As Long End Type Dim oGCC As RECT Sub auto_open() GetClipCursor oGCC With oGCC [a1] = .droit & "" x "" & .bas If [a1] <> ""1024 x 768"" Then MsgBox ""Üzgünüm ekran çözünürlüğünüz 1024 x 768 olması gerekiyor aksi taktirde bu programı kullanmazsınız"" Application.DisplayAlerts = False ActiveWorkbook.Close  End If  End With " "Declare Function GetDeviceCaps Lib ""gdi32"" (ByVal hdc As Long, ByVal nIndex As Long) As Long Declare Function GetDC Lib ""user32"" (ByVal hwnd As Long) As Long Declare Function ReleaseDC Lib ""user32"" (ByVal hwnd As Long, ByVal hdc As Long) As Long Const HORZRES = 8 Const VERTRES = 10 Declare Function GetSystemMetrics Lib ""user32"" (ByVal nIndex As Long) As Long Const SM_CYSCREEN As Long = 1 Const SM_CXSCREEN As Long = 0 Sub GetScreenDimensions() Dim lWidth As Long Dim lHeight As Long lWidth = GetSystemMetrics(SM_CXSCREEN) lHeight = GetSystemMetrics(SM_CYSCREEN) MsgBox ""Screen Width = "" & lWidth & vbCrLf & ""Screen Height = "" & lHeight  Function ScreenResolution() Dim lRval As Long Dim lDc As Long Dim lHSize As Long Dim lVSize As Long lDc = GetDC(0&) lHSize = GetDeviceCaps(lDc, HORZRES) lVSize = GetDeviceCaps(lDc, VERTRES) lRval = ReleaseDC(0, lDc) ScreenResolution = lHSize & ""x"" & lVSize  Sub GetScreenSize() Debug.Print ScreenResolution() " "Private Sub Worksheet_Activate() Call GetScreenSize  Declare Function GetDeviceCaps Lib ""gdi32"" (ByVal hdc As Long, _ ByVal nIndex As Long) As Long Declare Function GetDC Lib ""user32"" (ByVal hwnd As Long) As Long Declare Function ReleaseDC Lib ""user32"" (ByVal hwnd As Long, _ ByVal hdc As Long) As Long Const HORZRES = 8 Const VERTRES = 10 Function ScreenResolution() Dim lRval As Long Dim lDc As Long Dim lHSize As Long Dim lVSize As Long lDc = GetDC(0&) lHSize = GetDeviceCaps(lDc, HORZRES) lVSize = GetDeviceCaps(lDc, VERTRES) lRval = ReleaseDC(0, lDc) ScreenResolution = lHSize & ""x"" & lVSize  Sub GetScreenSize() Dim aufl As String aufl = ScreenResolution() If aufl = ""800x600"" Then ActiveWindow.Zoom = 75 End If If aufl = ""1024x768"" Then ActiveWindow.Zoom = 125 End If " "Declare Function GetDeviceCaps Lib ""gdi32"" (ByVal hdc As Long, _ ByVal nIndex As Long) As Long Declare Function GetDC Lib ""user32"" (ByVal hWnd As Long) As Long Declare Function ReleaseDC Lib ""user32"" (ByVal hWnd As Long, _ ByVal hdc As Long) As Long Sub RésolutionEcran() Dim Pix As Long Pix = GetDC(0) MsgBox ""La résolution est : "" & GetDeviceCaps(Pix, 8) _ & ""  "" & GetDeviceCaps(Pix, 10) & "" pixels"" ReleaseDC 0, Pix " "Sub Menueleiste_ein() With Application .ScreenUpdating = False .CommandBars(""toolbar list"").Enabled = True .CommandBars(""Worksheet Menu Bar"").Enabled = True .CommandBars(""Cell"").Enabled = True .DisplayFormulaBar = False .DisplayStatusBar = False .DisplayFullScreen = False End With With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True .DisplayWorkbookTabs = True .DisplayHeadings = True .WindowState = xlMaximized End With  Sub Menueleiste_aus() With Application .ScreenUpdating = False .CommandBars(""toolbar list"").Enabled = False .CommandBars(""Worksheet Menu Bar"").Enabled = False .CommandBars(""Cell"").Enabled = False .DisplayFormulaBar = True .DisplayStatusBar = True .DisplayFullScreen = True End With With ActiveWindow .DisplayHorizontalScrollBar = False .DisplayVerticalScrollBar = False .DisplayWorkbookTabs = False .DisplayHeadings = False .WindowState = xlMaximized End With " "Sub ayikla() For x = 1 To [a65536].End(3).Row d = Split(Cells(x, 1))  For Each elem In d If InStr(elem, ""@"") Then a = a + 1 Sheets(""sayfa2"").Cells(a, 1) = Trim(Replace(Replace(Replace(elem, "","", """"), ""email:"", """"), Chr(160), """")) End If  Next elem Next x  Sheets(""sayfa2"").Select " "Sub Email() ActiveWorkbook.SendMail Recipients:=""pir@yahoo.com"" " "Sub HyperlinkMitEmailEinfuegen()  Range(""A1"").Select  ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= ""mailto:machero@aol.com""  Sub HyperlinkAktivieren() Range(""A1"").Select Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True " "Tüm sayfadaki en son hücreyi isterseniz aşağıdaki kodu deneyin.  Sub ensonagit() Sheets(""sayfa2"").Select Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Select " "Sub test_A() Colonne = Left$(ActiveCell.Address(0, 0), (ActiveCell.Column < 27) + 2) If Colonne = ""A"" Then MsgBox ""Je lance la macro ici"" Else MsgBox Colonne End If " "Sub LetzteZelle() Rows.SpecialCells(xlCellTypeLastCell).Rows.Activate " "Function pir(Mahmut) For I = 0 To Len(Mahmut)  1 Verkehrt = Verkehrt & Mid(Mahmut, _ Len(Mahmut)  I, 1)  Next I pir = Right(Mahmut, InStr(1, _  Verkehrt, "" "", 0)) " "Sub AnzahlVerwendeteZeilen() i = ActiveSheet.UsedRange.Rows.Count MsgBox i " "Sub LastRow() MsgBox Cells.Find("""", searchdirection:=xlPrevious).Row " "Çalışma Sayfasındaki en son dolu hücreden üstteki boş hücreleri siler Sub DeleteEmptyRows() LastRow = ActiveSheet.UsedRange.Row  1 + _ ActiveSheet.UsedRange.Rows.Count Application.ScreenUpdating = False For r = LastRow To 1 Step 1 If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete Next r  SATIR BOŞLUKLARINI DOLDURUR(sayfada) Private Sub CommandButton8_Click() LastRow = ActiveSheet.UsedRange.Row  1 + _ ActiveSheet.UsedRange.Rows.Count Application.ScreenUpdating = False For r = LastRow To 1 Step 1 If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete Next r  " "Soruyu sorduktan sonra tesadüfen Sayın Raider'in daha önce yazmış olduğu aşağıdaki kodu buldum ve işimi gördü.  Kod:  Private Sub Worksheet_Activate() Cells(65536, 2).End(xlUp).Select   " "Private Sub Workbook_Open() MsgBox ActiveWorkbook.BuiltinDocumentProperties(12).Name & ActiveWorkbook.BuiltinDocumentProperties(12) " "Sub der() Range(""A1"").Select If Cells(ActiveCell.Row + 1, ActiveCell.Column).Value <> """" Then ActiveCell.End(xlDown).Select End If " "Sub ResetEnterReturn()  Application.OnKey ""{ENTER}""  Application.OnKey ""~""  " "Sub Auto_Close() Application.MoveAfterReturn = True  " "Private Sub Worksheet_Activate() Application.OnKey ""{ENTER}"", ""Macro1"" Application.OnKey ""~"", ""Macro1"" " "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row > 4 Then Cells(1, Target.Column + 1).Activate  " "ESC tuşuyla Userformunuzu kapatabilirsiniz Kod: Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)  If KeyCode = 27 Then Unload Me  " "Sub formulyenile() Application.ScreenUpdating = False Range(""e2"").Select Range(""e2"").Formula = ""=ROUND(AVERAGE(RC[4]:RC[1]),0)"" Range(""e2"").Select Selection.AutoFill Destination:=Range(""e2:e50""), Type:=xlFillDefault Range(""e2:e50"").Select Selection.AutoFill Destination:=Range(""e2:e50""), Type:=xlFillDefault Range(""e2"").Select Application.ScreenUpdating = True " "Sub a() For i = 1 To 100 If Cells(i, 1) <> Cells(i, 3) Then Cells(i, 3).EntireRow.Delete End If Next " "Sub Dialog_40() Application.Dialogs(xlDialogInsertNameLabel).Show " ActiveSheet.StandartWidth=25  >Etkin işlem sayfasının genişliğini 25 yapar. "Sub Dialog_01() Application.Dialogs(xlDialogActivate).Show " "UserForm'a CommandButton1 nesnesini ilave ederseniz;  Kod: Private Sub ComboBox1_Change()  [AA1] = ComboBox1.Text   Private Sub CommandButton1_Click()  MsgBox Format(Evaluate(""SUMIF(C8:C1000,AA1,E8:E1000)""), ""###,###"")   TextBox2' e girdiğin tarih de dikkate alınsın istiyorsan;  Kod: Private Sub ComboBox1_Change()  On Error Resume Next  [AA1] = ComboBox1.Text  [AA2] = CDate(TextBox2.Text) + 0  ' Private Sub TextBox2_Change()  On Error Resume Next  [AA1] = ComboBox1.Text  [AA2] = CDate(TextBox2.Text) + 0  ' Private Sub CommandButton1_Click()  MsgBox Format(Evaluate(""SUMPRODUCT((B8:B998=AA2)(C8:C998=AA1)(E8:E998))""), ""###,###"")   " "Sub mesaj() YesNo = MsgBox(""Bu makroyu çalıştırmak istiyor musunuz?"", vbYesNo + vbCritical, ""Soru Başlığı"") Select Case YesNo Case vbYes MsgBox ""Makro çalıştırıldı."", vbMsgBoxRtlReading Case vbNo MsgBox ""Makroyu iptal ettiniz."", vbMsgBoxSetForeground End Select " "Size iki çözüm ; 1.cisi activ sayfada active hucre en son veri girdiğiniz hucre ise Kod: Sub Cozum1() Dim i As Integer Set Sliste = Worksheets(""liste"") For i = 2 To 30000 If Sliste.Range(""A"" & i).Value = Empty Then Sliste.Range(""A"" & i).Value = ActiveCell.Value Sliste.Range(""B"" & i).Value = ActiveCell.Offset(0, 1).Value Exit Sub End If Next i   2.cisi ise Activ sayfada activ hucra neresi olursa olsun.en son veri girişi yaptığınız hucredeki veriyi liste sayfasına aktarır. Kod: Sub Cozum2() Dim iliste, satir As Integer Dim hucre As Range Set Sliste = Worksheets(""liste"") For iliste = 2 To WorksheetFunction.CountA(Range(""A1:A65000"")) For Each hucre In Range(""A1:A65000"").Cells If hucre.Value = Empty Then satir = hucre.Row  1 GoTo cik End If Next hucre cik: If Sliste.Range(""A"" & iliste).Value = Empty Then Sliste.Range(""A"" & iliste).Value = ActiveSheet.Cells(satir, 1).Value Sliste.Range(""B"" & iliste).Value = ActiveSheet.Cells(satir, 2).Value Exit Sub End If Next iliste   Burada listeniz a ve b surunlarında olduğunu ve devamlı şekilde liste sayfasına aktaracağınızı hesap ederek yapılmıştır" "Sub Killfile() Dim MyFile As String 'This line of code is optional On Error Resume Next 'On hitting errors, code resumes next code MyFile = ""c:\Yeni.xls"" Kill MyFile " "Sub b() Open ""c:/uludağ/no"" For Random As #4 Dim s As Integer Dim h As String Get 4, 1, s u = 2 For i = 2 To s Get 4, i, h Dim kitap As Excel.Application Set kitap = CreateObject(""Excel.Application"") kitap.Workbooks.Open (""c:\uludağ\"" & h & "".xls"") kitap.Visible = False Sheets(1).Cells(u, 2).Value = kitap.Sheets(9).Cells(2, 2).Value Sheets(1).Cells(u, 3).Value = kitap.Sheets(9).Cells(2, 3).Value For w = 1 To 9 If kitap.Sheets(9).Cells(w + 1, 4) = """" Then u = u + w: GoTo 10 Sheets(1).Cells(u + w  1, 1).Value = kitap.Sheets(9).Cells(2, 1).Value Sheets(1).Cells(u + w  1, 4).Value = kitap.Sheets(9).Cells(w + 1, 4) Sheets(1).Cells(u + w  1, 5).Value = kitap.Sheets(9).Cells(w + 1, 5) Sheets(1).Cells(u + w  1, 6).Value = kitap.Sheets(9).Cells(w + 1, 6) Sheets(1).Cells(u + w  1, 7).Value = kitap.Sheets(9).Cells(w + 1, 7) Sheets(1).Cells(u + w  1, 8).Value = kitap.Sheets(9).Cells(w + 1, 8) Sheets(1).Cells(u + w  1, 9).Value = kitap.Sheets(9).Cells(w + 1, 9) Sheets(1).Cells(u + w  1, 10).Value = kitap.Sheets(9).Cells(w + 1, 10) Next w 10 Next i Close 4 kitap.Quit Set kitap = Nothing " "Sub Passwortknacken() xlCrack  Private Function xlCrack() Dim wkb As Workbook Dim wks As Worksheet Dim txt As String Application.ScreenUpdating = False Set wkb = ActiveWorkbook Set wks = ActiveWorkbook.ActiveSheet txt = Application.Version If Left(txt, 1) <> 8 And Left(txt, 1) <> 9 Then Beep MsgBox ""Das AddIn ist nur unter XL8 und XL9 lauffähig!"" Exit Function End If Call wkbEncode(wkb) For Each wks In Worksheets If wks.ProtectContents Then Call wksEncode(wks) Next wks MsgBox prompt:=""Der Job wurde nach langer, harter Arbeit erledigt!"", _ Title:=""Fertig"" Application.ScreenUpdating = True  Private Function wksEncode(wks As Worksheet) On Error Resume Next With wks .Protect vbNullString, , , , True .Range(""IV65536"").Copy .Range(""IV65536"") .Unprotect vbNullString End With  Private Function wkbEncode(wkb As Workbook) On Error Resume Next With wkb .Protect vbNullString, True, True .Unprotect vbNullString End With " "Sub Kareler()  Dim i As Byte For i = 1 To WorksheetFunction.CountA(Range(""A:A"")) ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, Cells(i, 1).Value, Cells(i, 1).Value, Cells(i, 1).Value).Select Selection.Name = Cells(i, 1).Value & "" Nolu Kare ""  Next i  " "Sub Düğme1_Tıklat() [D1:E2].Copy sat = WorksheetFunction.CountA([A1:A65536]) + 1 Cells(sat, ""a"").PasteSpecial Application.CutCopyMode = False Range(""A1:A100"").Sort Key1:=Range(""A1""), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Range(""B1:B100"").Select Selection.Sort Key1:=Range(""B1""), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Range(""A1"").Select  " "Sub işlem() For x = 1 To 100 Cells(x, 3) = Cells(x, 1)  1  Cells(x, 2) Next  Sub başla() For x = 1 To Sheets.Count Sheets(x).Select Application.Run ""işlem"" Next  Sn.Danersin'e ait Kod.İşinizi Görecektir. Sub TRIMLE_BOSLUK_AL() Selection.CurrentRegion.Select Set xxx = Selection For Each x In xxx x.Activate ActiveCell.Value = Application.WorksheetFunction.Clean(ActiveCell.Value) ActiveCell.Value = Application.WorksheetFunction.TRIM(ActiveCell.Value) Next x Selection.CurrentRegion.Select With Selection .WrapText = False End With Range(""A1"").Select  " "Aşağıdaki kodları excel sayfasında bi commandbutton oluşturup o butona atama işlemini yapıyoruz. commandbutona tıkladığımızda yanıp sönme işlemi c1 hücresinde çalışmaya başlayacaktır.Ben C1 hücresini seçmiştim. Siz istediğiniz hücreyi seçebilirsiniz tabi ki. Sub YANIPSON() Dim durum As Boolean, i As Single Do While (True) If durum=True Then Range(""C1"").Select With Selection.Interior .ColorIndex=3 .Pattern=xlSolid End With For i =0 To 2500 DoEvents Next durum=False Else Range(""C1"").Select Selection.Interior.ColorIndex=xlNone For i=0 To 2500 DoEvents Next durum=True End If Loop " "Sub auto_open() Application.ScreenUpdating = False For i = 1 To Application.CommandBars.Count Application.CommandBars(i).Enabled = False Next i Application.ScreenUpdating = True  ' Sub auto_close()  Application.ScreenUpdating = False For i = 1 To Application.CommandBars.Count Application.CommandBars(i).Enabled = 1 Next i  Application.ScreenUpdating = True " "Neden Api arıyorsunuz anlayamadım. Bu işlem windows script ile kolayca yapılabilir. Örneğin aşağıdaki kod aktif dosyanın masa üstünde kısayolunu oluşturacaktır.  visual basic kodu: Sub Desktopkisayol() Set kisayol = CreateObject(""WScript.Shell"") yol = kisayol.SpecialFolders(""Desktop"") Set deg = kisayol.CreateShortcut(yol & ""\"" & ActiveWorkbook.Name & "".lnk"") With deg .TargetPath = ActiveWorkbook.FullName .Save End With Set kisayol = Nothing MsgBox ""Kısayol oluşturuldu""  " "Sub Dirxls() Shell ""command.com /c dir c:\.xls /W/O/S >C:\ajeter\dirxls.xls"", vbHide  Sub Dirxls2() Shell ""command.com /c dir c:\.xls /s/b >C:\ajeter\dirxls.xls"", vbHide " "Sub Auto_Close() Dim f As String, r As Integer f = ThisWorkbook.Sheets(1).Cells(1, 1).Value If f = """" Then  f = Application.GetSaveAsFilename(fileFilter:=""Excel Workbook(.xls), .xls"") If f = False Then Exit Sub End If End If r = ThisWorkbook.Sheets(1).Cells(1, 1).Characters.Count If ThisWorkbook.Sheets(1).Cells(1, 1).Characters(r  3).Text <> "".xls"" Then  f = f & "".xls"" End If ‘ ThisWorkbook.SaveAs Filename:=f " "‘Bu program CDRom ismini kontrol ediyor ve tutmuyorsa dosya açmayı iptal ediyor. ’CDRom a özel bir isim vermemiş iseniz, CDRom dahi herhangi bir dosyayıda kontrol ettirebilirsiniz, eğer o dosya ‘yoksa program kapanır. Sub auto_open() Dim fso, drv, cdr Set fso = CreateObject(""Scripting.FileSystemObject"") For Each drv In fso.Drives  If drv.driveType = 4 Then Set cdr = drv Next If cdr.volumename <> ""CD nin adı"" Then  MsgBox ""Lütfen program cd sini takmadan programı çalıştırmayınız""  ThisWorkbook.Close False End If " "Sub deplace() Name ""c:\Test.xls"" As ""c:\aaa\Test.xls"" " "Bunu sadece Auto_Pen le değil de Workbook_Activate içersine ve dosyanızın kapanış kısmına yazacağınız iki kodla mümkün bende bu kodları gene bu sitede bulmuş ve kendi dosyama uyarlamıştım.DANISMAN yazan yerlere kendi dosyanızın adını yazmanız gerekiyor.If (Date  CDate(d)) > 30 Then satırındaki 30 yerine gün olarak kaç gün istiyorsanız onu yazabilirsiniz. Private Sub Workbook_Activate() On Local Error Resume Next Application.Visible = False 'Excel Uygulamasını görünmez yap Dim d, x, y d = GetSetting(""DANISMAN"", ""Ayarlar"", ""Ilk Giris"", """") If d = """" Then SaveSetting ""DANISMAN"", ""Ayarlar"", ""Ilk Giris"", Date Else If (Date  CDate(d)) > 30 Then MsgBox (""Programin Demo Süresi dolmustur.Uzatmak Için EMail adresine Not mesaj atabilirsiniz"") DoCmd.Close Application.Quit Else x = GetSetting(""DANISMAN"", ""Ayarlar"", ""Son Çikis Tarihi"", """") If x = """" Then 'End Else If CVDate(x) > Date Then MsgBox (""Programin Deneme Süresi Doldu Lütfen Israr Etmeyin"") DoCmd.Close Else y = GetSetting(""DANISMAN"", ""Ayarlar"", ""Son Çikis Saati"", """") If (CVDate(x) = Date) And (CVDate(y) > Time) Then MsgBox (""Programin Deneme Süresi Doldu Lütfen Israr Etmeyin"") DoCmd.Close End If End If x = GetSetting(""DANISMAN"", ""Ayarlar"", ""Sayi"", ""1"") MsgBox (""Programi"" & x & "". defa çalistiriyorsunuz."") SaveSetting ""DANISMAN"", ""Ayarlar"", ""Sayi"", x + 1 End If End If End If siparisfrm.Show  Benim çıkış için kullandığım ;Userform kapatıldığında dosyayı kapatıyor,bu arada ilgili dosyaya çıkış tarihini ve saatini kaydettiriyorum. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) SaveSetting ""DANISMAN"", ""Ayarlar"", ""Son Çikis Tarihi"", Date 'Danışman dosyasının çıkış tarihi SaveSetting ""DANISMAN"", ""Ayarlar"", ""Son Çikis Saati"", Time 'Danışman dosyasının çıkış saati Application.Visible = True 'Excel Ara yüzü görünür Yap Application.Quit 'Excel Uygulamasından Komple Çık " "Sub auto_open() Static sayac As Integer Do If sayac = 3 Then ThisWorkbook.Close False Else If InputBox(""şifreyi girin"") = ""sifre"" Then GoTo devam Else sayac = sayac + 1 End If End If Loop devam:  " "Option Explicit Sub GetFonts() Dim Fonts Dim x As Integer x = 1 Set Fonts = Application.CommandBars.FindControl(ID:=1728) On Error Resume Next Do Cells(x + 1, 1) = Fonts.List(x) If Err Then Exit Do x = x + 1 Loop On Error GoTo 0 Range(""A1"").FormulaR1C1 = ""=""""Font List = """" & COUNTA(R[1]C:R["" & x  1 & ""]C)"" With Range(""A1"") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Name = ""Arial"" .Font.FontStyle = ""Bold"" .Font.Size = 10 .Font.ColorIndex = 5 .Interior.ColorIndex = 15 End With Columns(""A:A"").EntireColumn.AutoFit Set Fonts = Nothing " "Sub ShowInstalledFonts() Const StartRow As Integer = 4 Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer fontSize = 0 fontSize = Application.InputBox(""Enter Sample Font Size Between 8 And 30"", _ ""Select Sample Font Size"", 12, , , , , 1) If fontSize = 0 Then Exit Sub If fontSize < 8 Then fontSize = 8 If fontSize > 30 Then fontSize = 30 Set FontNamesCtrl = Application.CommandBars(""Formatting"").FindControl(ID:=1728) ' If Font control is missing, create a temp CommandBar If FontNamesCtrl Is Nothing Then  Set FontCmdBar = Application.CommandBars.Add(""TempFontNamesCtrl"", _ msoBarFloating, False, True)  Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728) End If Application.ScreenUpdating = False fontCount = FontNamesCtrl.ListCount Workbooks.Add ' list font names in column A and font example in column B For i = 0 To FontNamesCtrl.ListCount  1  fontName = FontNamesCtrl.List(i + 1)  Application.StatusBar = ""Listing font "" & _ Format(i / (fontCount  1), ""0 %"") & "" "" & _ fontName & ""...""  Cells(i + StartRow, 1).Formula = fontName  With Cells(i + StartRow, 2) tFormula = ""abcdefghijklmnopqrstuvwxyz"" If Application.International(xlCountrySetting) = 47 Then tFormula = tFormula & ""æøå"" End If tFormula = tFormula & UCase(tFormula) tFormula = tFormula & ""1234567890"" .Formula = tFormula .Font.Name = fontName  End With Next i Application.StatusBar = False If Not FontCmdBar Is Nothing Then FontCmdBar.Delete Set FontCmdBar = Nothing Set FontNamesCtrl = Nothing ' add heading Columns(1).AutoFit With Range(""A1"")  .Formula = ""Installed fonts:""  .Font.Bold = True  .Font.Size = 14 End With With Range(""A3"")  .Formula = ""Font Name:""  .Font.Bold = True  .Font.Size = 12 End With With Range(""B3"")  .Formula = ""Font Example:""  .Font.Bold = True  .Font.Size = 12 End With With Range(""B"" & StartRow & "":B"" & _  StartRow + fontCount)  .Font.Size = fontSize End With With Range(""A"" & StartRow & "":B"" & _  StartRow + fontCount)  .VerticalAlignment = xlVAlignCenter End With Range(""A4"").Select ActiveWindow.FreezePanes = True Range(""A2"").Select ActiveWorkbook.Saved = True  " "VB excel bağlantısı gerçekleştirenlere : Tools > Protection > Protect and Shared Workbook : Protect Shared Workbook = Sharing with track changes , seçeneği aktif edilirse Aynı dosyaya birden çok kullanıcı Read Only olmadan bağlanabilir ve Save edildiği anda diğer kullanıcıların Save ettikleri görülebilir" "Abs Access Alias And Any AppActivate Append ArgName Array As Asc Atn Attributes B Base Beep BF Binary Blue Boolean Buttons ByRef ByVal Call Case CBool CCur CDate CDbl CDecl Character CharCode ChDir ChDrive Chr CInt Class CLng Close Color Compare Const Constant Context Conversion Cos CreateObject CSng CStr CurDir Currency CVar CVDate CVErr Date Date DateSerial DateValue Day Debug Declare Default DefBool DefCur DefDate DefDbl DefInt DefLng DefObj DefSng DefStr DefVar Destination Dim Dir Do DoEvents Double Drive Each Else ElseIf Empty End EndIf EOF Eqv Erase Erl Err Error Exit Exp Explicit Expression F False FileAttr FileCopy FileDateTime FileLen FileNumber Fix For Format FreeFile Function Get GetAttr GetObject Global GoSub GoTo Green HelpFile Hex Hour If IMEStatus Imp In Input InputB InputBox InStr InStrB Int Integer Is IsArray IsDate IsEmpty IsError IsMissing IsNull IsNumeric IsObject Kill LBound LCase Left LeftB Len LenB Length Let Lib Like Line Loc Local Lock LOF Log Long Loop LSet LTrim MacID MacScript Mid MidB Minute MkDir Mod Module Month MsgBox Name Next Not Nothing Now Null Number Object Oct Of On Open Option Optional Or Output ParamArray Path PathName Preserve Print Private Prompt Prompt Property Public Put Random Randomize Read Red ReDim Rem Reset Resume Return ReturnType RGB Right RightB RmDir Rnd RSet RTrim Script Second Seek Select SendKeys Set SetAttr Sgn Shared Shell Sin Single Source Space Spc Sqr Static Step Stop Str StrComp StrConv Strict String String Sub Tab Tan Text Then Time Timer TimeSerial TimeValue Title To Trim True Type TypeName UBound UCase Unknown Unlock Until Val Variant VarName VarType vbAbort vbAbortRetryIgnore vbApplicationModal vbArchive vbArray vbBoolean vbCancel vbCritical vbCurrency vbDataObject vbDate vbDefaultButton1 vbDefaultButton2 vbDefaultButton3 vbDirectory vbDouble vbEmpty vbError vbExclamation vbHidden vbHiragana vbIgnore vbInformation vbInteger vbKatakana vbLong vbLowerCase vbNarrow vbNo vbNormal vbNull vbObject vbOK vbOKCancel vbOKOnly vbProperCase vbQuestion vbReadOnly vbRetry vbRetryCancel vbSingle vbString vbSystem vbSystemModal vbUpperCase vbVariant vbVolume vbWide vbYes vbYesNo vbYesNoCancel Wait WeekDay Wend Where While Width WindowStyle With Write Xor XPos Year YPos ' Accelerator AccessMode Action Activate ActivateMicrosoftApp ActivateNext ActivatePrevious ActiveCell ActiveChart ActiveDialog ActiveMenuBar ActivePane ActivePrinter ActiveSheet ActiveWindow ActiveWorkbook Add AddChartAutoFormat AddCustomList AddFields AddIn AddIndent AddIns AddItem AddMenu AddReplacement Address AddressLocal AddToTable AddVertex AdvancedFilter After AlertBeforeOverwriting Alignment AltStartupPath AlwaysSuggest Amount App Appearance AppendLast Application ApplyDataLabels ApplyNames ApplyOutlineStyles Arc Arcs Area Area3DGroup AreaGroup AreaGroups Areas Arg0 Arg1 Arg10 Arg11 Arg12 Arg13 Arg14 Arg15 Arg16 Arg17 Arg18 Arg19 Arg2 Arg20 Arg21 Arg22 Arg23 Arg24 Arg25 Arg26 Arg27 Arg28 Arg29 Arg3 Arg30 Arg31 Arg4 Arg5 Arg6 Arg7 Arg8 Arg9 Arrange ArrangeStyle ArrowHeadLength ArrowHeadStyle ArrowHeadWidth ArrowNumber AskToUpdateLinks Author AutoComplete AutoCorrect AutoFill AutoFilter AutoFilterMode AutoFit AutoFormat AutoLoad Automatic AutomaticStyles AutoOutline AutoPage AutoScaling AutoSize AutoText AutoUpdate Axes Axis AxisBetweenCategories AxisGroup AxisObj AxisTitle Background Backward Bar3DGroup BarGroup BarGroups BasedOn BaseField BaseItem BasicCode BCCRecipients Before BlackAndWhite Bold Border BorderAround Borders Bottom BottomMargin BottomRightCell BringToFront Build BuiltIn BuiltinDocumentProperties BuiltInFace Button Buttons ButtonText By ByRow Calculate CalculateBeforeSave Calculation Caller Cancel CancelButton CanPlaySounds CanRecordSounds CapitalizeNamesOfDays Caption Category CategoryLabels CategoryLocal CategoryNames CategoryTitle CCRecipients Cell Cell1 Cell2 CellDragAndDrop Cells CenterFooter CenterHeader CenterHorizontally CenterVertically Centimeters CentimetersToPoints ChangeFileAccess ChangeLink ChangeScenario ChangingCell ChangingCells Channel Characters Chart ChartArea ChartGroup ChartGroups ChartObject ChartObjects Charts ChartSize ChartTitle ChartWizard ChartWizardDisplay CheckBox CheckBoxes Checked CheckSpelling ChildField ChildItems CircularReference ClassType Clear ClearArrows ClearContents ClearFormats ClearNotes ClearOutline ClipboardFormats Close Closed Collate Color ColorButtons ColorIndex ColorPalette Colors Column Column3DGroup ColumnAbsolute ColumnDifferences ColumnFields ColumnGrand ColumnGroup ColumnGroups ColumnIndex ColumnInput ColumnLevels ColumnOffset ColumnRange Columns ColumnSize ColumnWidth Comma CommandUnderlines Comments Comparison ConflictResolution ConsecutiveDelimiter Consolidate ConsolidationFunction ConsolidationOptions ConsolidationSources Constants ConstrainNumeric Container ContainsBIFF ContainsPICT ContainsRTF ContainsVALU Contents Convert Converter ConvertFormula Copies Copy CopyFace CopyFile CopyFromRecordset CopyObjectsWithCells CopyPicture CopyToRange Corners Count CreateBackup CreateLinks CreateNames CreatePublisher CreateSummary Creator Criteria1 Criteria2 CriteriaRange Crosses CrossesAt CrtBorder CrtInterior CurrentArray CurrentPage CurrentRegion Cursor CustomDictionary CustomDocumentProperties CustomListCount Cut CutCopyMode Data DataBodyRange DataEntryMode DataFields DataLabel DataLabelRange DataLabels DataRange DataSeries DataSeriesIn DataSheet DataType Date Date1904 DDEAppReturnCode DDEExecute DDEInitiate DDEPoke DDERequest DDETerminate Default DefaultButton DefaultFilePath Delete DeleteChartAutoFormat DeleteCustomList DeleteNumberFormat DeleteReplacement Delimiter Delivery Dependents DepthPercent Description Deselect Destination DestName Dialog DialogBox DialogFrame Dialogs DialogSheet DialogSheets DirectDependents Direction DirectPrecedents DismissButton Display3DShading DisplayActiveCell DisplayAlerts DisplayAsIcon DisplayAutomaticPageBreaks DisplayBlanksAs DisplayClipboardWindow DisplayDrawingObjects DisplayEquation DisplayExcel4Menus DisplayFormat DisplayFormula DisplayFormulaBar DisplayFormulas DisplayFullScreen DisplayGridlines DisplayHeadings DisplayHorizontalScrollBar DisplayInfoWindow DisplayNames DisplayNote DisplayNoteIndicator DisplayOutline DisplayProtection DisplayRecentFiles DisplayRightToLeft DisplayRSquared DisplayScrollBars DisplayStatusBar DisplayVerticalScrollBar DisplayWorkbookTabs DisplayZeros Document Documents DoubleClick DoughnutGroup DoughnutGroups DoughnutHoleSize Down DownBars DownloadNewMail Draft Drawing DrawingObject DrawingObjects Drawings DropDown DropDownLines DropDowns DropLines Duplicate EarliestTime EchoOn Edit Editable EditBox EditBoxes EditDirectlyInCell Edition EditionOptions EditionRef Elevation EnableAnimations EnableAutoComplete EnableAutoFilter EnableCancelKey Enabled EnableOutlining EnablePivotTable EnableTipWizard Enclosures End EndStyle EntireColumn EntireRow ErrorBar ErrorBars Evaluate Events Excel4IntlMacroSheet Excel4IntlMacroSheets Excel4MacroSheet Excel4MacroSheets ExclusiveAccess ExecuteExcel4Macro Explosion Extend External ExtraTitle Field FieldInfo File FileConverters FileFilter FileFormat Filename FillAcrossSheets FillDown FillLeft FillRight FillUp FilterIndex FilterMode Find FindFile FindNext FindPrevious FirstPageNumber FirstSliceAngle FitToPagesTall FitToPagesWide FixedDecimal FixedDecimalPlaces Floor Focus Font FontStyle FooterMargin Format FormatName Formula FormulaArray FormulaHidden FormulaLocal FormulaR1C1 FormulaR1C1Local Formulas Forward ForwardMailer FreezePanes From FromReferenceStyle FullName Function FunctionWizard Gallery GapDepth GapWidth GetCustomListContents GetCustomListNum GetOpenFilename GetSaveAsFilename Goal GoalSeek Goto Graph GridlineColor GridlineColorIndex Gridlines Group GroupBox GroupBoxes GroupBy GroupLevel GroupObject GroupObjects Groups HasArray HasAutoFormat HasAxis HasDataLabel HasDataLabels HasDropLines HasErrorBars HasFormula HasHiLoLines HasLegend HasLinks HasMailer HasMajorGridlines HasMenu HasMinorGridlines HasPassword HasRadarAxisLabels HasRoutingSlip HasSeriesLines HasShortcutKey HasTitle HasUpDownBars Header HeaderMargin Height HeightPercent Help HelpButton HelpContextID HelpFile Hidden HiddenFields HiddenItems Hide HiLoLines HorizontalAlignment IconFileName IconIndex IconLabel Id IgnoreReadOnlyRecommended IgnoreRelativeAbsolute IgnoreRemoteRequests IgnoreUppercase Import ImportChart ImportData Inches InchesToPoints Include IncludeAlignment IncludeBorder IncludeFont IncludeNumber IncludePatterns IncludeProtection Index IndexLocal InitialFilename InnerDetail InputBox InputType Insert InsertFile Installed Interactive Intercept InterceptIsAuto Interior International Intersect InvertIfNegative IsGap Italic Item Iteration Justify Key Key1 Key2 Key3 Keys Keywords Label LabelRange Labels LargeButtons LargeChange LargeScroll LatestEdition LatestTime Launch Left LeftColumn LeftFooter LeftHeader LeftMargin Legend LegendEntries LegendEntry LegendKey Length LibraryPath Line Line3DGroup LineGroup LineGroups Lines LineStyle Link LinkCombo LinkedCell LinkedObject LinkInfo LinkNumber Links LinkSources List ListArray ListBox ListBoxes ListCount ListFillRange ListHeaderRows ListIndex ListNames ListNum LocationInTable Locked LockedText LookAt LookIn Macro MacroOptions MacroType Mailer MailLogoff MailLogon MailSession MailSystem MajorGridlines MajorTickMark MajorUnit MajorUnitIsAuto MajorVersion MarkerBackgroundColor MarkerBackgroundColorIndex MarkerForegroundColor MarkerForegroundColorIndex MarkerStyle MatchByte MatchCase MathCoprocessorAvailable Max MaxChange MaxColumns MaximumScale MaximumScaleIsAuto MaxIterations MaxRows MemoryFree MemoryTotal MemoryUsed Menu MenuBar MenuBars MenuItem MenuItems Menus MenuText Merge Message Min MinimumScale MinimumScaleIsAuto MinorGridlines MinorTickMark MinorUnit MinorUnitIsAuto MinorVersion MinusValues Mode Module Modules MouseAvailable Move MoveAfterReturn MoveAfterReturnDirection MultiLine MultiSelect MultiUserEditing Name NameIsAuto NameLocal Names NavigateArrow NetworkTemplatesPath NewEnum NewName NewSeries NewWindow Next NextLetter Note NoteText Notify Number NumberFormat NumberFormatLinked NumberFormatLocal NumCategoryLabels NumSeriesLabels Object Offset OLEObject OLEObjects OLEType OmitBackground OmitColumn OmitRow OnAction OnCalculate OnData OnDoubleClick OnEntry OnKey OnRepeat OnSave OnSheetActivate OnSheetDeactivate OnTime OnUndo OnWindow Open OpenLinks OpenText OperatingSystem Operation Operator Option OptionButton OptionButtons Order Order1 Order2 Order3 OrderCustom OrganizationName Orientation Origin Other OtherChar Outline OutlineFont OutlineLevel Oval Ovals Overlap PageBreak PageBreaks PageField PageFields PageRange PageSetup Pane Panes PaperSize Parent ParentField ParentItem ParentItems ParentShowDetail ParentWorksheet Parse ParseLine Password PasswordEdit Paste PasteFace PasteSpecial Path PathSeparator Pattern PatternColor PatternColorIndex Period Periods Perspective PhoneticAccelerator Picture Pictures PictureType PictureUnit Pie3DGroup PieGroup PieGroups PivotField PivotFields PivotItem PivotItems PivotTable PivotTables PivotTableWizard Placement Play PlotArea PlotBy PlotOrder PlotVisibleOnly Point Points Position Post Precedents PrecisionAsDisplayed PrefixCharacter Preview Previous PreviousSelections PrintArea PrintGridlines PrintHeadings PrintNotes PrintObject PrintOut PrintPreview PrintQuality PrintTitleColumns PrintTitleRows PrintToFile Priority Procedure Prompt PromptForSummaryInfo Protect ProtectContents ProtectDrawingObjects Protection ProtectionMode ProtectScenarios ProtectStructure ProtectWindows Pushed Quit R1C1 RadarAxisLabels RadarGroup RadarGroups Range Range1 Range2 RangeSelection ReadOnly ReadOnlyRecommended Received Recipients Record RecordMacro RecordRelative Rectangle Rectangles Reference ReferenceStyle RefersTo RefersToLocal RefersToR1C1 RefersToR1C1Local RefersToRange RefreshDate RefreshName RefreshTable RegisteredFunctions RegisterXLL RelativeTo Remove RemoveAllItems RemoveItem RemoveSubtotal Repeat Replace Replacement ReplacementList ReplaceText Reply ReplyAll ReportType Reserved Reset ResetTipWizard Reshape Resize Resource Restore ResultCells ReturnReceipt ReturnWhenDone ReversePlotOrder RevisionNumber Right RightAngleAxes RightFooter RightHeader RightMargin Root Rotation RoundedCorners Route Routed RouteWorkbook RoutingSlip Row RowAbsolute Rowcol RowDifferences RowFields RowGrand RowHeight RowIndex RowInput RowLevels RowOffset RowRange Rows RowSize Run RunAutoMacros Save SaveAs SaveAsOldFileFormat SaveChanges SaveCopyAs Saved SaveData SaveLinkValues ScaleType Scenario Scenarios Schedule ScreenUpdating Scroll ScrollBar ScrollBars ScrollColumn ScrollRow ScrollWorkbookTabs SearchDirection SearchOrder Select Selected SelectedSheets Selection Semicolon SendDateTime Sender SendKeys SendMail SendMailer SendToBack Series SeriesCollection SeriesLabels SeriesLines SetBackgroundPicture SetDefaultChart SetEchoOn SetInfoDisplay SetLinkOnData Shadow Sheet SheetBackground Sheets SheetsInNewWorkbook Shift ShortcutKey ShortcutMenu ShortcutMenus Show ShowAllData ShowConflictHistory ShowDataForm ShowDependents ShowDetail ShowErrors ShowLegendKey ShowLevels ShowPages ShowPrecedents ShowRevisionHistory ShowToolTips Size SizeWithWindow SkipBlanks SmallChange SmallScroll Smooth Sort SortMethod SortSpecial SoundNote Source SourceData SourceName Sources SourceType Space SpecialCells Spinner Spinners Split SplitColumn SplitHorizontal SplitRow SplitVertical StandardFont StandardFontSize StandardHeight StandardWidth Start StartRow StartupPath Status StatusBar Step Stop Strikethrough String Structure Style Styles Subject SubscribeTo Subscript Subtotal Subtotals SubType Summary SummaryBelowData SummaryColumn SummaryRow Superscript SurfaceGroup SyncHorizontal SyncVertical Tab Table TableDestination TableName TableRange1 TableRange2 TabRatio Template TemplatesPath Text TextBox TextBoxes TextLocal TextQualifier TextToColumns ThisWorkbook TickLabelPosition TickLabels TickLabelSpacing TickMarkSpacing Time Title To ToAbsolute ToLeft Toolbar ToolbarButton ToolbarButtons Toolbars Top Topic TopLeftCell TopMargin TopRow ToRecipients ToReferenceStyle ToRight TotalLevels TotalList TowardPrecedent TrackStatus TransitionExpEval TransitionFormEntry TransitionMenuKey TransitionMenuKeyAction TransitionNavigKeys Transpose Trend Trendline Trendlines TwoInitialCapitals Type Underline Undo Ungroup Union Unique Unprotect Up UpBars Update UpdateFromFile UpdateLink UpdateLinks UpdateRemoteReferences UsableHeight UsableWidth UsedRange UserInterfaceOnly UserName UseRowColumnNames UserStatus UseStandardHeight UseStandardWidth Value Values ValueTitle VaryByCategories Verb Version Vertex VerticalAlignment Vertices Visible VisibleFields VisibleItems VisibleRange Volatile Wait Walls WallsAndGridlines2D Weight What Which WhichAddress Whole Width Window WindowNumber Windows WindowsForPens WindowState Word Workbook Workbooks Worksheet Worksheets WrapText WritePassword WriteReserved WriteReservedBy WriteResPassword X1 X2 xl24HourClock xl3DArea xl3DBar xl3DColumn xl3DEffects1 xl3DEffects2 xl3DLine xl3DPie xl3DSurface xl4DigitYears xlA1 xlAbove xlAbsolute xlAbsRowRelColumn xlAccounting1 xlAccounting2 xlAccounting3 xlAccounting4 xlAdd xlAddIn xlAll xlAllAtOnce xlAllExceptBorders xlAlternateArraySeparator xlAnd xlArea xlAscending xlAutoActivate xlAutoClose xlAutoDeactivate xlAutoFill xlAutomatic xlAutomaticUpdate xlAutoOpen xlAverage xlAxis xlBar xlBelow xlBIFF xlBitmap xlBlanks xlBMP xlBoth xlBottom xlBottom10Items xlBottom10Percent xlBuiltIn xlButton xlByColumns xlByRows xlCancel xlCap xlCascade xlCategory xlCenter xlCenterAcrossSelection xlCGM xlChangeAttributes xlChart xlChart4 xlChartAsWindow xlChartInPlace xlChartSeries xlChartShort xlChartTitles xlChecker xlChronological xlCircle xlClassic1 xlClassic2 xlClassic3 xlClipboard xlClipboardFormatBIFF xlClipboardFormatBIFF2 xlClipboardFormatBIFF3 xlClipboardFormatBIFF4 xlClipboardFormatBinary xlClipboardFormatBitmap xlClipboardFormatCGM xlClipboardFormatCSV xlClipboardFormatDIF xlClipboardFormatDspText xlClipboardFormatEmbeddedObject xlClipboardFormatEmbedSource xlClipboardFormatLink xlClipboardFormatLinkSource xlClipboardFormatLinkSourceDesc xlClipboardFormatMovie xlClipboardFormatNative xlClipboardFormatObjectDesc xlClipboardFormatObjectLink xlClipboardFormatOwnerLink xlClipboardFormatPICT xlClipboardFormatPrintPICT xlClipboardFormatRTF xlClipboardFormatScreenPICT xlClipboardFormatStandardFont xlClipboardFormatStandardScale xlClipboardFormatSYLK xlClipboardFormatTable xlClipboardFormatText xlClipboardFormatToolFace xlClipboardFormatToolFacePICT xlClipboardFormatVALU xlClipboardFormatWK1 xlClosed xlCodePage xlColor1 xlColor2 xlColor3 xlColumn xlColumnField xlColumnHeader xlColumnItem xlColumns xlColumnSeparator xlColumnThenRow xlCombination xlCommand xlConsolidation xlConstants xlContents xlContinuous xlCopy xlCorner xlCount xlCountNums xlCountryCode xlCountrySetting xlCrissCross xlCross xlCSV xlCSVMac xlCSVMSDOS xlCSVWindows xlCurrencyBefore xlCurrencyCode xlCurrencyDigits xlCurrencyLeadingZeros xlCurrencyMinusSign xlCurrencyNegative xlCurrencySpaceBefore xlCurrencyTrailingZeros xlCustom xlCut xlDash xlDashDot xlDashDotDot xlDatabase xlDataField xlDataHeader xlDataItem xlDate xlDateOrder xlDateSeparator xlDay xlDayCode xlDayLeadingZero xlDBF2 xlDBF3 xlDBF4 xlDebugCodePane xlDecimalSeparator xlDefaultAutoFormat xlDelimited xlDescending xlDesktop xlDialogActivate xlDialogActiveCellFont xlDialogAddChartAutoformat xlDialogAddinManager xlDialogAlignment xlDialogApplyNames xlDialogApplyStyle xlDialogAppMove xlDialogAppSize xlDialogArrangeAll xlDialogAssignToObject xlDialogAssignToTool xlDialogAttachText xlDialogAttachToolbars xlDialogAttributes xlDialogAutoCorrect xlDialogAxes xlDialogBorder xlDialogCalculation xlDialogCellProtection xlDialogChangeLink xlDialogChartAddData xlDialogChartTrend xlDialogChartWizard xlDialogCheckboxProperties xlDialogClear xlDialogColorPalette xlDialogColumnWidth xlDialogCombination xlDialogConsolidate xlDialogCopyChart xlDialogCopyPicture xlDialogCreateNames xlDialogCreatePublisher xlDialogCustomizeToolbar xlDialogDataDelete xlDialogDataLabel xlDialogDataSeries xlDialogDefineName xlDialogDefineStyle xlDialogDeleteFormat xlDialogDeleteName xlDialogDemote xlDialogDisplay xlDialogEditboxProperties xlDialogEditColor xlDialogEditDelete xlDialogEditionOptions xlDialogEditSeries xlDialogErrorbarX xlDialogErrorbarY xlDialogExtract xlDialogFileDelete xlDialogFileSharing xlDialogFillGroup xlDialogFillWorkgroup xlDialogFilter xlDialogFilterAdvanced xlDialogFindFile xlDialogFont xlDialogFontProperties xlDialogFormatAuto xlDialogFormatChart xlDialogFormatCharttype xlDialogFormatFont xlDialogFormatLegend xlDialogFormatMain xlDialogFormatMove xlDialogFormatNumber xlDialogFormatOverlay xlDialogFormatSize xlDialogFormatText xlDialogFormulaFind xlDialogFormulaGoto xlDialogFormulaReplace xlDialogFunctionWizard xlDialogGallery3dArea xlDialogGallery3dBar xlDialogGallery3dColumn xlDialogGallery3dLine xlDialogGallery3dPie xlDialogGallery3dSurface xlDialogGalleryArea xlDialogGalleryBar xlDialogGalleryColumn xlDialogGalleryCustom xlDialogGalleryDoughnut xlDialogGalleryLine xlDialogGalleryPie xlDialogGalleryRadar xlDialogGalleryScatter xlDialogGoalSeek xlDialogGridlines xlDialogInsert xlDialogInsertObject xlDialogInsertPicture xlDialogInsertTitle xlDialogLabelProperties xlDialogListboxProperties xlDialogMacroOptions xlDialogMailLogon xlDialogMailNextLetter xlDialogMainChart xlDialogMainChartType xlDialogMenuEditor xlDialogMove xlDialogNew xlDialogNote xlDialogObjectProperties xlDialogObjectProtection xlDialogOpen xlDialogOpenLinks xlDialogOpenMail xlDialogOpenText xlDialogOptionsCalculation xlDialogOptionsChart xlDialogOptionsEdit xlDialogOptionsGeneral xlDialogOptionsListsAdd xlDialogOptionsTransition xlDialogOptionsView xlDialogOutline xlDialogOverlay xlDialogOverlayChartType xlDialogPageSetup xlDialogParse xlDialogPasteSpecial xlDialogPatterns xlDialogPivotFieldGroup xlDialogPivotFieldProperties xlDialogPivotFieldProperties xlDialogPivotFieldUngroup xlDialogPivotShowPages xlDialogPivotTableWizard xlDialogPivotTableWizard xlDialogPlacement xlDialogPrint xlDialogPrinterSetup xlDialogPrintPreview xlDialogPromote xlDialogProperties xlDialogProtectDocument xlDialogPushbuttonProperties xlDialogReplaceFont xlDialogRoutingSlip xlDialogRowHeight xlDialogRun xlDialogSaveAs xlDialogSaveCopyAs xlDialogSaveNewObject xlDialogSaveWorkbook xlDialogSaveWorkspace xlDialogScale xlDialogScenarioAdd xlDialogScenarioCells xlDialogScenarioEdit xlDialogScenarioMerge xlDialogScenarioSummary xlDialogScrollbarProperties xlDialogSelectSpecial xlDialogSendMail xlDialogSeriesAxes xlDialogSeriesOrder xlDialogSeriesX xlDialogSeriesY xlDialogSetBackgroundPicture xlDialogSetControlValue xlDialogSetPrintTitles xlDialogSetUpdateStatus xlDialogShareName xlDialogSheet xlDialogShowDetail xlDialogShowToolbar xlDialogSize xlDialogSort xlDialogSortSpecial xlDialogSplit xlDialogStandardFont xlDialogStandardWidth xlDialogStyle xlDialogSubscribeTo xlDialogSubtotalCreate xlDialogSummaryInfo xlDialogTable xlDialogTabOrder xlDialogTextToColumns xlDialogUnhide xlDialogUpdateLink xlDialogVbaInsertFile xlDialogVbaMakeAddin xlDialogVbaProcedureDefinition xlDialogView3d xlDialogWindowMove xlDialogWindowSize xlDialogWorkbookAdd xlDialogWorkbookCopy xlDialogWorkbookInsert xlDialogWorkbookMove xlDialogWorkbookName xlDialogWorkbookNew xlDialogWorkbookOptions xlDialogWorkbookProtect xlDialogWorkbookTabSplit xlDialogWorkbookUnhide xlDialogWorkgroup xlDialogWorkspace xlDialogZoom xlDiamond xlDIF xlDifferenceFrom xlDirect xlDisabled xlDistributed xlDivide xlDot xlDouble xlDoubleAccounting xlDoubleClosed xlDoubleOpen xlDoubleQuote xlDoughnut xlDown xlDownThenOver xlDownward xlDrawingObject xlDRW xlDXF xlEditionDate xlEntireChart xlEPS xlErrDiv0 xlErrNA xlErrName xlErrNull xlErrNum xlErrorHandler xlErrors xlErrRef xlErrValue xlExcel2 xlExcel2FarEast xlExcel3 xlExcel4 xlExcel4IntlMacroSheet xlExcel4MacroSheet xlExcel4Workbook xlExcelLinks xlExcelMenus xlExclusive xlExponential xlExtended xlExternal xlFill xlFillCopy xlFillDays xlFillDefault xlFillFormats xlFillMonths xlFillSeries xlFillValues xlFillWeekdays xlFillYears xlFilterCopy xlFilterInPlace xlFirst xlFitToPage xlFixedValue xlFixedWidth xlFloating xlFloor xlFormats xlFormula xlFormulas xlFreeFloating xlFullPage xlFunction xlGeneral xlGeneralFormatName xlGray16 xlGray25 xlGray50 xlGray75 xlGray8 xlGrid xlGridline xlGrowth xlGrowthTrend xlGuess xlHairline xlHGL xlHidden xlHide xlHigh xlHorizontal xlHourCode xlIBeam xlIcons xlImmediatePane xlIndex xlInfo xlInside xlInteger xlInterpolated xlInterrupt xlIntlAddIn xlIntlMacro xlJustify xlLandscape xlLast xlLastCell xlLeft xlLeftBrace xlLeftBracket xlLeftToRight xlLegend xlLightDown xlLightHorizontal xlLightUp xlLightVertical xlLine xlLinear xlLinearTrend xlList1 xlList2 xlList3 xlListSeparator xlLocalFormat1 xlLocalFormat2 xlLocalSessionChanges xlLogarithmic xlLogical xlLong xlLotusHelp xlLow xlLowerCaseColumnLetter xlLowerCaseRowLetter xlMacintosh xlMacrosheetCell xlManual xlManualUpdate xlMAPI xlMax xlMaximized xlMaximum XlmCode xlMDY xlMedium xlMetric xlMicrosoftAccess xlMicrosoftFoxPro xlMicrosoftMail xlMicrosoftPowerPoint xlMicrosoftProject xlMicrosoftSchedulePlus xlMicrosoftWord xlMin xlMinimized xlMinimum xlMinusValues xlMinuteCode xlMixed xlModule xlMonth xlMonthCode xlMonthLeadingZero xlMonthNameChars xlMove xlMoveAndSize xlMovingAvg xlMSDOS xlMultiply xlNarrow xlNext xlNextToAxis xlNo xlNoButtonChanges xlNoCap xlNoChange xlNoChanges xlNoDockingChanges xlNoDocuments xlNoMailSystem xlNoncurrencyDigits xlNone xlNonEnglishFunctions xlNormal xlNorthwestArrow xlNoShapeChanges xlNotes xlNotPlotted xlNotYetRouted xlNumber xlNumbers xlOff xlOLEEmbed xlOLELink xlOLELinks xlOn xlOneAfterAnother xlOpaque xlOpen xlOpenSource xlOr xlOtherSessionChanges xlOutside xlOverThenDown xlPageField xlPageHeader xlPageItem xlPaper10x14 xlPaper11x17 xlPaperA3 xlPaperA4 xlPaperA4Small xlPaperA5 xlPaperB4 xlPaperB5 xlPaperCsheet xlPaperDsheet xlPaperEnvelope10 xlPaperEnvelope11 xlPaperEnvelope12 xlPaperEnvelope14 xlPaperEnvelope9 xlPaperEnvelopeB4 xlPaperEnvelopeB5 xlPaperEnvelopeB6 xlPaperEnvelopeC3 xlPaperEnvelopeC4 xlPaperEnvelopeC5 xlPaperEnvelopeC6 xlPaperEnvelopeC65 xlPaperEnvelopeDL xlPaperEnvelopeItaly xlPaperEnvelopeMonarch xlPaperEnvelopePersonal xlPaperEsheet xlPaperExecutive xlPaperFanfoldLegalGerman xlPaperFanfoldStdGerman xlPaperFanfoldUS xlPaperFolio xlPaperLedger xlPaperLegal xlPaperLetter xlPaperLetterSmall xlPaperNote xlPaperQuarto xlPaperStatement xlPaperTabloid xlPaperUser xlPart xlPCT xlPCX xlPercent xlPercentDifferenceFrom xlPercentOf xlPercentOfColumn xlPercentOfRow xlPercentOfTotal xlPIC xlPICT xlPicture xlPie xlPivotTable xlPlaceholders xlPlotArea xlPLT xlPlus xlPlusValues xlPolynomial xlPortrait xlPower xlPowerTalk xlPrevious xlPrimary xlPrinter xlProduct xlPublisher xlPublishers xlR1C1 xlRadar xlReadOnly xlReadWrite xlReference xlRelative xlRelRowAbsColumn xlRight xlRightBrace xlRightBracket xlRoutingComplete xlRoutingInProgress xlRowField xlRowHeader xlRowItem xlRows xlRowSeparator xlRowThenColumn xlRTF xlRunningTotal xlScale xlScreen xlScreenSize xlSecondary xlSecondCode xlSelect xlSemiautomatic xlSemiGray75 xlSendPublisher xlSeries xlShared xlShort xlShowLabel xlShowLabelAndPercent xlShowPercent xlShowValue xlSimple xlSingle xlSingleAccounting xlSingleQuote xlSolid xlSortLabels xlSortValues xlSquare xlStack xlStandardSummary xlStar xlStDev xlStDevP xlStError xlStretch xlStrict xlSubscriber xlSubscribers xlSubtract xlSum xlSYLK xlSyllabary xlTableBody xlTemplate xlText xlTextBox xlTextMac xlTextMSDOS xlTextPrinter xlTextValues xlTextWindows xlThick xlThin xlThousandsSeparator xlTIF xlTiled xlTimeLeadingZero xlTimeSeparator xlTitleBar xlToLeft xlToolbar xlToolbarButton xlTop xlTop10Items xlTop10Percent xlTopToBottom xlToRight xlTransparent xlTriangle xlUp xlUpdateState xlUpdateSubscriber xlUpperCaseColumnLetter xlUpperCaseRowLetter xlUpward xlUserResolution xlVALU xlValue xlValues xlVar xlVarP xlVertical xlVeryHidden xlVisible xlWait xlWatchPane xlWeekday xlWeekdayNameChars xlWhole xlWide xlWindows xlWizardDisplayAlways xlWizardDisplayDefault xlWizardDisplayNever xlWJ2WD1 xlWK1 xlWK1ALL xlWK1FMT xlWK3 xlWK3FM3 xlWKS xlWMF xlWorkbook xlWorkbookTab xlWorks2FarEast xlWorksheet xlWorksheet4 xlWorksheetCell xlWorksheetShort xlWPG xlWQ1 xlX xlXYScatter xlY xlYear xlYearCode xlYes xlZero XValues XYGroup XYGroups Y1 Y2 Zoom ZOrder" "Dim MyControl Sub Auto_Open() MyMenu Range(""A1"").Select  Sub MyMenu() On Error Resume Next If Not MyControl Is Nothing Then GoTo ResumeSub: Set MyControl = CommandBars.FindControl(Type:=msoControlComboBox, Tag:=""MyMenu"", Visible:=True) MyControl.Delete On Error GoTo 0 Set MyBar = Application.CommandBars(""standard"") Set NewCombo = MyBar.Controls.Add(Type:=msoControlComboBox) ResumeSub: With NewCombo .Clear .Text = ""Sayfa secin"" .Tag = ""MyMenu"" .Width = 150 .Text = ActiveSheet.Name For i = 1 To Worksheets.Count .AddItem Sheets(i).Name, i Next .DropDownLines = 5 .DropDownWidth = 90 .OnAction = ""MyCombo"" End With Set NewCombo = Nothing Set MyBar = Nothing Set MyControl = Nothing  Sub MyCombo() Set MyControl = CommandBars.FindControl(Type:=msoControlComboBox, Tag:=""MyMenu"", Visible:=True) Sheets(MyControl.Text).Select Set MyControl = Nothing  Sub DelMyMenu() Set MyControl = CommandBars.FindControl(Type:=msoControlComboBox, Tag:=""MyMenu"", Visible:=True) MyControl.Delete Set MyControl = Nothing  Sub Auto_Close() DelMyMenu " "Sayfada herhangi bir işlem yapmanıza izin vermez. sadece ""a1"" ile ""p40"" arasını gösterir. Menü aşağıyukarı ve sağasola scrollunu kullanmanıza 'izin vermez.  Option Explicit Private Sub Workbook_Open() Sheets(""Anasayfa"").Select Sheets(""Anasayfa"").Range(""a1:p40"").ClearContents Sheets(""Anasayfa"").ScrollArea = ""c5"" " "Sub yazdir() For a=1 To sheets.count sheets(a).printout Next " "Merhaba,C Diskinde Veri adlı bir klasör aç.Sen Masa üstü istemiştin ozaman c:\Windows\Desktop olarak aşağıdaki yolu değiştirirsin..Daha sonra Excelinde A1:K10 Veri aralığına gerekli bilgileri gir.Ve Modüle şu kodları yapıştır.  Kod: Sub txtaktar() MsgBox ""Dosya Hazırlanıyor"" Dim LastRowA As Integer Dim veri1 As String Dim veri2 As String Dim veri3 As String Dim veri4 As String Dim veri5 As String Dim veri6 As String Dim veri7 As String Dim veri8 As String Dim veri9 As String Dim veri10 As String Dim veri11 As String Dim veri12 As String Dim veri13 As String Dim veri14 As String Dim i As Integer Open ""C:\Veri\Deneme.txt"" For Output As #1 LastRowA = Cells(65536, 1).End(xlUp).Row For i = 1 To LastRowA veri1 = Cells(i, 1).Text veri2 = Cells(i, 2).Text veri3 = Cells(i, 3).Text veri4 = Cells(i, 4).Text veri5 = Cells(i, 5).Text veri6 = Cells(i, 6).Text veri7 = Cells(i, 7).Text veri8 = Cells(i, 8).Text veri9 = Cells(i, 9).Text veri10 = Cells(i, 10).Text veri11 = Cells(i, 11).Text veri12 = Cells(i, 12).Text veri13 = Cells(i, 13).Text veri14 = Cells(i, 14).Text  Print #1, veri1; "" ""; veri2; "" ""; veri3; "" ""; veri4; "" ""; veri5; "" ""; veri6; "" ""; veri7; "" ""; veri8; "" ""; veri9; "" ""; veri10; "" ""; veri11; "" ""; veri12; "" ""; veri13; "" ""; veri14 Next i Close #1 Sheets(""Sayfa1"").Select Range(""A1"").Select  Daha fazla veri aktarılacaksa 14'den sonra ilave edin..Ayrıca bu aktardığın verileri herhangi bir proğrama adapte edeceksen karakter sayılarına dikkat et.Kolay Gelsin. " Yapmanız gereken hazırladığınız UserForm'u ve ilişkili modülleri File menüsünden Export etmek ve daha sonra Visual Basic'i açarak Import etmeniz yeterli olacaktır. Artık File menüsünden Make Exe komutunu tıklayarak exe halinde derleyebilirsiniz. "Sub AddIns() Dim AI As AddIn i = 1 For Each AI In Application.AddIns  Range(""A"" & i) = AI.FullName  i = i + 1 Next " "Sub VersionBulucu() If Application.Version Like ""7"" Then MsgBox ""OfficeVersion = 95""  ElseIf Application.Version Like ""8"" Then MsgBox ""OfficeVersion = 97""  ElseIf Application.Version Like ""9"" Then MsgBox ""OfficeVersion = 2000""  ElseIf Application.Version Like ""10"" Then MsgBox ""OfficeVersion = XP""  Else MsgBox ""Version bulunamadı"", vbCritical End If " "Function fGetExcelVer() As Integer If Application.Version Like ""5"" Then fGetExcelVer = 5 ElseIf Application.Version Like ""7"" Then fGetExcelVer = 7 Else fGetExcelVer = 8 End If  Sub PerVersion() MsgBox Application.Version Select Case Left(Application.Version, 1) Case ""5"" MsgBox ""TEBRİKLER Excel 5"" Case ""7"" MsgBox ""TEBRİKLER Excel 7/95"" Case ""8"" MsgBox ""TEBRİKLER Excel 8/97"" Case Else MsgBox ""TEBRİKLER Excel Version"" End Select ThisWorkbook.Activate " "Sub assist() Application.Assistant.Visible = True Assistant.Animation = msoAnimationIdle Set SB = Assistant.NewBalloon SB.Animation = msoAnimationCheckingSomething SB.BalloonType = msoBalloonTypeButtons SB.Heading = "" M E R H A B A! ! ! "" SB.Text = _ ""Selam Mahmut KARDEŞ"" If SB.Show = msoBalloonButtonOK Then Assistant.Visible = False End If " If Cells(x, 4).Value = "AGR" or Cells(x, 4).Value = "DAL" Then Cells.MergeCells = False "Private Sub Worksheet_Change(ByVal Target As Range) Target = BH(Target)  Function BH(cevir) BH = Replace(cevir, ""i"", ""İ"") BH = Replace(BH, ""ı"", ""I"") BH = UCase(BH)  " "Sub SpecialCellMenu() Dim cb As CommandBar Set cb = Application.CommandBars(""Cell"") ' Set MenuObject = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True) MenuObject.Caption = ""Lovekiller Menu"" MenuObject.BeginGroup = True ' With MenuObject With .Controls.Add(Type:=msoControlButton, ID:=4) .Visible = True End With End With Set MenuObject = Nothing  " "Bir Excel dosyasını açtığınızda şöyle bir formül kullandıysanız bilirsiniz; dec2hex, hex2dec, dec2bin, bin2dec vs., bu formülleri kullanabilmek için Araçlar – Eklentiler içinden Toolpak Çözümleyicilerin seçilmiş olması gerekir. Toolpak eklentisi Program Files\Microsoft Office\Office10\Library\Analysis\ATPVBAEN.XLA dosyasıdır. Eğer daha önce verilen bu tip formülleri kullanmak isterseniz bu dosyanın Eklentiler içinde seçilmiş olması gerekir. Bu dosya ne işe yarar derseniz, mühendislik kategorisinde formülleri içeren makroların yazıldığı bir dosyadır. Dec2Hex formülü; desimal olarak verilen değer yada hücrenin hexadesimal olarak değerini aktif hücreye yazdığı bir formüldür. Excel’in kendisine ait diğer eklentileri ise; Arama sihirbazı, Çözücü eklentisi, İnternet yardımcısı VBA, Koşullu toplam sihirbazıdır. Eğer hex, dec, oct, bin sayı çevrimlerini kullandıysanız XOR da kullanmak istemişsinizdir fakat XOR olarak Excel ‘in bir formülü yoktur. Bu durumda siz kendiniz bu formülü yazabilir ve sayfa içerisinden rahatlıkla kullanabilirsiniz… BİR FORMÜL NASIL OLUŞTURULUR; Eğer Excel in formüllerini incelemişseniz şuna benzer şekilde olduklarını görürsünüz; =HEX2DEC(A1) ‘Yani A1 hücresinin içinde hex sayı var onu decimale çevir demek… =HEX2DEC(“ff”) ‘Üsteki formülle aynı fakat hücre erimi değil direkt olarak hex biçimli veri girilmiş…  =TOPLA(A1:A10) ‘A1den A10 a kadar tüm hücrelerin içerisindeki verileri topla demek… =TOPLA(A1;A5;A8;B13) ‘Üstteki formülle aynı fakat sadece A1 + A5 + A8 + B13 hücrelerini topla demek, erim olarak geniş karelik bir alan verilmemiş (“;” ve “:” ye dikkat!). =TOPLA(A1;125) ‘Üstteki formülle yine aynı fakat sadece A1 hücresi ile 125 sayısını topla demek. =DÜŞEYARA(A5;SHEET1!A1:C500;2;YANLIŞ) ‘Bu formülde ise aktif sayfanın A5 hücresine bak, sheet1 sayfasının A1:C500 eriminde A sütununda bunu ara; bulduğunda 2nci sütun (B sütununu)daki değeri yaz; eğer A5 ile bulduğun tamamıyla aynı ise demek…. Yukarıdaki formüllerde de görüleceği üzere; 1. Formül = ile başlar 2. Formülün kod kelimesi verilir 3. Formülde verilecek değerler parantez içinde girilir 4. Verilecek değer birden fazla ise aralarında noktalı virgül kullanılır 5. Değerler girilecek formülün ihtiyacına göre değişebilir (sayı olabilir, string olabilir, erim yada tek hücre olabilir vs.) Şimdi bu bilgilerin ışığında kendi formülümüzü oluşturalım… XOR fonksiyonunu yapan bir formül oluşturacağız. Verilen iki hücre yada erim içerisindeki verileri long olarak okuyacak ve birbirleriyle XORlayıp sonucu formül yazılan hücrede gösterecek.  1. Önce formülümüze bir isim verelim: XorDec (long tipindeki sayıların XOR u için kullanılacağından her zaman akılda kalması için anlamlı olmasına dikkat edilmeli ve kullanılamayacak isimlere dikkat!). 2. Girilecek (istenen) veriler ne olacak (önce tek hücreli sonra geniş erim olsun; A1 ile A2:A5 gibi) 3. Formül sonucu nasıl gösterilecek (formül girilen hücreye long tipinde sayı) FONKSİYON OLUŞTURMAK; Buraya kadar tamam, peki Formül nasıl yazılacak? Fark etmiş olacağınız üzere bu Basic’de de yazılan fonksiyonlara benzer. Giriş değerlerini alacak, üstünde işlem yapacak ve sonucunda bir değer döndürecek… Excel Visual Basic Düzenleyicisini (Araçlar – Makro altında yada Alt+F11 kısayol) açalım. Insert menüsünden bir Module ekleyelim, bu projemize yeni bir modül ekler.  Public Function xORdec(OneCell As Range, Optional MultipCells As Range) As Long Satırını yazalım. Bu Public olarak fonksiyonumuzu tanımlayacak, her taraftan kullanabileceğiz. OneCell isimli değişken bir erim, tercihsel olarak MultipCells olarak diğer erim fonksiyonla birlikte girecek ve fonksiyondan Long tipinde değer dönecek. ‘kullanacağımız değer tiplerini tanımlayalım Dim tmpH As Long ‘long tipinde tmpH değeri tüm XOR değerler için kullanılacak ‘hata tuzaklaması, eğer hata kontrolü yapılmazsa sonsuz döngü ve istenmeyen sonuçlar doğurabilir fonksiyonumuz ‘Local olarak tanımlanmasının nedeni function yada sublarda hata olursa buraya gelmemesi için On Local Error GoTo errTekHücre ‘Eğer hücre doluysa bunu geçici bir değere ata If OneCell Then tmpH = Val(OneCell) ‘geniş erim olarak tanımlanan çoklu hücrelerin değerini For Each Cell In MultipCells ‘xor la tmpH = tmpH Xor Val(Cell) Next ‘sonucu fonksiyona ata xORdec = tmpH Exit Function  errTekHücre: ‘hatayı temizle Err.Clear ‘gösterilecek sonuca ne yazılacak, hata nasıl gösterilecek; hata mesajı olarak biz burada 0 sonucunu döndürdük… xORdec = 0 ‘hata artık olduğu yerde kalsın On Local Error GoTo 0 Exit Function   Basitçe yazacağımız kodlar şimdilik bu kadar. Şimdi bunu kaydedelim. Bu açık Excel dosyasının içinde yer alacak. Bu dosyanın herhangi bir yerine şimdi formülümüzü yazalım =xordec(A3;A4:A10) ‘anlamı A3’den A10’a kadar hücrelerin içindekileri XORla demek eğer içinde hata oluşursa sonucunda 0 yazacak… EKLENTİ OLUŞTURMAK; Peki bu Excel dosyasını kaydedip, kapatıp başka bir Excel dosyası açarsak bu formülü kullanabilir miyiz? Bu formülü yazdığımız hücrede #AD? hata mesajı görünür. Bu formülün tanımlanamadığını gösterir. Bu sorun ise eklentilerle aşılır. Yani Excel her açıldığında belirlenen her eklenti Excel ile birlikte yüklenir.  Boş bir Excel dosyası açalım, Visual Basic Düzenleyicisini (Araçlar – Makro altında yada Alt+F11 kısayol) nden, Insert menüsünden bir Module ekleyelim. Yukarıda verilen kodları aynı şekilde yazalım.  Açmış olduğumuz çalışma kitabını farklı kaydet menüsü ile Microsoft Excel Eklentisi (.xla) kayıt türünde, örneğin BenimMakrolarım adıyla kaydedelim. Bu çalışma kitabı sürücü:\Documents and Settings\Kullanıcı Adı\Application Data\Microsoft\AddIns\ dizininde kaydedilecektir. Şimdi de AraçlarEklentiler menüsü açalım. Gözat butonuna basarak, yeni kaydetmiş olduğumuz eklentiyi işaretleyerek Tamam butonuna basalım. Kullanılabilir eklentiler: penceresinde bizim yazdığımız eklenti de görülecektir. Bunu işaretlediğimizde, her zaman Excel açılırken bizim eklentimizi de yükleyecektir. Artık yazdığımız fonksiyonu herhangi bir Excel çalışma sayfası içerisinden formül yazarmış gibi girerek kullanabiliriz… Şuna benzer bir fonksiyonu eklentinize eklerseniz, Public Function aX() As String aX = ""Adınız Soyadınız""  Çalışma sayfanızda =aX() yazdığınızda, adınız soyadınız hemen görünecektir… Görüleceği üzere, Excel in kolaylıklarını (özelliklerini) daha verimli kullanırsanız, Excel de sizi hamallıktan (rutin işlerden) kurtaracaktır" Application.CommandBars("Menü Adı").Visible = True 'False de gizler "ok o zaman şöyle yapalım  Kod: Sub sil() For i = Cells(65536, 1).End(xlUp).Row to 2 step 2  Rows(i).Delete Next i  not: denemedim.  edit:  son satırın tek olma ihtimaline karşın  Kod: Sub sil() z= Cells(65536, 1).End(xlUp).Row if z mod 2 = 1 then z = z 1 For i = z to 2 step 2  Rows(i).Delete Next i  " "Dim NextTime As Date Sub Flash()  NextTime = Now + TimeValue(""00:00:01"")  With ActiveWorkbook.Styles(""Flash"").Font If .ColorIndex = 2 Then .ColorIndex = 3 Else .ColorIndex = 2  End With  Application.OnTime NextTime, ""Flash""  Sub StopIt()  Application.OnTime NextTime, ""Flash"", schedule:=False  ActiveWorkbook.Styles(""Flash"").Font.ColorIndex = xlAutomatic " "Sub WordAc() adres = Application.InputBox(""Belgenizin Adı Nedir ?"", ""Adres"", ""\Word.doc"") On Error GoTo hata1 With CreateObject(""Word.Application"") .Visible = 1 .Documents.Open (ThisWorkbook.Path & adres) End With hata1:  " "Sub auto_open() Static sayac As Integer Do If sayac = 3 Then ThisWorkbook.Close False Else If InputBox(""Şifreyi girin"") = ""Buraya koymak istediğiniz şifreyi yazacaksınız!"" Then GoTo devam Else sayac = sayac + 1 End If End If Loop devam: " "Exceli İlk Açtığınızda istediğiniz sayfanın gelmesi için Sub SayfaHucreSec() Sheets(""Sayfa1"").Select Selection.Range(""A1"").Select  " "Sub HideExcel() Application.Visible = False " "Sub Nur_MsgBox() Application.Visible = False MsgBox (""Du siehst nur die MsgBox"") Application.Visible = True " "Private Sub kapat() Dim Cevap As VbMsgBoxResult Cevap = MsgBox(""PROGRAMIN KAPATILMASINI İSTİYOR MUSUNUZ.?"", _ vbOKOnly + vbYesNo, ""MESAJ"") If Cevap = vbYes Then ActiveWorkbook.Save Excel.Application.Quit End If  " "makronuzun uygun yerine aşağidaki kodu yazmalısınız.  Application.Quit " application.quit "Public Sub ListAllFaces() Btn = MsgBox(""This macro will list all of the button faces (over 5000)"" & vbCrLf & _ ""in this worksheet."" & vbCrLf & vbCrLf & _ ""Are you READY TO PROCEED?"", vbOKCancel, ""Button Image Listing"") If Btn = vbCancel Then Exit Sub Dim i As Integer Dim j As Integer Dim k As Integer Dim cbCtl As CommandBarControl Dim cbBar As CommandBar On Error Resume Next Application.ScreenUpdating = False Set cbBar = CommandBars.Add(Position:=msoBarFloating, MenuBar:=False, temporary:=True) Set cbCtl = cbBar.Controls.Add(Type:=msoControlButton, temporary:=True) k = 1 Do While Err.Number = 0  For j = 1 To 10 i = i + 1 Application.StatusBar = ""Face ID = "" & i cbCtl.FaceId = i cbCtl.C

End Sub " Farkli uyari pencerelerİ "Sub Dene() MsgBox ""aa"", 16, ""hata"" End Sub Kod: Sub Denee() MsgBox ""aa"", 64, ""hata"" End Sub " Fcommandbutton hareket etsİn.Ormda "Private Sub SpinButton1_Change() CommandButton1.Top = 104 - SpinButton1.Value * 10 CommandButton1.Caption = ""YUKARI-AŞAĞI"" End Sub Private Sub SpinButton2_Change() CommandButton1.Left = 2 + SpinButton2.Value * 20 CommandButton1.Caption = ""SAĞA-SOLA"" End Sub Private Sub UserForm_Initialize() SpinButton1.Value = 5 SpinButton2.Value = 5 CommandButton1.Caption = """" End Sub" Filigran yazdırma (sayfa artalanına silik yazı) "Private Sub Workbook_BeforePrint(Cancel As Boolean) Dim i As Integer Dim x As Integer Dim shp As Shape ActiveSheet.Unprotect Range(""A1:IV65536"").Locked = False For Each shp In ActiveSheet.Shapes If shp.Type = msoTextEffect Then shp.Delete End If Next shp For i = 1 To ActiveSheet.UsedRange.Rows.Count If Rows(i).PageBreak = xlAutomatic Or _ Rows(i).PageBreak = xlManual Or _ i = 1 Then Cells(i, 1).Select Set shp = ActiveSheet.Shapes.AddTextEffect _ (msoTextEffect1, _ ""Mahmut BAYRAM"", ""Arial Black"", _ 36#, msoFalse, msoFalse, _ Cells(i, 1).Left + 40.5, _ Cells(i, 1).Top + 180#) With shp With .Fill .Visible = msoTrue .Solid .ForeColor.SchemeColor = 22 .Transparency = 0.51 End With With .Line .Weight = 0.75 .DashStyle = msoLineSolid .Style = msoLineSingle .Transparency = 0# .Visible = msoFalse End With .LockAspectRatio = msoTrue .Height = 51# .Width = 156# .Rotation = 40# End With For x = 1 To ActiveSheet.UsedRange.Columns.Count If Columns(x).PageBreak = xlAutomatic Or _ Columns(x).PageBreak = xlManual Then Cells(i, x).Select Set shp = ActiveSheet.Shapes.AddTextEffect _ (msoTextEffect1, _ ""Mahmut BAYRAM"", ""Arial Black"", _ 36#, msoFalse, msoFalse, _ Cells(i, x).Left + 40.5, _ Cells(i, x).Top + 180#) With shp With .Fill .Visible = msoTrue .Solid .ForeColor.SchemeColor = 22 .Transparency = 0.51 End With With .Line .Weight = 0.75 .DashStyle = msoLineSolid .Style = msoLineSingle .Transparency = 0# .Visible = msoFalse End With .LockAspectRatio = msoTrue .Height = 51# .Width = 156# .Rotation = 40# End With End If Next x End If Next i ActiveSheet.Protect DrawingObjects:=True Set shp = Nothing End Sub" Filtreyi (süzmeyi) iptal etme "Private Sub CommandButton2_Click() Worksheets(""Sayfa1"").AutoFilterMode = False End Sub" Fİnd menÜsÜ oluŞturma "Bu durumda bir userform üzerindeki textboxla bunu yapmak mümkün. Bunun için bir userform oluşturun ve üzerine bir textbox ile command buton yerleştirin. Command butona aşağıdaki kodları bağlayın. Arayacağınız veriyi textbox a girerek buldurabilirsiniz. Kod: Private Sub CommandButton1_Click() On Error GoTo hata Set ara = Sheets(""sayfa1"").Columns(""A:IV"").Find(What:=TextBox1) Application.Goto Reference:=Range(ara.Address), _ Scroll:=False Exit Sub hata: MsgBox (""yok"") End Sub " Fonksiyon çalıştırma kodu "Sub Goto_Factors() Application.Goto Reference:=""Factors"" End Sub Function Factors(x As Double) As String Dim i As Integer Factors = x For i = x - 1 To 1 Step -1 If x / i = Int(x / i) Then Factors = Factors & "", "" & i End If Next i End Function" Fonksiyon çalıştırma kodu2 "Sub Code2() Application.Goto Reference:=""Sum_color"" End Sub" Fonksiyon tanımlama not puanlama "Function Puan(Notu As Integer) Select Case Notu Case Is > 100: Puan = ""Geçersiz not"" Case Is >= 85: Puan = ""5 Geçti"" Case Is >= 70: Puan = ""4 Geçti"" Case Is >= 55: Puan = ""3 Geçti"" Case Is >= 45: Puan = ""2 Geçti"" Case Is >= 0: Puan = ""1 Kaldı"" Case Else: Puan = ""Geçersiz not"" End Select End Function" Fonksiyonla kitabın açık olup olmadığını öğrenme "Sub GotoCode() Application.Goto Reference:=""test"" End Sub Sub test() Dim wkbook As String wkbook = ""MyWorkbook.xls"" If IsOpen(wkbook) Then MsgBox wkbook & "" is open"" Else MsgBox wkbook & "" is not open"" End If End Sub Function IsOpen(WkBookName As String) As Boolean IsOpen = False For Each wkbk In Application.Workbooks opened = UCase(wkbk.Name) = UCase(WkBookName) If opened Then IsOpen = True End If Next wkbk End Function" Font isimleri a sütununda "Sub SchriftAuslesen() Dim cnt As CommandBarControl Dim intCounter As Integer Application.ScreenUpdating = False Set cnt = Application.CommandBars.FindControl(ID:=1728) For intCounter = 1 To cnt.ListCount With Cells(intCounter, 1) .Value = cnt.List(intCounter) .Font.Name = cnt.List(intCounter) End With Next intCounter Columns(1).AutoFit Application.ScreenUpdating = True End Sub" Fontları sayfaya yazdırma "Sub SchriftAuslesen() Dim cnt As CommandBarControl Dim intCounter As Integer Application.ScreenUpdating = False Set cnt = Application.CommandBars.FindControl(ID:=1728) For intCounter = 1 To cnt.ListCount With Cells(intCounter, 1) .Value = cnt.List(intCounter) .Font.Name = cnt.List(intCounter) End With Next intCounter Columns(1).AutoFit Application.ScreenUpdating = True End Sub" Form aÇar " FORM AÇAR Sub formaç() Günlük.Show End Sub " Form açma " Sub formaç() Günlük.Show End Sub" Form ÇaĞirir "EKLEYECEĞİNİZ FORMU ÇAĞIRIR Private Sub CommandButton6_Click() Load UserForm1 UserForm1.Show End Sub " Form dolarsa İkİncİ forma geÇİp Çiktisini alsin "Private Sub workbook_BeforePrint(Cancel As Boolean) Select Case ActiveSheet.Name Case ""Sayfa1"", ""Sayfa2"" Cancel = True MsgBox ""Bu sayfalar yazdırılamaz!!"", vbInformation End Select End Sub" Form kutusundan lİs.Kutusuna kom.Verme "FORM KUTUSUNDAN LİSTE KUTUSUNA KOMUT VERME Private Sub UserForm_Click() Sheets(""günlük"").Select TextBox1.Value = WorksheetFunction.Count(Range(""a2:a65000"")) + 1 TextBox2.SetFocus L = WorksheetFunction.CountA(Worksheets(""günlük"").Range(""a1:a10000"")) ListBox1.RowSource = ""günlük!a1:a"" & L ListBox1.ColumnCount = 12 ListBox1.RowSource = ""günlük!a1:l"" & L ' istatislikler yükleniyor Range(""b2"").Select TextBox2.Value = ActiveCell.Offset(0, 0).Value TextBox3.Value = ActiveCell.Offset(0, 1).Value TextBox4.Value = ActiveCell.Offset(0, 2).Value TextBox5.Value = ActiveCell.Offset(0, 3).Value TextBox6.Value = ActiveCell.Offset(0, 4).Value TextBox7.Value = ActiveCell.Offset(0, 5).Value TextBox8.Value = ActiveCell.Offset(0, 6).Value TextBox9.Value = ActiveCell.Offset(0, 7).Value TextBox10.Value = ActiveCell.Offset(0, 8).Value TextBox11.Value = ActiveCell.Offset(0, 9).Value TextBox12.Value = ActiveCell.Offset(0, 10).Value End Sub " Form kutusundan liste kutusuna komut verme "Private Sub UserForm_Click() Sheets(""günlük"").Select TextBox1.Value = WorksheetFunction.Count(Range(""a2:a65000"")) + 1 TextBox2.SetFocus L = WorksheetFunction.CountA(Worksheets(""günlük"").Range(""a1:a10000"")) ListBox1.RowSource = ""günlük!a1:a"" & L ListBox1.ColumnCount = 12 ListBox1.RowSource = ""günlük!a1:l"" & L ' istatislikler yükleniyor Range(""b2"").Select TextBox2.Value = ActiveCell.Offset(0, 0).Value TextBox3.Value = ActiveCell.Offset(0, 1).Value TextBox4.Value = ActiveCell.Offset(0, 2).Value TextBox5.Value = ActiveCell.Offset(0, 3).Value TextBox6.Value = ActiveCell.Offset(0, 4).Value TextBox7.Value = ActiveCell.Offset(0, 5).Value TextBox8.Value = ActiveCell.Offset(0, 6).Value TextBox9.Value = ActiveCell.Offset(0, 7).Value TextBox10.Value = ActiveCell.Offset(0, 8).Value TextBox11.Value = ActiveCell.Offset(0, 9).Value TextBox12.Value = ActiveCell.Offset(0, 10).Value End Sub" Form penceresİ "Formu açmak için şu kodları bir module yazabilirsiniz. Kod: Sub Makro1() Range(""A1:C5"").Select ActiveSheet.ShowDataForm End sub Formu açarken ""Microsoft Excel bu komut için gereken sütun etiketlerini hangi listenin ya da seçimin içerdiğini belirleyemiyor"" gibi bir uyarı çıkıyor ise şu kodları deneyin. Kod: Sub Makro1() Application.DisplayAlerts = False Range(""A1:C5"").Select ActiveSheet.ShowDataForm Application.DisplayAlerts = True End Sub " Forma otomatİk resİm getİrme "Önce gösterilecek resimlerin isimleri bilgisayardan (Resimlerim klasörü)seçilerek sayfaya kaydediliyor. Daha sonra bu resimlerden gösterilmek istenen seçiliyor. Gerekli malzeme: 1 adet İmage1 1 adet CmdButon 1 adet cmbobox 1 adet Label1 'BU KOD EN BAŞA YAZILACAK Private Declare Function ShellExecute Lib ""shell32.dll"" _ Alias ""ShellExecuteA"" (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _ ByVal nShowCmd As Long) As Long 'BU KOD SAYFADAKİ ADRESTE BULUNAN RESİMLERİ GÖSTERİR Private Sub ComboBox1_Change() Image1.PictureSizeMode = fmPictureSizeModeZoom If ComboBox1.Value = """" Then MsgBox ""Resim Yok"", vbCritical Unload UserForm1 UserForm1.Show Exit Sub End If Label1.Caption = Cells(ComboBox1.ListIndex + 1, 1).Value 'seçim kutusundaki isim etikete yazılıyor Image1.Picture = LoadPicture(Label1.Caption) 'Etikette adresi gösterilen resim yükleniyor End Sub 'BU KOD İSTENİLEN RESİMLERİ SAYFAYA KAYIT EDER Private Sub CommandButton1_Click() Dim son As Integer Dim MyPic As Variant On Error Resume Next MyPic: MyPic = Application.GetOpenFilename(""JPEG,*.jpg,GIF,*.gif,Bitmap, *.bmp"") If MyPic <> False Then resim.PictureSizeMode = fmPictureSizeModeZoom resim.Picture = LoadPicture(MyPic) son = WorksheetFunction.CountA(Sheets(""resimdata"").Range(""A:A"")) + 1 'Resim adlarını sayfada depo ediyor. Sheets(""resimdata"").Cells(son, 1) = MyPic cevap = MsgBox("" "" & MyPic & "" kayıt edildi.Yeni resim eklemek istiyor musunuz?"", vbExclamation + vbYesNo, ""RESİM KAYIT"") If cevap = vbYes Then GoTo MyPic End If End If End Sub 'BU KOD USERFORMA YAZILACAK Private Sub UserForm_Initialize() ComboBox1.RowSource = ""resimdata!A:A"" End Sub KOMPLE UYGULAMALI ÖRNEK 'BU KOD EN BAŞA YAZILACAK Private Declare Function ShellExecute Lib ""shell32.dll"" _ Alias ""ShellExecuteA"" (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _ ByVal nShowCmd As Long) As Long 'BU KOD COMBOBOX1 İÇİN Private Sub ComboBox1_Change() Image1.PictureSizeMode = fmPictureSizeModeZoom If ComboBox1.Value = """" Then MsgBox ""Resim Yok"", vbCritical Exit Sub End If Label1.Caption = Cells(ComboBox1.ListIndex + 1, 1).Value 'seçim kutusundaki isim etikete yazılıyor Image1.Picture = LoadPicture(Label1.Caption) 'Etikette adresi gösterilen resim yükleniyor End Sub 'BU KOD VERİLEN ADRESTEN RESİMİ SAYFAYA EKLER Private Sub CommandButton1_Click() cevap = MsgBox(""BU İŞLEMİ YANLIZCA YETKİLİ KİŞİ YAPABİLİR ? YETKİNİZ YOKSA LÜTFEN VAZGEÇİN ! "", vbYesNo + vbQuestion + vbDefaultcmdsil + vbApplicationModal, ""FORMA RESİM EKLER"") If cevap = vbNo Then End End If Dim son As Integer Dim MyPic As Variant On Error Resume Next MyPic: MyPic = Application.GetOpenFilename(""JPEG,*.jpg,GIF,*.gif,Bitmap, *.bmp"") If MyPic <> False Then resim.PictureSizeMode = fmPictureSizeModeZoom resim.Picture = LoadPicture(MyPic) son = WorksheetFunction.CountA(Sheets(""resimdata"").Range(""A:A"")) + 1 'Resim adlarını sayfada depo ediyor. Sheets(""resimdata"").Cells(son, 1) = MyPic cevap = MsgBox("" "" & MyPic & "" kayıt edildi.Yeni resim eklemek istiyor musunuz?"", vbExclamation + vbYesNo, ""RESİM KAYIT"") If cevap = vbYes Then GoTo MyPic End If End If End Sub 'BU KOD TEXTBOX1'DE VERİ ARATMAK İÇİN Private Sub CommandButton2_Click() On Error Resume Next Dim bak As Range For Each bak In Range(""B1:B"" & WorksheetFunction.CountA(Range(""B1:B65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(TextBox1.Value, vbUpperCase) Then bak.Select ComboBox1.Value = ActiveCell.Offset(0, -1).Value ComboBox2.Value = ActiveCell.Offset(0, 1).Value TextBox3.Value = ActiveCell.Offset(0, 2).Value TextBox4.Value = ActiveCell.Offset(0, 3).Value TextBox5.Value = ActiveCell.Offset(0, 4).Value TextBox6.Value = ActiveCell.Offset(0, 5).Value TextBox7.Value = ActiveCell.Offset(0, 6).Value TextBox8.Value = ActiveCell.Offset(0, 7).Value Exit Sub End If Next bak MsgBox ""Aradığınız isimde bir kayıt bulunamadı"" End Sub 'BU KOD EKRANI TEMİZLER Private Sub CommandButton3_Click() Unload UserForm1 UserForm1.Show End Sub 'BU KOD VERİLERİNİZDE YAPILAN DEĞİŞİKLİKLERİ KAYIT EDER Private Sub CommandButton4_Click() Dim bak As Range For Each bak In Range(""b1:b"" & WorksheetFunction.CountA(Range(""b1:b65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(TextBox1.Value, vbUpperCase) Then bak.Select ActiveCell.Value = TextBox1.Value ActiveCell.Offset(0, 1).Value = ComboBox2.Value ActiveCell.Offset(0, 2).Value = TextBox3.Value ActiveCell.Offset(0, 3).Value = TextBox4.Value ActiveCell.Offset(0, 4).Value = TextBox5.Value ActiveCell.Offset(0, 5).Value = TextBox6.Value ActiveCell.Offset(0, 6).Value = TextBox7.Value ActiveCell.Offset(0, 7).Value = TextBox8.Value Workbooks(""KADRO_.XLS"").Save MsgBox ""Verileriniz Başarıyla Değiştirildi"", , ""KAYIT"" TextBox1.Value = WorksheetFunction.Count(Range(""A1:A65000"")) + 1 Unload UserForm1 UserForm1.Show Exit Sub End If Next bak End Sub 'BU KOD COMBOBOX2'DE VERİ ARATMAK İÇİN Private Sub CommandButton5_Click() On Error Resume Next Dim bak As Range For Each bak In Range(""C1:C"" & WorksheetFunction.CountA(Range(""C1:C65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox2.Value, vbUpperCase) Then bak.Select ComboBox1.Value = ActiveCell.Offset(0, -2).Value TextBox1.Value = ActiveCell.Offset(0, -1).Value TextBox3.Value = ActiveCell.Offset(0, 1).Value TextBox4.Value = ActiveCell.Offset(0, 2).Value TextBox5.Value = ActiveCell.Offset(0, 3).Value TextBox6.Value = ActiveCell.Offset(0, 4).Value TextBox7.Value = ActiveCell.Offset(0, 5).Value TextBox8.Value = ActiveCell.Offset(0, 6).Value Exit Sub End If Next bak MsgBox ""Aradığınız isimde bir kayıt bulunamadı"" End Sub 'BU KOD USERFORM İÇİN Private Sub UserForm_Initialize() ComboBox1.RowSource = ""resimdata!A:A"" Dim say As Integer Sheets(""resimdata"").Select If Range(""c2"") = """" Then say = WorksheetFunction.CountA(Range(""B1:B65000"")) ComboBox1.RowSource = ""resimdata!c2:c"" & say + 1 Else say = WorksheetFunction.CountA(Range(""c1:c65000"")) ComboBox2.RowSource = ""resimdata!c2:c"" & say End If ComboBox1.SetFocus End Sub " Formatli olarak gİrdİĞİm sayinin sifirlarini gÖremİyorum "Private Sub CommandButton1_Click() TextBox1 = Format(TextBox1, ""#,###"") Cells(1, 1) = TextBox1.Value End Sub" Formlarda x Çikmaya İzİn vermez "BU KODLAR FORM KAPARKEN X DAN ÇIKMAYA İZİN VERMEZ. Option Explicit Public a, d As Integer Private Sub CommandButton1_Click() d = 0 ActiveWorkbook.Save ActiveWorkbook.Close End Sub 'KAPAT BUTONUNA BASILDIĞINDA UYARI VERİR ENGELLER Private Sub UserForm_initialize() d = 1 End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If d = 1 Then MsgBox "" kapat butonunu kullanınız."", vbCritical, ""UYARI"" Cancel = True End If End Sub 'BU KOD FORMUN ÇARPI İŞARETİNİ GİZLER Private Declare Function GetWindowLongA Lib ""User32"" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLongA Lib ""User32"" _ (ByVal hwnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function FindWindowA Lib ""User32"" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Sub UserForm_Initialize() Dim hwnd As Long hwnd = FindWindowA(""Thunder"" & IIf(Application.Version Like ""8*"", _ ""X"", ""D"") & ""Frame"", Me.Caption) SetWindowLongA hwnd, -16, GetWindowLongA(hwnd, -16) And &HFFF7FFFF End Sub " Formlardan bİrİnİ kapar dİĞerİnİ aÇar "EKLENEN FORMLARIN BİRİNİ KAPAR İSTENİLENİ AÇAR. Private Sub CommandButton1_Click() UserForm1.Hide UserForm2.Show End Sub " Formlardan birini kapayıp, diğerini açma "Private Sub CommandButton1_Click() UserForm1.Hide UserForm2.Show End Sub" Formu kapama "Private Sub CommandButton4_Click() End End Sub" Formu kapar "TABLOYU KAPAR Private Sub CommandButton4_Click() End End Sub " Formu otomatİk kapar "FORMU OTOMATİK KAPAR Private Sub UserForm_Activate() Application.Wait Now + TimeSerial(0, 0, 3) Unload Me End Sub " Formun sÜrÜklenmesİnİ engeller "BU KODU FORMA YAZDIĞINIZDA FORM AÇILDIĞINDA FORMU SÜRÜKLEYEMEZSİNİZ. Private Sub UserForm_Layout() Me.Move Application.Width / 2 - Me.Width / 2, Application.Height / 2 - Me.Height / 2 End Sub " Formunuzun baŞliĞini kodlarla İstedİĞİnİzİ Şekİlde ayarlayabİlİrsİnİz; "Private Sub UserForm_Initialize() UserForm1.Caption = ""www.excel.web.tr"" End Sub" Formül Çevirici "Sub Formul_Convertor() Dim data As New DataObject Dim z As String On Error GoTo hata MsgBox Application.ConvertFormula( _ Formula:=ActiveCell.Formula, _ fromReferenceStyle:=xlR1C1, _ toReferenceStyle:=xlA1), vbInformation, ""Normal Başvuru"" z = Application.ConvertFormula( _ Formula:=ActiveCell.Formula, _ fromReferenceStyle:=xlA1, _ toReferenceStyle:=xlR1C1) MsgBox z, vbInformation, ""R1C1 Stili"" data.SetText z data.PutInClipboard Exit Sub hata: MsgBox (""Formül yok !!!""), vbCritical, ""Başvurulan hücrede"" End Sub" Formül çoğaltma "Sub formulyaz() Application.ScreenUpdating = False Sheets(ComboBox1.Value).Activate [m11].Select Range(""m11"").Formula = ""YUVARLA(J12 + L12) / 2,0)"" [m11].Select Selection.AutoFill Destination:=[m11:m60], Type:=xlFillDefault [m11].Select ' ** [n11].Select [n11].Formula = ""=YAZIYLA(M11)"" [n11].Select Selection.AutoFill Destination:=[N11:N60], Type:=xlFillDefault [n11].Select ' *** End Sub" Formül çoğaltma "Sub Summebilden() z = ActiveCell.Row For i = 1 To 7 Cells(z - 1 + i, 6).FormulaArray = _ ""=SUM((r2c1:r23c2=1)*(r2c3:r23c3="" & i & "")*(r2c[-2]:r23c[-2]))"" Next i End Sub" Formül çoğaltma "Sub Minus() ActiveCell.FormulaR1C1 = ""=RC[1]-R[-1]C[1]"" Range(ActiveCell.Address & "":A"" & [B65536].End(xlUp).Row).FillDown End Sub" Formül çoğaltma dolu satıra göre "Sub Test() x = Cells(65536, 3).End(xlUp).Row Range(""E2"").AutoFill Destination:=Range(""E2:E"" & x) Application.Calculate End Sub " Formül çoğaltma dolu satıra göre (formülle) e1 hücresine eğer(c2<>"";c2-e2;"") da yazıp sürükleyin Formül çubuğunu kaldırma Application.DisplayFormulaBar=False - -> Formül çubuğu kaldırılır. Formül sonuna karakter ilave etme "Sub Formul_Sonuna_Karakter_Ilave_Et() Dim Hucre As Range karakter = InputBox(""Formülün Sonuna Ekleyeceğiniz Karakteri Giriniz ?"", """") For Each Hucre In Selection Hucre.Formula = Hucre.Formula & ""&"""""" & karakter & """""""" Next End Sub" Formülden değere, değerden formüle dönüşüm "Sub formulyaz() Application.ScreenUpdating = False Sheets(ComboBox2.Value).Select [b2].Select Range(""b2"").Formula = ""=yasbul(e1,e2,1)*(-1)"" [b2].Select Selection.AutoFill Destination:=[b2:b51], Type:=xlFillDefault [b2].Select End Sub Sub formulden_degere() Application.ScreenUpdating = False Sheets(ComboBox2.Value).Select Range(""B2:B51"").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range(""B2"").Select Application.CutCopyMode = False Range(""B2"").Select Application.ScreenUpdating = True End Sub" Formülle baş harfi büyük küçük öğrenme Büyük Formülleri değere dönüştürme "Sub a() ‘1.yol [B1].Value = [A1].Value End Sub Sub cokcokolsun() ‘2.yol [B1:B100].Value = [A1].Value End Sub Sub stepkopyala() ‘3.yol 1 er sütun atlayarak Dim x As Integer For x = 2 To 256 Step 2 Cells(1, x).Value = Cells(1, x).Offset(0, -1).Value Next x End Sub" Formülleri sayıya çevirme "Sub Form2val() For Each c in Selection.Cells c.formula=c.value Next c End Sub" FormÜllerİ sayiya Çevİrİr "FORMÜLLERİ SAYIYA ÇEVİRİR Sub Form2val() For Each c in Selection.Cells c.formula=c.value Next c End Sub " Formülleri yeni sayfada listeler " 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 " Formüllerin gizlenmesi "Sub Auto_Open() Cells.Select 'Range(""formüllü hücreler"").Select Selection.Locked = True Selection.FormulaHidden = True Range(""a1"").Select Sheets(""Sayfa1"").Protect Password:=""123"" End Sub ' ****Dosyayı kapatırken ise ** Sub Auto_Close() Sheets(""Sayfa1"").Unprotect Password:=""123"" Cells.Select 'Range(""formüllü hücreler"").Select Selection.Locked = False Selection.FormulaHidden = False Range(""a1"").Select End Sub" Formüllerin makro dili (ingilizcesi) "Sub AddressFormulasMsgBox() For Each Item In Selection If Mid(Item.Formula, 1, 1) = ""="" Then MsgBox ""The formula in "" & Item.Address(rowAbsolute:=False, _ columnAbsolute:=False) & "" is: "" & Item.Formula, vbInformation End If Next End Sub" Formüllü hücre renkli "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveCell.HasFormula Then With Selection.Interior .ColorIndex = 39 End With ActiveCell.Offset(0, 1).Select End If End Sub" Formüllü hücre silmeyi engelleme " **Sayfanın kod bölümüne ****** Option Explicit Private Sub Worksheet_Deactivate() Application.OnKey ""{del}"" End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.HasFormula Then Application.OnKey ""{del}"", ""mesaj"" Else Application.OnKey ""{del}"" End If End Sub ' **ThisWorbook kod bölümüne **** Option Explicit ' **bunu da modüle ***** Sub mesaj() MsgBox "" Formül silmek yasak kardeşim"" End Sub" Formüllü hücreleri korumaya alır "Sub Formul_bul_koru() Cells.Select Selection.Locked = False Selection.FormulaHidden = False Call ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas).Select Selection.Locked = True Selection.FormulaHidden = False ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub" Formüllü hücreleri silmeyi engelleme "Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim oRange As Range Application.EnableEvents = False On Error GoTo Fehler: If Target.Cells.Count = 1 Then If Target.HasFormula Then MsgBox ""In dieser Zelle befindet sich eine Formel oder ein Verweis."" & vbLf & vbLf & "" Ein Entfernen ist nur in der Bearbeitungsleiste möglich !"", vbOKOnly, ""http://www.excel-lex.de.vu"" Application.OnKey ""{del}"", """" Else Application.OnKey ""{del}"" End If Else Set oRange = Target.SpecialCells(xlCellTypeFormulas) MsgBox ""Es befinden sich Formeln oder Verweise im markierten Bereich."" & vbLf & vbLf & "" Ein Entfernen ist nur in der Bearbeitungsleiste möglich !"", vbOKOnly, ""http://www.excel-lex.de.vu"" Application.OnKey ""{del}"", """" End If Aufraeumen: Application.EnableEvents = True Exit Sub Fehler: Application.OnKey ""{del}"" Resume Aufraeumen End Sub" Formüllü hücreyi makroyla geri getirme "Option Explicit Type RangeCellInfo CellContent As Variant CellAddress As String End Type Public OrgWB As Workbook Public OrgWS As Worksheet Public OrgCells() As RangeCellInfo Sub EditRange() Dim i As Integer, cl As Range If TypeName(Selection) <> ""Range"" Then Exit Sub Application.ScreenUpdating = False ReDim OrgCells(Selection.Count) Set OrgWB = ActiveWorkbook Set OrgWS = ActiveSheet i = 1 For Each cl In Selection OrgCells(i).CellContent = cl.Formula OrgCells(i).CellAddress = cl.Address i = i + 1 Next cl Selection.Formula = ""X"" If Application.International(xlCountrySetting) = 47 Then Application.OnUndo ""Angre endringer utført av makroen"", ""UndoEditRange"" Else Application.OnUndo ""Undo the latest macro"", ""UndoEditRange"" End If End Sub Sub UndoEditRange() Dim i As Integer Application.ScreenUpdating = False On Error GoTo NoWBorWS OrgWB.Activate OrgWS.Activate On Error GoTo 0 For i = 1 To UBound(OrgCells) Range(OrgCells(i).CellAddress).Formula = OrgCells(i).CellContent Next i Set OrgWB = Nothing Set OrgWS = Nothing Erase OrgCells NoWBorWS: End Sub" Formüllü hücreyi seçmeden başka sayfaya değer olarak atamak "Sub deger() Worksheets(""Sayfa1"").Range(""A1"").Copy Worksheets(""Sayfa2"").Range(""A1"").PasteSpecial Paste:=xlValues Application.CutCopyMode = False End Sub" Formüllü ve tarihli kopyalama "Sub DebutActivite() Dim Cel As Range ActiveSheet.Unprotect Set Cel = Range(""B65536"").End(xlUp).Offset(1, 0) With Cel .Value = Date .NumberFormat = ""d-mmm-yy"" .HorizontalAlignment = xlCenter With .Offset(0, 1) .Value = Now .NumberFormat = ""hh:mm"" .HorizontalAlignment = xlCenter End With End With End Sub Sub FinActivite() Dim Cel As Range Set Cel = Range(""D65536"").End(xlUp).Offset(1, 0) With Cel .Value = Now .NumberFormat = ""hh:mm"" .HorizontalAlignment = xlCenter With .Offset(0, 1) .FormulaR1C1 = ""=RC[-1]-RC[-2]"" '.Value = Time .NumberFormat = ""hh:mm"" .HorizontalAlignment = xlCenter End With End With ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub" Formülü değere dönüştürme "Sub formuldegerlere () Application.ScreenUpdating = False Range(""D7:AH27"").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range(""D7"").Select Application.CutCopyMode = False Range(""D7"").Select Application.ScreenUpdating = True End Sub" Framede adres bİlgİsİ "Bu işi framele yapmak istemenizin bir sebebi varmı? Label bu iş için daha kullanışlı. Framelerin yerine label yerleştirip aaşağıdaki kodu bir deneyin. visual basic kodu: Private Sub ComboBox1_Change() ara = ComboBox1.Value alan = Sheets(""KAYITLAR"").Range(""adresler"") Label14.Caption = Application.WorksheetFunction.VLookup(ara, alan, 3, 0) End Sub " Geçici dosya ismi alma "Sub Geçici_Dosya_İsmi_Al() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") f = ds.GetTempName MsgBox f End Sub" Geçici dosyaya kaydetme "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" Geçici klasörler "Özel klasör isimleri alınıyor burada.Açıklama kodun içinde var. Sub Özel_Klasör_İsmi_Al() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") Set f = ds.GetSpecialFolder(0) '0 Windows,1 Sistem,2 Geçici Klasörlerinin yerini verir. MsgBox f End Sub" Geçiş seçenekleri penceresi "Sub Dialog_49() Application.Dialogs(xlDialogOptionsListsAdd).Show End Sub Sub Dialog_50() Application.Dialogs(xlDialogOptionsTransition).Show End Sub" Genel seçenekleri penceresi "Sub Dialog_48() Application.Dialogs(xlDialogOptionsGeneral).Show End Sub" Gerİ ÇaliŞan tİmer "Kodları modüle değil workbook içine yerleştirdiniz değilmi? (gözden kaçmış olabilir diye sordum). birde az önceki kodda dosyada tek sayfa varsa hata verecektir, onun yerine hücrelerin tamamını sildirebilirsiniz. Kod: Public AcZaman Private Sub Workbook_Open() AcZaman = Timer End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Application.DisplayAlerts = False SonZaman = Timer If SonZaman - AcZaman > 10 Then Range(""a1:IV65536"").Delete End If Application.DisplayAlerts = True End Sub " Gif, jpg vs… resim ekleme "Sub TestInsertPicture() InsertPicture ""C:\Excel Programlama\PictureFileName.gif"", Range(""D10""), True, True 'uzantıyı değiştirerek diğer resim formatlarını da ekleyebilirsiniz. End Sub Sub InsertPicture(PictureFileName As String, TargetCell As Range, _ CenterH As Boolean, CenterV As Boolean) ' inserts a picture at the top left position of TargetCell ' the picture can be centered horizontally and/or vertically Dim p As Object, t As Double, l As Double, w As Double, h As Double If TypeName(ActiveSheet) <> ""Worksheet"" Then Exit Sub If Dir(PictureFileName) = """" Then Exit Sub ' import picture Set p = ActiveSheet.Pictures.Insert(PictureFileName) ' determine positions With TargetCell t = .Top l = .Left If CenterH Then w = .Offset(0, 1).Left - .Left l = l + w / 2 - p.Width / 2 If l < 1 Then l = 1 End If If CenterV Then h = .Offset(1, 0).Top - .Top t = t + h / 2 - p.Height / 2 If t < 1 Then t = 1 End If End With ' resim pozisyonu With p .Top = t .Left = l End With Set p = Nothing End Sub" Gif, jpg vs… resmi hücreler arasına yerleştirme "Sub TestInsertPictureInRange() InsertPictureInRange ""C:\Excel Programlama\Arnold.gif"", _ Range(""B5:D10"") End Sub Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range) ' inserts a picture and resizes it to fit the TargetCells range Dim p As Object, t As Double, l As Double, w As Double, h As Double If TypeName(ActiveSheet) <> ""Worksheet"" Then Exit Sub If Dir(PictureFileName) = """" Then Exit Sub ' import picture Set p = ActiveSheet.Pictures.Insert(PictureFileName) ' determine positions With TargetCells t = .Top l = .Left w = .Offset(0, .Columns.Count).Left - .Left h = .Offset(.Rows.Count, 0).Top - .Top End With ' position picture With p .Top = t .Left = l .Width = w .Height = h End With Set p = Nothing End Sub" Gİrİlen verİ rakam diŞinda bİr Şey olursa kullaniciyi uyararak tekrar rakam İstesİn "Sub hesaplama() zamoranı: z = InputBox(""Zam oranını giriniz ! Ondalık kısmı varsa virgülle ayırınız !"") If Not IsNumeric(z) Then GoTo zamoranı Cells(1, 23) = (z + 100) / 100 End Sub" Gİrİlen verİnİn aynisi varsa kaydetmesİn "Private Sub CommandButton1_Click() Dim x As Boolean x = False For i = 1 To Sheets(""sheet2"").Cells(65536, 1).End(xlUp).Row If TextBox1.Text = Sheets(""sheet2"").Cells(i, 1) And TextBox2.Text = Sheets(""sheet2"").Cells(i, 2) Then x = True MsgBox (""Mükerrer kayıt"") Exit For End If Next i If x = False Then Sheets(""sheet2"").Cells(i, 1) = TextBox1 Sheets(""sheet2"").Cells(i, 2) = TextBox2 End If End Sub" Git penceresi "Sub Dialog_33() Application.Dialogs(xlDialogFormulaGoto).Show End Sub" Gitmek istenilen hücreyi seçer "Sub hücresec() 'Gitmek istenilen hücreyi seçer Dim Rng As Range On Error Resume Next Set Rng = Application.InputBox(prompt:=""Gitmek istediğiniz Hücreyi Yazınız"", Type:=8) If Rng Is Nothing Then MsgBox ""Seçimden vazgeçtiniz"" Else Rng.Select End If End Sub" Gizli açıklamayı göster (hücre seç) "Sub MSQCommentaire() Dim wks As Worksheet, MyCmt As Comment For Each wks In Worksheets For Each MyCmt In wks.Comments MyCmt.Visible = False ' Masque le commentaire MyCmt.Visible = True ' Affiche le commentaire Next MyCmt Next wks End Sub" Gizli safaları gösterme "Sub gizligoster() Dim wsh As Worksheet For Each wsh In Sheets wsh.Visible = True Next wsh End Sub" Gizli sayfada makro calisirmi "Çalışma Kitabında Sayfa1'i Gizlediğini varsayalım.. Fakat Dosyayı açan Kullanıcı Sayfa1'de işlem yapması gerekiyor veya sizin kodlarınız Sayfa1'de işlem yapması gerekiyor.. Kodlarınızın başına Kod: Sheets(""Sayfa1"").Visible = True yazdığınızda Gizli olan Sayfa1 açılıyor.. Ve Kodlarınızda yapılması gerekenler ne ise onu yapıyorsunuz,işi bittikten sonra yani kodların, Kod: Sheets(""Sayfa1"").Select 'Sayfayı seçiyor. ActiveWindow.SelectedSheets.Visible = False'Seçili sayfayı gizliyor.. Örnek Bir çalışma .. Burada Sayfa'in Gizli olması Gerek.. Kod: Sub deneme() Sheets(""Sayfa1"").Visible = True Sheets(""Sayfa1"").Select Range(""A1"").Value = ""Bu Sayfa Gizlidir."" Sheets(""Sayfa1"").Select 'Sayfayı seçiyor. ActiveWindow.SelectedSheets.Visible = False 'Seçili sayfayı gizliyor.. End Sub Kodu Çalıştırdıktan sonra Gizli Sayfayı açın. A1 Hücresine Bu Sayfa Gizlidir. yazısının yazıldığını göreceksiniz.." Gizli sayfaları siler "Sub DeleteHiddenSheets() Dim sh As Worksheet Application.DisplayAlerts = False For Each sh In ThisWorkbook.Worksheets If sh.Visible <> xlSheetVisible Then sh.Visible = True sh.Delete End If Next sh Application.DisplayAlerts = True End Sub" Gizli sayfanın gösterimi için şifre sorulması "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" Gizli sayfayı yazdır "Sayfa gizliyken yapmak mümkün değil ama 'Sayfa görünür hale getirip 'Çıktısını alıp 'Tekrar gizlerken 'Bu işlemlerin gözükmemesi için kodlarınız başına application.screenuptading = false " Gİzlİ tÜm tÜm sayfalari gÖster "GİZLİ OLAN TÜM SAYFALARI GÖSTER Sub Un_Hide_All() Dim sh As Worksheet For Each sh In Worksheets sh.Visible = True Next End Sub " Görsel ve güzel bir userform "Private Declare Function FindWindow Lib ""user32"" Alias ""FindWindowA"" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindow Lib ""user32"" (ByVal hwnd As Long, ByVal wCmd As Long) As Long Private Declare Function GetWindowRect Lib ""user32"" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function ReleaseCapture Lib ""user32"" () As Long Private Declare Function SendMessage Lib ""user32"" Alias ""SendMessageA"" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function CreateRectRgn Lib ""gdi32"" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function SetWindowRgn Lib ""user32"" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Private FensterRegion&, Region& Private Hauptfensternummer&, Clientfensternummer& Private dummy As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Const GW_CHILD = 5 Private Const WM_NCLBUTTONDOWN = &HA1 Private Const HTCAPTION = 2 Private Sub UserForm_Initialize() Call FensterOhneKopf End Sub Sub FensterOhneKopf() Dim Abmessung As RECT Dim Abmessung1 As RECT Dim Pos1x&, Pos1y&, Pos2x&, Pos2y& If FensterRegion <> 0 Then Exit Sub UserForm1.BorderStyle = fmBorderStyleSingle Call Fensternummer(UserForm1, Abmessung, Abmessung1) Pos1x = 0 Pos1y = (Abmessung1.Top - Abmessung.Top) Pos2x = Abmessung.Right - Abmessung.Left Pos2y = Abmessung.Bottom - Abmessung.Top Region = CreateRectRgn(Pos1x, Pos1y, Pos2x, Pos2y) FensterRegion = SetWindowRgn(Hauptfensternummer, Region, True) End Sub 'Fensterhandles und Infos über Fenster holen Private Sub Fensternummer(Form As Object, Abmessung As RECT, Abmessung1 As RECT) Dim Fenstername$, Suchstring$ Suchstring = ""UserForm ohne Titelzeile"" Fenstername = Form.Caption Form.Caption = Suchstring Hauptfensternummer = FindWindow(vbNullString, Suchstring) Form.Caption = Fenstername Clientfensternummer = GetWindow(Hauptfensternummer, GW_CHILD) dummy = GetWindowRect(Hauptfensternummer, Abmessung) dummy = GetWindowRect(Clientfensternummer, Abmessung1) End Sub 'Folgendes ist notwendig, um die Form ohne Titelleiste zu verschieben Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 1 Then If Hauptfensternummer <> 0 Then dummy = ReleaseCapture() dummy = SendMessage(Hauptfensternummer, WM_NCLBUTTONDOWN, HTCAPTION, 0) End If Else Unload UserForm1 ' Zum schließen, beim ausprobieren. End If End Sub Private Sub CommandButton1_Click() Unload Me End Sub" Görünüm seçenekleri penceresi "Sub Dialog_25() Application.Dialogs(xlDialogDisplay).Show End Sub" Gruplandır penceresi "Sub Dialog_24() Application.Dialogs(xlDialogDemote).Show End Sub" Güncelleştirme el ile "Sub guncelle() Application.AskToUpdateLinks = False ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources End Sub " Güncelleştirme otomatik "Private Sub Workbook_Open() Application.AskToUpdateLinks = False ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources End Sub" Haftanın gününü bulma "Private Sub CommandButton1_Click() Select Case Weekday(Date, vbMonday) 'Weekday(Date, vbMonday) şu anki tarihin (Date) haftanın kaçıncı günü olduğunu verir. 'Çıkan sonuç kaç ise o satıra (Örn: Case 5) gidip komutu işletir. Case 1: gun = ""Pazartesi"" Case 2: gun = ""Salı"" Case 3: gun = ""Çarşamba"" Case 4: gun = ""Perşembe"" Case 5: gun = ""Cuma"" Case 6: gun = ""Cumartesi"" Case 7: gun = ""Pazar"" End Select MsgBox gun End Sub" Haftanin kaÇinci gÜnÜ? "Private Sub CommandButton1_Click() MsgBox Application.Weekday(CDate(TextBox1), 2) End Sub" Hangi butona basıldığını bildirir (commandbutton) "örnek için 1 adet userform 1 adet buton ekleyin Option Explicit Dim Buttons() As New Class1 Sub ShowDialog() Dim ButtonCount As Integer Dim ctl As Control ' Create the Button objects ButtonCount = 0 For Each ctl In UserForm1.Controls If TypeName(ctl) = ""CommandButton"" Then If ctl.Name <> ""OKButton"" Then 'Skip the OKButton ButtonCount = ButtonCount + 1 ReDim Preserve Buttons(1 To ButtonCount) Set Buttons(ButtonCount).ButtonGroup = ctl End If End If Next ctl UserForm1.Show End Sub 'classmodüle Public WithEvents ButtonGroup As CommandButton Private Sub ButtonGroup_Click() MsgBox ""Hello from "" & ButtonGroup.Name End Sub" Hangi hücreye gitmek istiyorsan gider scroll yaparak "Sub git_hucre() Application.Goto Reference:=Range(""Q6""), Scroll:=True End Sub" Hangi hücreye yazarsan yaz a1 kaydetsin "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = ""$A$1"" Then Application.MoveAfterReturn = False" Hangi sayfalar korumalı öğrenin "Sub ProtectScan() MySheet = ActiveSheet.Name MyNote = """" For Each sht In ActiveWorkbook.Sheets IsProtected = sht.ProtectContents MyNote = MyNote & sht.Name & "": "" & IsProtected & vbCrLf Next sht MsgBox Prompt:=MyNote, Title:=""Korumalı Sayfalar"" End Sub" Hangi tuşa basarsan o makro çalışır "Sub Auto_open() Call EingabeEreignis End Sub Sub EingabeEreignis() Sheets(""Sayfa1"").OnEntry = ""B"" End Sub Sub B() If ActiveCell = Range(""A5"") Then ActiveSheet.DrawingObjects(""Button"").Select If Selection.Characters.Font.ColorIndex = 3 Then Selection.Characters.Font.ColorIndex = 1 Else Selection.Characters.Font.ColorIndex = 3 End If Range(""A5"").Select End If End Sub" Hangi tuşa basıldığını bulan api "Option Base 1 Option Explicit Type POINTAPI16 x As Integer y As Integer End Type Type MSG16 hWnd As Integer message As Integer wParam As Integer lParam As Long time As Long pt As POINTAPI16 End Type Declare Function FindWindow16 Lib ""User"" Alias ""FindWindow"" (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Integer Declare Function PeekMessage16 Lib ""User"" Alias ""PeekMessage"" (lpMsg As MSG16, _ ByVal hWnd As Integer, ByVal wMsgFilterMin As Integer, ByVal wMsgFilterMax As Integer, _ ByVal wRemoveMsg As Integer) As Integer Declare Function TranslateMessage16 Lib ""User"" Alias ""TranslateMessage"" (lpMsg As MSG16) As Integer Type POINTAPI32 x As Long y As Long End Type Type MSG32 hWnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI32 End Type Declare Function FindWindow32 Lib ""USER32"" Alias ""FindWindowA"" (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Declare Function PeekMessage32 Lib ""USER32"" Alias ""PeekMessageA"" (lpMsg As MSG32, _ ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, _ ByVal wRemoveMsg As Long) As Long Declare Function TranslateMessage32 Lib ""USER32"" Alias ""TranslateMessage"" (lpMsg As MSG32) As Long Sub procTestKey() Dim iCount As Integer Dim sKey As String Application.DisplayStatusBar = True iCount = 0 Do iCount = iCount + 1 Application.StatusBar = ""Loop: "" & iCount & "" Press any key to stop."" If InStr(1, Application.OperatingSystem, ""32"") = 0 Then sKey = funCheckKey16 Else sKey = funCheckKey32 End If Loop Until sKey <> """" MsgBox ""You pressed: "" & sKey Application.StatusBar = False End Sub Function funCheckKey16() As String Dim msgMessage As MSG16 Dim iHwnd As Integer Dim i As Integer Const WM_CHAR As Integer = &H102 Const WM_KEYDOWN As Integer = &H100 Const PM_REMOVE As Integer = &H1 Const PM_NOYIELD As Integer = &H2 funCheckKey16 = """" iHwnd = FindWindow16(""XLMAIN"", Application.Caption) i = PeekMessage16(msgMessage, iHwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE + PM_NOYIELD) If i <> 0 Then i = TranslateMessage16(msgMessage) i = PeekMessage16(msgMessage, iHwnd, WM_CHAR, WM_CHAR, PM_REMOVE + PM_NOYIELD) funCheckKey16 = Chr(msgMessage.wParam) End If End Function Function funCheckKey32() As String Dim msgMessage As MSG32 Dim iHwnd As Long Dim i As Long Const WM_CHAR As Long = &H102 Const WM_KEYDOWN As Long = &H100 Const PM_REMOVE As Long = &H1 Const PM_NOYIELD As Long = &H2 funCheckKey32 = """" iHwnd = FindWindow32(""XLMAIN"", Application.Caption) i = PeekMessage32(msgMessage, iHwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE + PM_NOYIELD) If i <> 0 Then i = TranslateMessage32(msgMessage) i = PeekMessage32(msgMessage, iHwnd, WM_CHAR, WM_CHAR, PM_REMOVE + PM_NOYIELD) funCheckKey32 = Chr(msgMessage.wParam) End If End Function" Hangİ tuŞa basildiĞini bİlebİlmek "İşgüzarlık mı yapıyorum bilmem ama konu bütünlüğü olsun istedim. Kodun son hali. Private Sub Tarih_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If KeyAscii <> vbKeyBack Then If Len(Tarih) = 2 Then Tarih = Tarih + ""."" If Len(Tarih) = 5 Then Tarih = Tarih + ""."" If Len(Tarih) = 10 Then Tarih = Left(Tarih, 10) End If End Sub " Hard disk formatlama SHFormatDrive hwnd, 2, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK Harddisk hakkında ayrıntılı rapor "Option Explicit Sub Festplatten() Const TEILER As Long = 1073741824 Dim objFSO As Object, objDrive As Object, colDrives As Object, varFree, intCount As Integer Set objFSO = CreateObject(""Scripting.FileSystemObject"") Set colDrives = objFSO.Drives intCount = 5 With LW .[b6:i100].ClearContents For Each objDrive In colDrives If objDrive.DriveType = 2 Then intCount = intCount + 1 .Cells(intCount, 2) = objDrive.DriveLetter .Cells(intCount, 3) = objDrive.TotalSize .Cells(intCount, 4) = objDrive.TotalSize / TEILER .Cells(intCount, 5) = objDrive.FreeSpace .Cells(intCount, 6) = objDrive.FreeSpace / TEILER If objDrive.IsReady Then .Cells(intCount, 7) = ""Bereit"" Else .Cells(intCount, 7) = ""Nicht bereit"" End If .Cells(intCount, 8) = objDrive.SerialNumber .Cells(intCount, 9) = objDrive.VolumeName End If Next End With End End Sub" Harddisk seri numarası alma a1 hücresine "Sub Seriennummer() Dim myfso As Object Set myfso = CreateObject(""Scripting.FileSystemObject"") 'MsgBox myfso.GetDrive(""C:\"").SerialNumber Range(""A1"").Value = myfso.GetDrive(""C:\"").SerialNumber Set myfso = Nothing End Sub" Harddiske format atma "Sub FormatageDSK() ValRetour = Shell(""C:\WINDOWS\RUNDLL32.EXE shell32,SHFormatDrive"", 1) End Sub" Harddiskin boş alanını vs.. ÖğRenme "Aktif sayfada Private Sub Workbook_Activate() Call Festplatten End Sub Sub Festplatten() Const TEILER As Long = 1073741824 Dim objFSO As Object, objDrive As Object, colDrives As Object, varFree, intCount As Integer Set objFSO = CreateObject(""Scripting.FileSystemObject"") Set colDrives = objFSO.Drives intCount = 5 With LW .[b6:i100].ClearContents For Each objDrive In colDrives If objDrive.DriveType = 2 Then intCount = intCount + 1 .Cells(intCount, 2) = objDrive.DriveLetter .Cells(intCount, 3) = objDrive.TotalSize .Cells(intCount, 4) = objDrive.TotalSize / TEILER .Cells(intCount, 5) = objDrive.FreeSpace .Cells(intCount, 6) = objDrive.FreeSpace / TEILER If objDrive.IsReady Then .Cells(intCount, 7) = ""Bereit"" Else .Cells(intCount, 7) = ""Nicht bereit"" End If .Cells(intCount, 8) = objDrive.SerialNumber .Cells(intCount, 9) = objDrive.VolumeName End If Next End With End End Sub" Hareket ettirilemeyen userform "Private Sub UserForm_Layout() Me.Move Application.Width / 2 - Me.Width / 2, Application.Height / 2 - Me.Height / 2 End Sub" Hareketsiz inputbox "Sub MyAddComment() 'www.ozgrid.com 'dan alınarak türkçeleştirilmiştir. ' Local Variables Dim DefaultRange As String, rngSelected As Range Dim UserRange As Range ' Step 1 : Retrieve range from user DefaultRange = Selection.Address On Error Resume Next Set UserRange = Application.InputBox _ (Prompt:=""Açıklama yazılacak hücreyi seçiniz:"", _ Title:=""pir"", _ Default:=DefaultRange, _ Type:=8) On Error GoTo 0 ' Step 2 : Set cell comments If Not UserRange Is Nothing Then For Each rngSelected In UserRange rngSelected.ClearComments With rngSelected.AddComment .Text InputBox(""Açıklamada Gözükecek Metni Giriniz"") End With Next rngSelected End If ' Step 3 : Make sure that the comment indicators are made visible If Application.DisplayCommentIndicator = xlNoIndicator Then _ Application.DisplayCommentIndicator = xlCommentIndicatorOnly End Sub" Hareketsiz userform "Option Explicit Private Sub UserForm_Layout() ' Von Bert Körn ' http://www.forum.excelabc.de/ Me.Move Application.Width / 2 - Me.Width / 2, Application.Height / 2 - Me.Height / 2 End Sub" Hareketsiz userform başlığı "Sub HarfHarf(ref As UserForm1) baslik = ref.Caption ref.Caption = """" For i = 0 To Len(baslik) If i = 0 Then ref.Caption = """" current = Timer Do While Timer - current < 0.1 DoEvents Loop GoTo Son Else End If ref.Caption = Left(baslik, i) current = Timer Do While Timer - current < 0.01 DoEvents Loop Son: Next i End Sub Private Sub CommandButton1_Click() HarfHarf Me End Sub" Harf değişimi "Sub Umlaute() Range(""A5:C10"").Select With Selection .Replace What:=""Ö"", Replacement:=""Oe"", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=True .Replace What:=""Ä"", Replacement:=""Ae"", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=True .Replace What:=""Ü"", Replacement:=""Ue"", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=True .Replace What:=""ö"", Replacement:=""oe"", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=True .Replace What:=""ä"", Replacement:=""ae"", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=True .Replace What:=""ü"", Replacement:=""ue"", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=True End With Range(""A5"").Select End Sub" Harf sayısı 100'den fazla İse alttaki hücreye yaz 1 "Private Sub TextBox1_Change() Select Case Len(TextBox1) Case 1 To 100 [A1] = TextBox1 Case 101 To 200 [A2] = Mid(TextBox1, 101, Len(TextBox1) - 100) Case Is > 200 [A3] = Mid(TextBox1, 201, Len(TextBox1) - 200) End Select End Sub" Harf sayısı 100'den fazla İse alttaki hücreye yaz 2 "Private Sub TextBox1_Change() Select Case Len(TextBox1) Case 1 To 100 ActiveCell.Offset.Value = TextBox1 Case 101 To 200 ActiveCell.Offset(1, 0).Value = Mid(TextBox1, 101, Len(TextBox1) - 100) Case Is > 200 ActiveCell.Offset(2, 0).Value = Mid(TextBox1, 201, Len(TextBox1) - 200) End Select End Sub" Hata mesajını yoksaymak on error resume next Hata mesajını yoksaymak "Sub Test() On Error GoTo ExitProc: ' ' ' Kodlar ' ' ' Exit Sub ExitProc: End Sub " Hataya mesaj yazma 1 "Sub verigir() On Error GoTo hata Range(""A1"") = ""pir"" On Error GoTo 0 Range(""A2"") = ""pir"" hata: MsgBox ""Korumalı Hücreye mesaj yazamazsın"" End Sub" Hataya mesaj yazma 2 "Sub verigir() On Error GoTo hata Range(""A1"") = ""pir"" On Error GoTo 0 git: Range(""A1"") = ""pir"" hata: MsgBox ""Korumalı Hücreye mesaj yazamazsın"" GoTo git End Sub" Hedef ara penceresi "Sub Dialog_36() Application.Dialogs(xlDialogGoalSeek).Show End Sub" Hedef hücreye gitme "Sub git() Application.Goto reference:=Range(""Sayfa1!A1"") 'You can change the address to a range name End Sub" Hepsi bir arada toplama çarpma bölme "A,B ve C sütunlarında değerler var.A2 hücresine aşağıdaki formülü girdiğimi varsayın.Gerçi bu kadar uzun bir formülü tek hücre,uzun geldiği için kabul etmez ama,siz öyle olduğunu kabul edin. =(A5*B5/C5)+(A6*B6/C6)+(A7*B7/C7)+ ..(A100*B100/C100) Şimdi,bu uzun formülün görevini yapacak kısacık bir formül yok mu?Basit gibi görünen Bu uzun formül,benim ömrümün törpüsü oldu ya hu! Mesela; Bu Excel'i icat eden, TOPLA.ÇARPIM veya DÇARP gibi harika fonksiyonları yapmışlar da,TOPLA.BÖL veya DBÖL ya da ÇARP.BÖL.TOPLA gibi fonksiyonlar neden eklememişler sanki. Bilmem anlatabildim mi dostlar? Saygılar. Function boltopla(bas As Integer, son As Integer) If bas <= 0 Or son <= 0 Then MsgBox ""İlk değer ve son değer sıfır ve sıfırdan küçük olamaz"" boltopla = ""HATA"" Exit Function End If If bas > 65536 Or son > 65536 Then MsgBox ""İlk değer ve son değer 65536'dan büyük olamaz"" boltopla = ""HATA"" Exit Function End If If son < bas Then MsgBox ""İlk değer Son değerden büyük olamaz"" boltopla = ""HATA"" Exit Function End If boltopla = 0 For i = bas To son boltopla = boltopla + Cells(i, 1) * Cells(i, 2) / Cells(i, 3) Next i End Function " Her 3 saniyede alt alta formül girme "Sub auto_open() Call makro_bei_zeit End Sub Sub makro_bei_zeit() Application.OnTime Now + TimeValue(""00:00:03""), ""daten_lesen"" End Sub Sub daten_lesen() Range(""A"" & Rows.Count).End(xlUp).Select ActiveCell.Offset(1, 0).Range(""A1"").Select ActiveCell.Formula = ""=VTPlus|NTV244!'3,3,,,B(13/12/17/12)'"" 'Börsenkurs aus dem Videotext von ntv 'Call makro_bei_zeit End Sub" Her 30 sn de bir mesaj verme (makro) "Modüle Option Explicit Sub MsgBox_alle_5min() Dim NextTime As Date NextTime = Now + TimeValue(""00:00:30"") Application.OnTime NextTime, ""AufrufMsgBox"" End Sub Sub AufrufMsgBox() MsgBox ""Nicht vergessen zu speichern."" Call MsgBox_alle_5min End Sub 'Thisworbook a Option Explicit Private Sub Workbook_Open() Call MsgBox_alle_5min End Sub 'Sayfanın kod bölümüne Option Explicit" Her 5 dk a1:a3000 arasında veri varsa bir uyarı vermeden silme "Sub auto_open() Application.OnTime Now + TimeValue(""00:05:00""), ""dene"" End Sub Sub dene() on error resume next Range(""A1:A3000"").SpecialCells(xlCellTypeConstants ).EntireRow.Delete Call auto_open End Sub" Her 5 satırdan sonraki satırın yüksekliği 5 "Sub Ligne() Range(""D1:D20"").Select 'Exemple de sélection possible For Each col In Selection.Rows If col.Row Mod 6 = 0 Then col.RowHeight = 5 End If Next col End Sub" Her 5 sn de bir makro çalıştırma (mesaj) "Public bekleme As Double Public Const Pause = 5 '5 saniye Public Const CallMakro = ""Selam"" Sub StartTimer() bekleme = Now + TimeSerial(0, 0, Pause) Application.OnTime earliesttime:=bekleme, _ procedure:=CallMakro, schedule:=True End Sub Sub Selam() MsgBox (""Selamun Aleyküm"") StartTimer End Sub Sub StopTimer() On Error Resume Next Application.OnTime earliesttime:=bekleme, _ procedure:=CallMakro, schedule:=False End Sub" Her 50 satırda bir toplam alır "Sub Zwischensumme() ' Bildet die Zwischensumme der Spalte C nach jeweils 49 Zeilen, fügt einen Seitenwechsel ein und überträgt die Zwischensumme auf die neue Seite For i = 50 To 2500 Step 50 '2500 ist Zeilenanzahl, ggf ändern a = i + 2 Rows(i).Select Selection.EntireRow.Insert Selection.EntireRow.Insert Cells(i, 3).FormulaR1C1 = ""=SUM(R[-49]C:R[-1]C)"" '3 steht für Spalte C Cells(i + 1, 3).Value = Cells(i, 3) '3 steht für Spalte C ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(i + 1, 3) '3 steht für Spalte C Next i End Sub" Her hangi bir sayfaya hızlı bilgi girşi için "Private Sub cmd_click() Columns(""A:D"").Select ActiveSheet.ShowDataForm End Sub 'Sayfa içerisindeki başlıklar excel'in kendi form ile birlikte 'size sorulacak , bu sayede pratik bir şekilde veri girişi sağlanabilir." Her saniye arayla mesaj verme "Option Explicit Sub Countdown() Dim intCounter As Integer Dim bln As Boolean bln = Application.DisplayStatusBar For intCounter = 10 To 1 Step -1 Application.StatusBar = ""Noch "" & _ intCounter & "" Sekunden "" Application.Wait Now + TimeSerial(0, 0, 1) Next intCounter Application.StatusBar = False Application.DisplayStatusBar = bln MsgBox ""Fertig "", vbOKOnly, ""© K.-M. Buss"" End Sub" Her saniyede bip ile birlite mesaj alma "Sub bip_uyari() pir = InputBox(""Almak istediğinizi mesajı yazınız?"") For Count = 1 To pir Beep Application.Wait Now() + TimeValue(""00:00:01"") Next Count End Sub" Her sayfayı ayrı ayrı kitap olarak c'ye kaydetme "Sub BreakItUp() Dim sht As Worksheet Dim NFName As String Const WBPath = ""C:\"" For Each sht In ActiveWorkbook.Worksheets sht.Copy NFName = WBPath & sht.Name & "".xls"" ActiveWorkbook.SaveAs FileName:=NFName, _ FileFormat:=xlNormal, CreateBackup:=False ActiveWindow.Close Next End Sub" Her veri girişten sonra mesaj alma "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Target, Range(""B:B"")) Is Nothing Then MsgBox ""Elemtere fiş kem gözlere şiş!"", vbOKOnly, ""www.pir38.sitemynet.com"" End If End Sub" Herhangİ bİr form ÜzerÜndekİ metİn kutusuna gİrİlecek karakter sayisini nasil sinirlandirabİlİrİm "aşağıdaki kodları bie denerseniz sanırım istediğiniz olacaktır. Bunları module değilde objelerin kendi kodları olarak girmelisiniz. Kod: Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) 'Girilen değer numerik değilse Textboxten çıkışı engelliyor, bu durumda boşta olamıyor. If IsNumeric(TextBox1.Value) Then Cancel = False Else Cancel = True Beep ' 'beep' sesi üretiyor MsgBox (""Sadece sayı girin!"") ' Uyarı penceresi açıyor. End If End Sub Private Sub UserForm_Initialize() TextBox1.MaxLength = 8 End Sub" Herhangi bir hücreye tıklayınca makro çalışsın "Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Target.Address = ""$H$3"" Then test End If End Sub Sub test() MsgBox ""aaaaaaaaaaaaaaaaaa"" End Sub" Herhangi bir hücreye tıklayınca o hücreden sağa doğru kayarak o aydaki günlerin numaralarını yazar ve haftasonlarını renklendirir "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, [A:A]) Is Nothing Then Exit Sub Cancel = True Satır = Target.Row Range(Cells(Satır, 1), Cells(Satır + 1, 31)).ClearContents Range(Cells(Satır, 1), Cells(Satır + 1, 31)).Interior.ColorIndex = xlNone TARİH = DateSerial(Year(Now), Month(Now), 1) AYINİLKGÜNÜ = TARİH AYEKLE = DateAdd(""M"", 1, TARİH) AYINSONGÜNÜ = DateAdd(""D"", -1, CDate(AYEKLE)) Sütun = 1 For GÜNLER = AYINİLKGÜNÜ To AYINSONGÜNÜ Cells(Satır, Sütun) = GÜNLER Cells(Satır + 1, Sütun) = Format(GÜNLER, ""DDDD"") If Weekday(Cells(Satır, Sütun), vbMonday) = 6 Or Weekday(Cells(Satır, Sütun), vbMonday) = 7 Then Range(Cells(Satır, Sütun), Cells(Satır + 1, Sütun)).Interior.ColorIndex = 6 End If Sütun = Sütun + 1 Next End Sub" Herhangi bir hücreye tıklayınca o hücreden sağa doğru kayarak o aydaki günlerin numaralarını yazma "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, [A:A]) Is Nothing Then Exit Sub Cancel = True Satır = Target.Row Range(Cells(Satır, 1), Cells(Satır + 1, 31)).ClearContents TARİH = DateSerial(Year(Now), Month(Now), 1) AYINİLKGÜNÜ = TARİH AYEKLE = DateAdd(""M"", 1, TARİH) AYINSONGÜNÜ = DateAdd(""D"", -1, CDate(AYEKLE)) Sütun = 1 For GÜNLER = AYINİLKGÜNÜ To AYINSONGÜNÜ Cells(Satır, Sütun) = GÜNLER Cells(Satır + 1, Sütun) = Format(GÜNLER, ""DDDD"") Sütun = Sütun + 1 Next End Sub" Herhangi bir tarihten sonraki ilk pazartesiyi bulma "=G1+8-weekday(G1;2) '=G1+8-HAFTANINGÜNÜ(G1;2)" Hesap kodlari "E1 Hücresi ile E15 HÜCRELERİNİN TOPLAMINI A1 E YAZ Sub Topla() [A1].Value = Application.Sum([E1:E15]) End Sub 'TEXTBOX'AGİRİLEN RAKAMLARI ÜÇ HANEDE BİR NOKTA İLE OTOMATİK AYIRIR Private Sub TextBox5_Change() TextBox5.Value = Format(TextBox5, ""###,###"") End Sub 'G SÜTUNUNA 50000 SATIR ÇIKARMA FORMÜLÜ GİRER(E2'DEN F2'Yİ ÇIKARIR) Private Sub CommandButton9_Click() Range(""G2"").Select ActiveCell.FormulaR1C1 = ""=+RC[-2]-RC[-1]"" Selection.AutoFill Destination:=Range(""G2:G50000""), Type:=xlFillDefault Range(""G2:G50000"").Select End Sub TOPLAM FORMÜLÜNÜ HER DEFASINDA BİR ALTA TOPLAYAN KODLAR Sub Addieren() Dim rng As Range Set rng = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) rng.Formula = ""=SUM(A1:A"" & rng.Row - 1 & "")"" End Sub AKTİF HÜCREYE GİRİLEN RAKAMLARI ALTAKİ STATUSBAR DA TOPLAYAN KODLAR Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Dim myVar As Double myVar = Application.Sum(Columns(Target.Column)) If myVar <> 0 Then Application.StatusBar = Format(myVar, ""###,###"") Else Application.StatusBar = False End If End Sub HÜCRELERE VERİLEN AD TANIMLAMALARINI SİLER Sub DeleteRangeNames() Dim rName As Name For Each rName In ActiveWorkbook.Names rName.Delete Next rName End Sub FAREYLE SEÇTİĞİNİZ HÜCRELERDEKİ FORMÜLLERİ AÇIKLAMA OLARAK YAZDIRAN KODLAR Sub formulacikla() Dim cell As Range Selection.ClearComments For Each cell In Selection If cell.HasFormula Then cell.AddComment cell.Formula cell.Comment.Visible = False cell.Comment.Shape.TextFrame.AutoSize = True End If Next cell End Sub MAKRO İLE TOPLAMA VE BÖLME YAPMA (YÜZDE ALMA) Sub topla_böl() Range(""C1"") = (Range(""A1"") / Range(""A2"")) * 100 End Sub 'VERİLERİ BİRLEŞTİRİR Sub birlestir() Range(""A1"").Select ActiveCell.FormulaR1C1 = _ ""=CONCATENATE(R[1]C[0],R[1]C[1],R[1]C[2])"" Range(""A2"").Select End Sub 'HÜCRELERE GİRİLEN SAYILARI YAZIYA ÇEVİRİR =Yaziyla(A1)formülü girildiğinde makro işler. Function Yaziyla(Sayi#) ReDim birler$(10), onlar$(10), basamak$(5) birler$(0) = """": birler$(1) = ""Bir"" birler$(2) = ""İki"": birler$(3) = ""Üç"" birler$(4) = ""Dört"": birler$(5) = ""Beş"" birler$(6) = ""Altı"": birler$(7) = ""Yedi"" birler$(8) = ""Sekiz"": birler$(9) = ""Dokuz"" onlar$(0) = """": onlar$(1) = ""On"" onlar$(2) = ""Yirmi"": onlar$(3) = ""Otuz"" onlar$(4) = ""Kırk"": onlar$(5) = ""Elli"" onlar$(6) = ""Altmış"": onlar$(7) = ""Yetmiş"" onlar$(8) = ""Seksen"": onlar$(9) = ""Doksan"" basamak$(1) = """": basamak$(2) = ""Bin"" basamak$(3) = ""Milyon"": basamak$(4) = ""Milyar"" basamak$(5) = ""Trilyon"" virgul2$ = """": cevap$ = """": onda$ = """" Say$ = Str$(Sayi#) virgul% = InStr(1, Say$, ""."") If virgul% Then Say$ = Right$(Say$, Len(Say$) - virgul%) Select Case Len(Say$) Case 6: onda$ = ""milyonda"" Case 5: onda$ = ""yüzbinde"" Case 4: onda$ = ""onbinde"" Case 3: onda$ = ""binde"" Case 2: onda$ = ""yüzde"" Case 1: onda$ = ""onda"" End Select GoSub cevir virgul2$ = "" virgül "" + onda$ + "" "" + cevap$ cevap$ = """" Say$ = Str$(Sayi#) Say$ = Left(Say$, virgul% - 1) End If GoSub cevir 'If cevap$ = """" And Mid$(Str$(Sayi#), 2, 1) = 0 Then cevap$ = ""Sıfır"" Yaziyla = cevap$ + virgul2$ Exit Function cevir: x% = Len(Say$) Say$ = String$(3 - (x% - Int(x% / 3) * 3), 48) + Say$ x% = Len(Say$) / 3 For i% = 1 To x% uclu$ = Mid$(Say$, Len(Say$) - i% * 3 + 1, 3) Y% = Val(Mid$(uclu$, 1, 1)) O% = Val(Mid$(uclu$, 2, 1)) b% = Val(Mid$(uclu$, 3, 1)) yazi$ = """" If Y% <> 0 Then If Y% > 1 Then yazi$ = birler$(Y%) yazi$ = yazi$ + ""Yüz"" End If yazi$ = yazi$ + onlar$(O%) + birler$(b%) If yazi$ <> """" Then If LCase(yazi$) = ""bir"" And i% = 2 Then yazi$ = """" cevap$ = yazi$ + basamak$(i%) + cevap$ End If Next i% Return End Function " Hesap makİnasi ÇaĞirir "HESAP MAKİNASINI AKTİF YAPAR Sub Hesap_makinesi() Application.ActivateMicrosoftApp Index:=0 End Sub " Hesap makinesi açma "Option Explicit Private Declare Function OpenProcess Lib ""kernel32"" ( _ ByVal dwDesiredAccess As Long, _ ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) As Long Private Declare Function GetExitCodeProcess Lib ""kernel32"" ( _ ByVal lnghProcess As Long, _ lpExitCode As Long) As Long '// If your going to be working with Systems that support security '// settings eg NT, XP the access will be checked against any '// security descriptor for the target process, so use this Const '// Sets all possible access flags for the process object. Private Const PROCESS_ALL_ACCESS = &H1F0FFF Public Function ShlProc_IsRunning(ShellReturnValue As Long) As Boolean Dim lnghProcess As Long Dim lExitCode As Long Dim lRet As Long '//Get the process handle lnghProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, ShellReturnValue) If lnghProcess <> 0 Then '// The GetExitCodeProcess function retrieves the '// termination status of the specified process. GetExitCodeProcess lnghProcess, lExitCode If lExitCode <> 0 Then '// Process still ALIVE! ShlProc_IsRunning = True Else '// YES finished @ last ShlProc_IsRunning = False End If End If End Function Sub ShellTester() Dim RetVal As Long '// '// When you Shell out to an Application the Return Value '// is the Applications Task ID '// in order to determine if it has Terminated we need to check '// if there is an existing process object '// > OpenProcess function opens an existing process object. '// On Error Resume Next '// On WinXP Calc.exe @ C:\WINDOWS\System32\ '// On Win9x Calc.exe @ C:\WINDOWS\ RetVal = Shell(""C:\WINDOWS\System32\CALC.EXE"", 1) On Error GoTo 0 If RetVal = 0 Then MsgBox ""NoGo!"" & vbCr & ""Check your Path"": End '// Ok, lets loop until the App process is terminated! Do While ShlProc_IsRunning(RetVal) = True DoEvents Loop MsgBox ""Program finished!"" & vbCr & ""Lets continue on now!"" End Sub" Hesap makinesi çağırma "Sub Hesap_makinesi() Application.ActivateMicrosoftApp Index:=0 End Sub" Hesap makinesini açma kapama "Option Explicit '// Declare the Required API's '// these handle the Calculator Menu Private Declare Function GetSystemMenu _ Lib ""user32"" ( _ ByVal hWnd As Long, _ ByVal bRevert As Long) _ As Long Private Declare Function DeleteMenu _ Lib ""user32"" ( _ ByVal hMenu As Long, _ ByVal nPosition As Long, _ ByVal wFlags As Long) _ As Long '// used to get the Windows Dir Private Declare Function GetWindowsDirectory _ Lib ""kernel32"" _ Alias ""GetWindowsDirectoryA"" ( _ ByVal lpBuffer As String, _ ByVal nSize As Long) _ As Long '// used to find the calculator Window Private Declare Function FindWindow _ Lib ""user32"" _ Alias ""FindWindowA"" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) _ As Long '// used to CLOSE the calcul7ator Private Declare Function PostMessage _ Lib ""user32"" _ Alias ""PostMessageA"" ( _ ByVal hWnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) _ As Long '// Used to set the Windows Style Private Declare Function SetWindowPos _ Lib ""user32"" ( _ ByVal hWnd As Long, _ ByVal hWndInsertAfter As Long, _ ByVal x As Long, _ ByVal y As Long, _ ByVal cx As Long, _ ByVal cy As Long, _ ByVal wFlags As Long) _ As Long '// Positions Private Const HWND_TOPMOST = -1 Private Const SWP_NOSIZE = &H1 Private Const SWP_NOMOVE = &H2 Private Const SWP_NOACTIVATE = &H10 Private Const SWP_SHOWWINDOW = &H40 Private Const WM_CLOSE = &H10 Private Const MF_BYCOMMAND As Long = &H0 Private Const SC_CLOSE = &HF060 Dim HoldVar As New Class1 Sub WinCalculator_Open() '// Need to consider International Versions Dim strSysDir1 As String Dim strSysDir2 As String Dim Fso As Object Dim Ret As Long Dim strTmp1 As String Dim strTmp2 As String '// make sure only ONE instance of Calc is open '// Unless you want more? then just remove this code. If HoldVar.hdlCalc Then Exit Sub '// On Error Resume Next '// get users [System Dir] > Typical location of Calculator Set Fso = CreateObject(""Scripting.FileSystemObject"") strSysDir1 = Fso.GetSpecialFolder(1) '// get users [Windows Dir] strTmp2 = String(256, Chr(0)) strSysDir2 = Left(strTmp2, GetWindowsDirectory(strTmp2, Len(strTmp2))) '// Calculator is typically in the [System Dir] or [Windows] '// lets see! Ret = Shell(strSysDir1 & ""\calc.exe"", 1) If Ret = 0 Then Ret = Shell(strSysDir2 & ""\calc.exe"", 1) If Ret = 0 Then GoTo NoGo On Error GoTo 0 '// Lets Keep these variable to reference later '// This is done via Class variable HoldVar.hdlCalc = FindWindow(vbNullString, ""calculator"") '// Disable the CLOSE button > so that we only close '// the instance of the calculator via Code WinCalculator_RemoveCloseMenu HoldVar.hdlCalc '// Make calculator Applet stay ONTOP SetWindowPos HoldVar.hdlCalc, _ HWND_TOPMOST, _ 0, 0, 0, 0, _ SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE Exit Sub NoGo: MsgBox ""Couldn't find Calc.exe file! "" & _ ""In either .."" & vbCrLf & vbCrLf & _ strSysDir1 & vbCrLf & "" OR "" & vbCrLf & _ strSysDir2, vbCritical, ""Better check!"" End Sub Sub WinCalculator_Close() '// If HoldVar.hdlCalc Then PostMessage HoldVar.hdlCalc, WM_CLOSE, 0&, 0& '// Reset the Windowhandle variable HoldVar.hdlCalc = 0 End Sub Sub WinCalculator_RemoveCloseMenu(hWnd As Long) '// Removes the CLOSE button on calculator Dim hMenu As Long hMenu = GetSystemMenu(hWnd, 0) Call DeleteMenu(hMenu, SC_CLOSE, MF_BYCOMMAND) End Sub ‘classmodüle Option Explicit Public hdlCalc As Double Public strCalcCaption As String " Hesaplama seçenekleri penceresi "Sub Dialog_09() Application.Dialogs(xlDialogCalculation).Show End Sub" Hesaplama seçenekleri penceresi "Sub Dialog_46() Application.Dialogs(xlDialogOptionsCalculation).Show End Sub" Hizalama penceresi "Sub Dialog_04() Application.Dialogs(xlDialogAlignment).Show End Sub" Hoparlörden beep sesi çıkarmak "Private Sub Command1_Click() Beep End Sub" Htm uzantılı dosyayı açma "Sub Help() Call Shell(""hh "" & ThisWorkbook.Path & ""\varCheck.htm"", vbMaximizedFocus) End Sub" Hucre ye geldİgİnde makro calİssİn "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect(Target, Range(""a1:a10"")) Is Nothing Then Exit Sub makroadi() End Sub " Hücre a1 deki yazı boyutu ve karekterini sadece yazıcıya gönderirken arial-italik ve 14 punto yapar "Sub Printr() ActiveSheet.PageSetup.CenterHeader = ""&""""Arial,Bold Italic""""&14Benim Tercihim"" & Chr(13) _ & Sheets(1).Range(""A1"") ActiveWindow.SelectedSheets.PrintOut Copies:=1 End Sub" Hücre alanı kesme, seçili alanı kesme Range(“A1:E10”).Cut Selection.Cut Hücre alanı seçme Range(“A1:E10”).Select Hücre biçimi textboxta da aynı biçimde "Private Sub CommandButton1_Click() Range(""a1"").Select ActiveCell.Formula = TextBox1 End Sub" HÜcre bİÇİmİnİ ayarlamak "Sorunuz üzerine biraz düşündüm. Aşağıdaki gibi kodlar sanırım isteğinizi karşılar. Aşağıda iki textbox için kod yazılmıştır. Textbox1 ""A1"" hücresine değer atıyor. Textbox2 ise ""A1"" hücresindeki değerin biçimini değiştiriyor. Textbox2'ye en az üç basamaklı bir biçim girin örneğin ""O/E"" şeklinde, daha az basamaklı değer için iki nolu koddaki mid formüllerini biçim uzunluğu kadar azaltın (OE için iki,O için bir mid kalsın). İkinci kodun yazılan biçim uzunluğunu dikkate alacak şekilde dahada geliştirilmesi mümkün. selamlar Kod: Private Sub TextBox1_Change() [a1] = TextBox1.Value End Sub Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) [a1].NumberFormat = ""General \"" & Mid(TextBox2.Value, 1, 1) & ""\"" & Mid(TextBox2.Value, 2, 1) & ""\"" & Mid(TextBox2.Value, 3, 1) End Sub " Hücre biçimlendir penceresi "Sub Dialog_02() Application.Dialogs(xlDialogActiveCellFont).Show End Sub Sub Dialog_22() Application.Dialogs(xlDialogDeleteFormat).Show End Sub" Hücre biçimlendir/yazı tipleri penceresi "Sub Dialog_30() Application.Dialogs(xlDialogFontProperties).Show End Sub" Hücre boş iken makro 1 dolu iken makro2 "Sayfanın kod kısmına Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range(""B3"").Value = """" Then Call Makro1 Else Call Makro2 End If End Sub Sub Makro1() MsgBox ""Selam"" End Sub Sub Makro2() MsgBox ""Günaydın"" End Sub" Hücre değer değişince makro çalışsın "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = ""$A$1"" <> Empty Then Deneme End Sub Sub Deneme() MsgBox ""suzunkopru"" End Sub" HÜcre deĞerİne gÖre renk deĞİŞtİrİr "BU KOD HÜCRELERİN DEĞERLERİNE GÖRE HÜCRE RENGİNİ DEĞİŞTİRİR Private Sub Worksheet_Change(ByVal Target As Range) Select Case Target Case ""65/4G"": Target.Interior.ColorIndex = 15 ' gri Case ""70/3G"": Target.Interior.ColorIndex = 5 ' kırmızı Case Else: Target.Interior.ColorIndex = xlNone End Select End Sub " HÜcre deĞerİnİ aÇiklamaya ekleme "İstediğin şeyi doğru anladıysam yaptım ve bende çalıştı. à imdi A1 den A20 ye kadar her hücrede ayrı bilgilerin var ve bunları günlük değiştiriyorsun.Vede her hücrede ayrı ayrı açıklaman olmasını ve bu hücrelerin günlük değişimlerini kaydetsin istiyorsun. Macroyu yazarken A1:A20 arasını baz aldım ve C1 hücresinede =bugün() fonksiyonunu yazarak o günün tarihini yazdırdım. Private Sub Worksheet_Change(ByVal Target As Range) Dim eski As String If Not Intersect(Target, Range(""A1:A20"")) Is Nothing Then yeni = Target.Value eski = Target.Comment.Text tarih = Range(""c1"").Value 'burdaki C1 o günün tarihinin yazdigi hücre. Target.Comment.Text Text:=eski & tarih & "" / "" & yeni & Chr(10) End If End Sub Bastaki if sadece A1 ve A20 arası hücrelere bilgi girdiğin zaman açıklamaya bilgi yazması için.Range(""A1:A20"") değiştirerek bu aralığı ayarlayabilirsin. Tek şart daha önceden elle A1 A20 arasına içi boş olan bir açıklama eklemen.(Ama içi boş olsun.Başlığı dahi olmasın) A1 ile A20 arasındaki herhangi bir hücrede değişiklik yaptığın an, o hücreye ait açıklamada, o hücrede yaptığın değişiklik ""tarih / eğişiklik"" şeklinde kendiliğinden eklenir. " Hücre değerleri belli tabloda otomatik renklendirmeli seçme "Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range(""A1"") = False Then Exit Sub ' Optional On Error Resume Next Dim myRange As Range Dim myTopLeftCell As Range Dim myBottomRightCell As Range ' Set your Top Left Cell and Bottom Right Cell, (Range Names can be used also) ' * Set myTopLeftCell = Range(""B3"") Set myBottomRightCell = Range(""H17"") ' * If Target.Row >= myTopLeftCell.Row And _ Target.Offset(Selection.Rows.Count - 1).Row <= myBottomRightCell.Row And _ Target.Column >= myTopLeftCell.Column And _ Target.Offset(, Selection.Columns.Count - 1).Column <= myBottomRightCell.Column Then Set myRange = Selection If ActiveSheet.Shapes(""hSelection"") Is Nothing Then ActiveSheet.Shapes.AddShape(msoShapeRectangle, myTopLeftCell.Left, Selection.Top, _ myBottomRightCell.Offset(, 1).Left - _ myTopLeftCell.Left, Selection.Height).Select With Selection With .ShapeRange .Fill.Visible = msoFalse .Line.ForeColor.SchemeColor = 12 ' Change Color Here .Line.Weight = 2.25 ' Change Line Weight (Thickness) Here .ZOrder msoSendToBack .Shadow.Visible = msoFalse End With .Name = ""hSelection"" .PrintObject = False End With Else With ActiveSheet.Shapes(""hSelection"") .Left = myTopLeftCell.Left .Top = Selection.Top .Width = myBottomRightCell.Offset(, 1).Left - myTopLeftCell.Left .Height = Selection.Height .ShapeRange.Shadow.Visible = msoFalse End With End If myRange.Select End If Set myTopLeftCell = Nothing Set myBottomRightCell = Nothing Set myRange = Nothing End Sub" HÜcre deĞİŞtİĞİnde yaninda kİ hÜcreye tarİh yazsin "Private Sub Worksheet_Change(ByVal Target As Range) If Target = 0 Then Exit Sub Application.EnableEvents = False Target.Offset(0, 1) = Now Application.EnableEvents = True End Sub" Hücre değiştirilemez uyarısı, diğer hücreye yönlendirme "Private Sub Worksheet_Change(ByVal Target As Range) If ActiveCell.Column = 11 Then Msg = ""Bu bölümdeki bilgileri değiştiremezsin!"" Cvp = MsgBox(Msg) Application.Undo Else End If If ActiveCell.Column = 12 Then Msg = ""Bu bölümdeki bilgileri değiştiremezsin! "" Cvp = MsgBox(Msg) Application.Undo Else End If End Sub" HÜcre dolu İse boŞ hÜcreye aktar "Dim satirsay As Integer satirsay = Application.CountA(Sheets(""sayfa1"").Columns(""A"")) if satirsay=0 then Sheets(""sayfa1"").Cells(1, 1)=""ne yazılacaksa"" else Sheets(""sayfa1"").Cells(2, 1)=""ne yazılacaksa"" end if " Hücre genişliğince kenarlık çizme "Sub TextBox2Cell() With ActiveCell ActiveSheet.Shapes.AddTextbox _ msoTextOrientationHorizontal, .Left, _ .Top, .Width, .Height End With End Sub" Hücre genişliğince kenarlık çizme2 "Sub TextBox2Selection() If TypeName(Selection) = ""Range"" Then With Selection ActiveSheet.Shapes.AddTextbox _ msoTextOrientationHorizontal, .Left, _ .Top, .Width, .Height End With End If End Sub" HÜcre İÇerİĞİne ekleme yap karŞilaŞtir. "verilen ilk koda dikkat etti iseniz Kod: Sub Macro1() For i = 1 To 20 bir = Cells(i, 1) [b]' 20 kez işlem yapar[/b] For j = 1 To 20 iki = Cells(j, ""2&"" Total"") [b]'400 kez bu işlemi [/b] If bir = iki Then [b]'400 kez bu kontrolü [/b] Cells(j, 4) = ""eşit"" [b]'400 kez bu işlemi yapar[/b] Next j Next i End Sub gereksiz 1200 işlem yaptığını görmüşünüzdür. " Hücre içeriğinin silinmesi Range(“D2:E5”).Clear Hücre içerisinde kayan yazı "Sub YANIPSON() Dim durum As Boolean, i As Single Do While (True) If durum=True Then Range(""C1"").Select With Selection.Interior .ColorIndex=3 .Pattern=xlSolid End With For i =0 To 2500 DoEvents Next durum=False Else Range(""C1"").Select Selection.Interior.ColorIndex=xlNone For i=0 To 2500 DoEvents Next durum=True End If Loop End Sub " HÜcre İÇerİsİndekİ boŞluklari sİlmek Columns("H").Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart Hücre içerisine kelime ekleme "Sub InserTermineDansCellule() Cells(1, 1).Select With Selection .Characters(.Characters.Count + 1).Insert ("" terminé"") End With End Sub" Hücre isimlerini öğrenme "Sub a() Dim Nm As Name For Each Nm In Names Nm.Visible = True Next End Sub Sub ShowNames() Dim N As Integer For N = 1 To ActiveWorkbook.Names.Count On Error Resume Next Cells(N, 1) = ""'"" & ActiveWorkbook.Names(N).Nam" Hücre ismi ile tarihli ve tarihsiz kitap kaydetme "Sub range_date_save () Dim dName$ dName = Worksheets(1).Range(""A1"") dName = Format(dName, ""mmdd"") & "".xls"" ActiveWorkbook.SaveAs dName End Sub Sub range_save() ThisWorkbook.SaveAs FileName:=Worksheets(1).Range(""A1"") End Sub" Hücre kopyalama "Sub CopyRange() Range(""A1:A3"").Copy Destination:=ActiveCell End Sub" Hücre kopyalama "Sub copy() Sheets(""Sayfa1"").Range(""A1:A3"").copy Destination:=ActiveCell End Sub" Hücre koruma penceresi "Sub Dialog_10() Application.Dialogs(xlDialogCellProtection).Show End Sub" Hücre renkleri ile ilgili kodlar "Eğer A sütununda kırmızı hücre varsa ilgili satırı siler (Color index = 3 :Kırmızı) Sub kirmizisil() Sub DeleteRowsRedInColA() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'pre XL97 xlManual Dim rng As Range, ix As Long Set rng = Intersect(Range(""A:A""), ActiveSheet.UsedRange) For ix = rng.Count To 1 Step -1 If rng.Item(ix).Interior.ColorIndex = 3 Then 'rakamı değiştirebilirsiniz rng.Item(ix).EntireRow.Delete End If Next Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub 'Dolu hücrelerin satırını mavi, boşları ise sarı yapan kodlar Sub bosdolurenklendir() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range For Each cell In Intersect(Selection, ActiveCell.EntireColumn, _ ActiveSheet.UsedRange) Select Case cell.Value Case Is >= 50 cell.EntireRow.Interior.ColorIndex = 20 Case Is >= 40 cell.EntireRow.Interior.ColorIndex = 37 Case Is >= 20 cell.EntireRow.Interior.ColorIndex = 38 Case Is >= 0 cell.EntireRow.Interior.ColorIndex = 36 Case Else cell.EntireRow.Interior.ColorIndex = 44 End Select Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub 'A1:B10 hücrelerindeki değer 10 dan büyükse hücre sarı olur Private Sub Worksheet_Change( _ ByVal Target As Excel.Range) If Intersect(Target, Range(""A1:B10"")) _ Is Nothing Then Exit Sub If Target.Value > 10 Then Target.Interior.ColorIndex = 6 Else Target.Interior.ColorIndex = xlNone End If End Sub" HÜcre renklerİ İle İlgİlİ kodlar "EĞER A SÜTUNUNDA KIRMIZI HÜCRE VARSA İLGİLİ SATIRI SİLEN KODLAR (COLOR İNDEK = 3 :Kırmızı) Sub kirmizisil() Sub DeleteRowsRedInColA() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'pre XL97 xlManual Dim rng As Range, ix As Long Set rng = Intersect(Range(""A:A""), ActiveSheet.UsedRange) For ix = rng.Count To 1 Step -1 If rng.Item(ix).Interior.ColorIndex = 3 Then 'rakamı değiştirebilirsiniz rng.Item(ix).EntireRow.Delete End If Next Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub DOLU HÜCRELERİN SATIRINI MAVİ BOŞLARI İSE SARI YAPAN KODLAR Sub bosdolurenklendir() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range For Each cell In Intersect(Selection, ActiveCell.EntireColumn, _ ActiveSheet.UsedRange) Select Case cell.Value Case Is >= 50 cell.EntireRow.Interior.ColorIndex = 20 Case Is >= 40 cell.EntireRow.Interior.ColorIndex = 37 Case Is >= 20 cell.EntireRow.Interior.ColorIndex = 38 Case Is >= 0 cell.EntireRow.Interior.ColorIndex = 36 Case Else cell.EntireRow.Interior.ColorIndex = 44 End Select Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub A1:B10 HÜCRELERİNDEKİ DEĞER 10 DAN BÜYÜK İSE HÜCRE RENGİ SARI OLUR Private Sub Worksheet_Change( _ ByVal Target As Excel.Range) If Intersect(Target, Range(""A1:B10"")) _ Is Nothing Then Exit Sub If Target.Value > 10 Then Target.Interior.ColorIndex = 6 Else Target.Interior.ColorIndex = xlNone End If End Sub " Hücre seçilince şifreli giriş "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Selection.Cells.Address = ""e26:ı36"" Then Exit Sub şifre = InputBox(""lütfen şifreyi giriniz"") If şifre <> ""a"" Then [e2].Select End Sub" Hücre seçilince şifreli giriş "Private Sub Worksheet_SelectionChange(ByVal Target As Range) sut = Selection.Cells.Column sat = Selection.Cells.Row If sut < 5 Or sut > 9 Or sat < 26 Or sat > 36 Then Exit Sub şifre = InputBox(""lütfen şifreyi giriniz"") If şifre <> ""a"" Then [a2].Select End Sub" Hücre seçme,tanımlama "Sub Düğme1_Tıklat() Dim r1 As Range, r2 As Range, myMultiAreaRange As Range Set r1 = Range(""A1:B2"") Set r2 = Range(""C3:D4"") Set myMultiAreaRange = Union(r1, r2) myMultiAreaRange.Select End Sub" Hücre sürüklemesini engelle, aktif yap "Sub SuruklemeyiEngelle() Application.CellDragAndDrop = False End Sub 'sürüklemeyi aktif yap Sub Auto_Close() Application.CellDragAndDrop = True End Sub " HÜcre sÜrÜklenmesİnİ engelle & aktİf yap "HÜCRE SÜRÜKLENMESİNİ ENGELLE Sub SuruklemeyiEngelle() Application.CellDragAndDrop = False End Sub HÜCRE SÜRÜKLENMESİNİ AKTİF YAP Sub Auto_Close() Application.CellDragAndDrop = True End Sub " Hücre tanımlayarak yazıcıdan çıktı alma "Sub ImpZoneEtTitle() With Worksheets(""Sayfa1"").PageSetup .CenterHorizontally = True .PrintArea = ""$A$10:$G$15"" .PrintTitleRows = (""$A$1:$A$2"") .Orientation = xlPortrait .FitToPagesWide = 1 .FitToPagesTall = 1 End With Worksheets(""Sayfa1"").PrintOut End Sub" HÜcre tanimlamalarini sayfaya gÖre ayarlama "Private Sub cmdkaydet_Click() Dim bak As Range Dim say As Integer For Each bak In Range(""A1:A"" & WorksheetFunction.CountA(sheets(""veriler"").Range(""A1:A65000""))) ------------ txtceksirano.Value = WorksheetFunction.Count(sheets(""veriler"").Range(""A1:A65000"")) + 1 " HÜcre ve sÜtun seÇİmlerİ "AKTİF SÜTUNU SEÇ Sub SelectEntireColumn() Selection.EntireColumn.Select End Sub AKTİF SATIRI SEÇ Sub SelectEntireRow() Selection.EntireRow.Select End Sub TÜM HÜCRELERİ SEÇ Sub SelectEntireSheet() Cells.Select End Sub DOLU HÜCRELERİN ALTINDAKİ BOŞ HÜCREYİ SEÇER Sub ActivateNextBlankDown() ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop End Sub AKTİF HÜCRELERİN SAĞ TARAFINDAKİ BOŞ HÜCREYİ SEÇER Sub ActivateNextBlankToRight() ActiveCell.Offset(0, 1).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(0, 1).Select Loop End Sub AKTİF HÜCRENİN SAĞINDAKİ VE SOLUNDAKİ DOLU HÜCRELERİ SEÇER Sub SelectFirstToLastInRow() Set LeftCell = Cells(ActiveCell.Row, 1) Set RightCell = Cells(ActiveCell.Row, 256) If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight) If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft) If LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select End Sub AKTİF HÜCRENİN ALTINDAN BAŞLAYARAK EN SON HÜCREYE KADAR SEÇER Sub SelectDown() Range(ActiveCell, ActiveCell.End(xlDown)).Select End Sub A1:A3 VE C3:C8 HÜCRE ARALIĞINI SEÇER Sub hucresec() Application.ScreenUpdating = False Dim r1 As Range, r2 As Range, rAll As Range Set r1 = Range(""A1"", ""A3"") Set r2 = Range(""C3"", ""C8"") Set rAll = Union(r1, r2) rAll.Select End Sub Aktif hücrenin 3 satır altındaki, iki sütun önündeki hücreyi seçer Sub MoveToCell() ActiveCell.Offset(3, 2).Select End Sub " Hücre veya hücreleri kopyalama "Sub CopyOneArea() Dim sourceRange As Range Dim destrange As Range Dim Lr As Long Lr = LastRow(Sheets(""Sayfa1"")) + 1 Set sourceRange = Sheets(""Sayfa1"").Range(""A1:c10"") Set destrange = Sheets(""Sayfa2"").Range(""A"" & Lr) sourceRange.Copy destrange End Sub Sub CopyOneAreaValues() Dim sourceRange As Range Dim destrange As Range Dim Lr As Long Lr = LastRow(Sheets(""Sayfa2"")) + 1 Set sourceRange = Sheets(""Sayfa1"").Range(""A1:c10"") With sourceRange Set destrange = Sheets(""Sayfa2"").Range(""A"" & Lr). _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:=""*"", _ After:=sh.Range(""A1""), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function Lastcol(sh As Worksheet) On Error Resume Next Lastcol = sh.Cells.Find(What:=""*"", _ After:=sh.Range(""A1""), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column On Error GoTo 0 End Function" Hücre, sütun seçimleri "Aktif sütunu seç Sub SelectEntireColumn() Selection.EntireColumn.Select End Sub 'Aktif satırı seç Sub SelectEntireRow() Selection.EntireRow.Select End Sub 'Tüm hücreleri seç Sub SelectEntireSheet() Cells.Select End Sub 'Dolu hücrelerin altındaki boş hücreyi seç Sub ActivateNextBlankDown() ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop End Sub 'Aktif hücrenin sağ tarafındaki boş hücreyi seç Sub ActivateNextBlankToRight() ActiveCell.Offset(0, 1).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(0, 1).Select Loop End Sub 'Aktif hücrenin sağındaki ve solundaki dolu hücreleri seçer Sub SelectFirstToLastInRow() Set LeftCell = Cells(ActiveCell.Row, 1) Set RightCell = Cells(ActiveCell.Row, 256) If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight) If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft) If LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select End Sub 'Aktif hücrenin altından başlayarak en son hücreye kadar seç Sub SelectDown() Range(ActiveCell, ActiveCell.End(xlDown)).Select End Sub 'A1:A3 VE C3:C8 hücre aralığını seç Sub hucresec() Application.ScreenUpdating = False Dim r1 As Range, r2 As Range, rAll As Range Set r1 = Range(""A1"", ""A3"") Set r2 = Range(""C3"", ""C8"") Set rAll = Union(r1, r2) rAll.Select End Sub 'Aktif hücrenin 3 satır altındaki, iki sütun önündeki hücreyi seçer Sub MoveToCell() ActiveCell.Offset(3, 2).Select End Sub" Hücre_bicimlendir_saydirma (dalga geçme) "Sub hücre_bic_say() For n = 100 To 1 Step -1 Application.StatusBar = n SendKeys ""{Tab}"" For i = 1 To 11 SendKeys ""{down}"" Next SendKeys ""{Tab}"" SendKeys ""{Tab}"" For i = 1 To n SendKeys ""{down}"" Next SendKeys ""%l"" SendKeys ""{Enter}"" Application.Dialogs(xlDialogFormatNumber).Show Next Application.StatusBar = False End Sub" Hücrede 0 (sıfır) varsa durur yoksa atlar "Do While Not IsEmpty(ActiveCell) And ActiveCell <> """" And ActiveCell <> 0 ActiveCell.Offset(1, 0).Select Loop" Hücrede ad soyad'ları 2 textbox'ta göstermek "Sub ayır() b = Split(Range(""a1"").Value, "" "") If UBound(b) > 1 Then TextBox1 = b(0) & "" "" & b(1) TextBox2 = b(2) Else TextBox1 = b(0) TextBox2 = b(1) End If End Sub" Hücrede ay öğrenme (fonksiyon tanımlayarak) "Örnek kullanım 1 'a1 =1 'b1==aycevir(A1) 'Örnek kullanım 2 'a2=02.02.2006 'b2=aycevir(AY(A2)) Function AyCevir(deger As Byte) AyCevir = Choose(deger, ""Ocak"", ""Şubat"", ""Mart"", ""Nisan"", ""Mayıs"", ""Haziran"", _ ""Temmuz"", ""Ağustos"", ""Eylül"", ""Ekim"", ""Kasım"", ""Aralık"") End Function" Hücrede bir sonraki ayın gün sayısı kadar gün ilave etme "Private Sub CommandButton1_Click() For i = 2 To 100 ay = DatePart(""m"", DateAdd(""m"", 1, Cells(i - 1, 2))) yıl = DatePart(""yyyy"", DateAdd(""m"", 1, Cells(i- 1, 2))) For k = 28 To 31 yeni = DateAdd(""d"", k, ""1/"" & ay & ""/"" & yıl) If ay <> DatePart(""m"", yeni) Then Exit For Next k Cells(i, 2) = DateAdd(""d"", k, Cells(i - 1, 2)) Next i End Sub Burada A2 ile A100 arasına A1 deki tarih baz alınarak uygun tarihler yerleştirildi. Ama baktım, bu işte bir gariplik var dedim. Bu kadar basit bir işlemi Excel fonksiyonları çözümlemeli diyerek formüllerimi kurcaladım biraz. Eğer ToolPak-VBA Çözümleyicisi eklentisi aktif ise sizin formülleriniz içinde de EoMonth formülünü bulacaksınız. =EoMonth(ReferansTarih,İstenilenAy) Referans Tarih = Yeni tarihi bulmak için üzerine ilave etmek istediğiniz tarih değeri. İstenilen Ay = Gün sayısını öğrenmek istediğiniz ayı belirtecek olan ve ReferansTarih ten sonraki ayı belirten Tamsayı değişken. Bu Durumda A2 hücresine = A1+EoMonth(A1;1) A3 hücresine = A2+EoMonth(A2;1) ve bu şekilde devam edildiğinde istenilen çözüm bulunmuş oluyor." Hücrede enter a basınca makro çalıştırma "Sub auto_open() Call Ereignis End Sub Sub Ereignis() Sheets(""Sayfa1"").OnEntry = ""färben"" End Sub Sub färben() Farbzahl = Range(""C6"") Range(""B2:D5"").Select With Selection.Interior .ColorIndex = Farbzahl End With Range(""C5"").Select End Sub Sub auto_close() Worksheets(""Sayfa1"").OnEntry = """" End Sub" Hücrede entere basılıncs direk sayfaya gitme "Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Intersect(Target, [a4]) Is Nothing Then Exit Sub If Target <> """" Then Sheets("""" & [a4]).Select End Sub" Hücrede ilk harfler büyük 1 "Option Explicit Sub ChangeText_Proper() Dim cCell As Range Dim TheRg As Range '// Incase No constants of type text in the selection! On Error Resume Next Set TheRg = Selection.SpecialCells(xlCellTypeConstants, 2) If TheRg Is Nothing Then MsgBox ""Yazı yok mu desem!"", vbCritical: Exit Sub On Error GoTo 0 For Each cCell In TheRg cCell = Application.WorksheetFunction.Proper(cCell) Next MsgBox ""Tamam!"", vbInformation End Sub" Hücrede ilk harfler büyük 2 "Sayfanın kod bölümüne 'İlk harfler büyük Private Sub Worksheet_Change(ByVal Target As Range) Target.Value = WorksheetFunction.Proper(Target.Value) End Sub 'Hepsi Büyük Private Sub Worksheet_Change(ByVal Target As Range) Target.Value = WorksheetFunction.UPPER(Target.Value) End Sub 'Hepsi Küçük Private Sub Worksheet_Change(ByVal Target As Range) Target.Value = WorksheetFunction.Lower(Target.Value) End Sub " Hücrede İsim küçük harfli İse o hücreyi silme "Sub kucuksil() Dim gg as double gg = Application.worksheetFunction.CountA(Range(""A:A"")) For i = 1 to gg if LCase(Cells(i,1).text) = Cells(i,1).text then Cells(i,1).value="""" Else End if Next i End sub" Hücrede İsim küçük harfli İse o satırı silme "Sub sil() For i = 1 To 500 If LCase(Cells(i, 1).Text) = Cells(i, 1).Text Then Application.DisplayAlerts = False Cells(i, 1).EntireRow.Delete If Not ActiveCell.Value = """" Then i = i - 1 Application.DisplayAlerts = True End If Next i MsgBox ""Satır Silme İşlemi Tamamlanmıştır."" End Sub" Hücrede karakter say "Sub hucresaymesaj() pir = [a1] MsgBox Len(pir) End Sub" Hücrede kelimelerin ilk harfi büyük "Private Sub Worksheet_Change(ByVal Target As Range) Static dur As Boolean If Target.Address = ""$A$4"" And dur = False Then dur = True Target.Value = UCase(Left(LTrim(Target.Value), 1)) & Right(LTrim(Target.Value), Len(LTrim(Target.Value)) - 1) End If dur = False End Sub" Hücrede saat "Private Sub Worksheet_Activate() Do DoEvents [a1] = Format(Now, ""hh:mm:ss"") Loop End Sub" Hücrede saat (hücreye ad tanımlayarak) "Private Sub Workbook_Open() Call Ayar End Sub Sub Ayar() Dim Zaman As Date Zaman = Now + TimeValue(""00:00:01"") Application.ontime Zaman, ""Yenile"" End Sub Sub Yenile() Range(""Saat"").Value = Now Call Ayar End Sub" Hücrede saat saydırma "Sub clock() If ThisWorkbook.Worksheets(1).Range(""B1"").Value = ""X"" Then Exit Sub ThisWorkbook.Worksheets(1).Range(""A1"").Value = Format(Now, ""hh:mm:ss AM/PM"") Application.OnTime Now + TimeSerial(0, 0, 1), ""clock"" End Sub" Hücrede saat saydırma "Sub Heure() Application.OnTime Now + TimeValue(""00:00:01""), ""Heure"" Range(""A1"") = Time End Sub Sub Arret() Application.OnTime Now + TimeValue(""00:00:01""), ""Heure"", , False End Sub" Hücrede saat saydırma-durdurma "Dim stopit As Boolean 'on top of module! Sub startclock() 'assign start button stopit = False clock End Sub Sub clock() If stopit = True Then Exit Sub ActiveWorkbook.Worksheets(1).cells(1, 1).Value = _ Format(Now, ""hh:mm:ss"") Application.OnTime (Now + TimeSerial(0, 0, 1)), ""clock"" End Sub Sub stopclock() 'assign stop button stopit = True End Sub" Hücrede takvim (calendar) açma "Sayfaya bir Calendar ekle ve adı Calendar1 olsun. Sonra 'ThisWorkbook ' un Open event ine : Private Sub Workbook_Open() Calendar1.Visible = False End Sub 'Bunu da olayın gerçekleşmesini istediğin sayfanın kod bölümüne Private Sub Calendar1_Click() ActiveCell.Value = Calendar1.Value End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = Range(""A2"").Address Then Calendar1.Visible = True Else Calendar1.Visible = False End If End Sub" Hücrede yazılı sayfa var mı yok mu bulur "Sub SayfaAra() Dim i As Integer For i = 1 To Worksheets.Count If Worksheets(i).Name = Range(""B5"").Value Then MsgBox ""Bu isimde bir sayfa var"" Exit Sub End If Next i End Sub" Hücredeki açıklamayı textbox'a alma TextBox1 = Sheets("Sayfa2").Range("A21").Comment.Text Hücredeki ad soyadı ayırmak "A Stünu B Stünu C Stünu Sub hücre_ayir() Dim AD As String Dim SOYAD As String For HÜCRE = 1 To 1000 'DÖNGÜ SAYISINI SİZ VEREBİLİRSİNİZ. BURADA 1000 ALINDI Range(""A"" & HÜCRE).Select UZUNLUK = Len(Range(""A"" & HÜCRE).Text) 'BAŞVURULAN HÜCRENİN METİN UZUNLUĞU For KARAKTER = 1 To UZUNLUK If Mid(Range(""A"" & HÜCRE), KARAKTER, 1) = "" "" Then 'EĞER BAKILAN KARAKTER "" "" İSE AYIRMA İŞLEMİ YAPILACAK VE BİR SONRAKİ HÜCREYE GEÇİLECEK AD = Left(Range(""A"" & HÜCRE), KARAKTER - 1) SOYAD = Mid(Range(""A"" & HÜCRE), KARAKTER + 1, UZUNLUK - Len(AD)) '+1 VE -1 LER BOŞLUĞU ALMAMAK İÇİN EKLENDİ Range(""B"" & HÜCRE).Value = AD Range(""C"" & HÜCRE).Value = SOYAD Exit For End If Next KARAKTER Next HÜCRE Range(""A1"").Select End Sub" Hücredeki adrese ping atma "Sub GetIPs() Dim c As Range 'Range(""A2:A4"") contains the domain names to ping For Each c In ActiveSheet.Range(""A2:A4"") c.Offset(0, 1) = PingAddress(c.Text) Next c End Sub Function PingAddress(strDomain As String) As String Dim fso As Object Dim WshShell As Object Dim RetVal As Long Dim strTemp As String Dim colOutput As New Collection Dim OutputItem Dim i As Long Set WshShell = CreateObject(""Wscript.Shell"") RetVal = WshShell.Run(""cmd /c nslookup.exe -ls "" & strDomain & "" > C:\NSLOOKUPDATA.TXT"", 0, True) Set fso = CreateObject(""Scripting.FileSystemObject"") Set txtstream = fso.OpenTextFile(""C:\NSLOOKUPDATA.TXT"", 1) Do strTemp = txtstream.ReadLine colOutput.Add strTemp Loop Until txtstream.AtEndOfStream txtstream.Close For i = colOutput.Count To 1 Step -1 If Left(colOutput(i), 10) = ""Addresses:"" Then strTemp = Trim(colOutput(i)) PingAddress = Trim(Right(strTemp, Len(strTemp) - InStr(1, strTemp, ""Addresses:"") - 9)) Exit For End If Next If PingAddress = """" Then For i = colOutput.Count To 1 Step -1 If Left(colOutput(i), 8) = ""Address:"" Then strTemp = Trim(colOutput(i)) PingAddress = Trim(Right(strTemp, Len(strTemp) - InStr(1, strTemp, ""Addresses:"") - 9)) Exit For End If Next End If If PingAddress = """" Then PingAddress = ""Domain name not resolved"" Set txtstream = Nothing Set fso = Nothing Set WshShell = Nothing End Function " Hücredeki değere göre makro çalıştırma "Sayfanın kod bölümüne, Mahmut yazarsan Makro1'i çalıştırır. Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target = ""Mahmut"" Then Run ""Module1.Makro1"" End If End Sub" Hücredeki değere göre mesaj veya makro "Private Sub Worksheet_Calculate() Worksheet_Change Range(""VB_Trigger"") End Sub Private Sub Worksheet_Change(ByVal Target As Excel.Range) ' Level 1: Set up the event to watch a single cell. If Target.Address = Range(""VB_Trigger"").Address Then ' Level 2: Perform some action based on the value of the watched cell. Select Case Target.Value Case 1 MsgBox ""Hello"" Case 2 MsgBox ""Goodbye"" Case 3 MsgBox ""Pretty Bird"" End Select End If End Sub" Hücredeki değeri 1 er artırarak yazdırma "Sub pay_wages() Dim counter counter = 1 Range(""B3"").Select Do While ActiveCell.Value < 10 ActiveCell.Value = counter ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True counter = counter + 1 Loop End Sub" Hücredeki değeri birer artırarak yazdırma "Sub herartista_bir_kopya() Dim counter counter = 1 Range(""B3"").Select Do While ActiveCell.Value < 10 ActiveCell.Value = counter ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True counter = counter + 1 Loop End Sub" Hücredeki değerlerin yazı tipi, fontu kalınlık "Range(“D3”).Font.Size=14 Range(“D3”).Font.Name=”Arial” Range(“D3”).Font.Bold=True gibi" HÜcredekİ formÜlÜ deĞİŞen satir sayisi kadar kopyala "Sub Test() x = Cells(65536, 3).End(xlUp).Row Range(""E2"").AutoFill Destination:=Range(""E2:E"" & x) Application.Calculate End Sub " Hücredeki metne çevir olayını userformdan yapmak "Sub GunFormati() Yil = Sheets(""MENÜ"").Range(""AA1"") Ay = Sheets(""MENÜ"").Range(""AA2"") Gun = Range(""D6"") MsgBox Format(DateSerial(Yil, Ay, Gun), ""dddd"") End Sub" HÜcredekİ otomatİk tarİh formati "worksheet in change olayına visual basic kodu: Private Sub Worksheet_Change(ByVal Target As Range) Dim blg As Range If Target.Count > 1 Then Exit Sub Set blg = Range(""A:A"") If Intersect(Target, blg) Is Nothing Then Exit Sub If Len(Target) = 8 Then If InStr(Target, ""."") = 0 Then Target = Left(Target, 2) & ""."" & Mid(Target, 3, 2) & ""."" & Right(Target, 4) End If End Sub kodunu eklerseniz, a sütununa bahsettiğiniz formatta girdiğiniz her tarih kısaltmasını istediğiniz formata çevirir. " HÜcredekİ rakamlari harf karŞiliklarina Çevİrme "lgili hücreleri seçtikten sonra; Kod: Sub Encrypt2() Dim Array1, Array2 Dim i As Integer Dim MyRng As Range Array1 = Array(""a"", ""N"", ""b"", ""t"", ""S"", ""E"", ""T"", ""K"", ""I"", ""Z"") Array2 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 0) For Each MyRng In Selection For i = LBound(Array1) To UBound(Array1) MyRng = WorksheetFunction.Substitute(MyRng, Array1(i), Array2(i)) Next Next End Sub ' Sub Decrypt2() Dim Array1, Array2 Dim i As Integer Dim MyRng As Range Array1 = Array(""a"", ""N"", ""b"", ""t"", ""S"", ""E"", ""T"", ""K"", ""I"", ""Z"") Array2 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 0) For Each MyRng In Selection For i = LBound(Array1) To UBound(Array1) MyRng = WorksheetFunction.Substitute(MyRng, Array2(i), Array1(i)) Next Next End Sub " Hücredeki renge göre filtreleme "Sayfanın kod bölümüne. Function renkkodu(hucre As Range) hucre1 = hucre.Address(ColumnAbsolute:=False, RowAbsolute:=False) renkkodu = Range(hucre1).Font.ColorIndex End Function 'Kaydet, kapat. 'Renkkodu adında yeni bir fonksiyon oluşturmuş olduk. 'Tablonun en sağındaki hücrelere '=renkkodu(adres) yaz (adres rengine göre filtreleme yapacağın hücre) 'Aynı formülü tablonun tüm satırlarına karşılık gelecek şekilde kopyala. 'Böylece sözkonusu hücrenin renk kodunu yazdırmış olduk. 'Şimdi bu kolon üzerinden istediğin renk koduna göre filtre yapabilirsin" Hücredeki sayı kadar çıktı almak "Private Sub CommandButton1_Click() Sheets(""Sayfa1"").PrintOut From:=1, To:=[A1].Value ‘TextBox1.value olursa textboxtali sayı kadar çıktı alınır End Sub" Hücredeki sayı kadar yazıcıdan çıktı alma "Sub ImprimFormulaire() Dim CellPara Range(""A2"") = Application.InputBox(prompt:=""Taper le nombre de copies que vous désirez."", Type:=1) For CellPara = 1 To Range(""A2"") Range(""E13"").Value = Range(""E13"").Value + 1 ActiveSheet.PageSetup.PrintArea = ""$A$5:$I$24"" ActiveWindow.SelectedSheets.PrintOut Copies:=1 Next End Sub" Hücredeki sayının son rakamını 0 (sıfır) yapar "Sub Round() ActiveCell = Application.Round(ActiveCell, -3) End Sub" Hücredeki sayıyı alt veya üst karaktere ve normale çevirir. H2o, co2 "Sub ZahlHoch() Dim r As Range Dim i As Integer For Each r In Selection.Cells If r.Value <> Empty Then For i = 1 To Len(r.Value) If IsNumeric(Mid(r.Value, i, 1)) Then r.Characters(i, 1).Font.Superscript = True Else r.Characters(i, 1).Font.Superscript = False End If Next End If Next End Sub Sub ZahlTief() Dim r As Range Dim i As Integer For Each r In Selection.Cells If r.Value <> Empty Then For i = 1 To Len(r.Value) If IsNumeric(Mid(r.Value, i, 1)) Then r.Characters(i, 1).Font.Subscript = True Else r.Characters(i, 1).Font.Subscript = False End If Next End If Next End Sub Sub ZahlNormal() Dim r As Range Dim i As Integer For Each r In Selection.Cells If r.Value <> Empty Then For i = 1 To Len(r.Value) If IsNumeric(Mid(r.Value, i, 1)) Then r.Characters(i, 1).Font.Superscript = False r.Characters(i, 1).Font.Subscript = False End If Next End If Next End Sub" Hücredeki sayıyı bir üst binliğe tamamlar "Sub son() ActiveCell = Application.Ceiling(ActiveCell, 1000) End Sub" Hücredeki sayıyı bulma "Function sayim(hucre) Dim i As Integer For i = 1 To Len(hucre) sayi = Mid(hucre, i, 1) If IsNumeric(sayi) = True Then sayim = sayim & sayi End If Next i End Function" Hücredeki sayıyı kendi binliğine 0 sıfırlar "Sub bin() ActiveCell = Application.Floor(ActiveCell, 1000) End Sub" Hücredeki veri kadar sütunda genişlik (otomatik) "Thisworkbook a Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range) x = Target.Row y = Target.Column ActiveSheet.Rows(x).AutoFit ActiveSheet.Columns(y).AutoFit End Sub" Hücredeki veri mesaj kutusunda 1 "Sub Düğme1_Tıklat() Set s1 = Sheets(""Sayfa2"") For i = 1 To 100 s1.Cells(i, 1).Activate s1.Rows(i + 1 & "":"" & i + 32).Select Selection.Insert Shift:=xlDown i = i + 32 Next i End Sub" Hücredeki veri mesaj kutusunda 2 "Sub Mesaj() Dim Mes As String Dim i As Integer For i = 6 To 48 Step 2 Mes = Mes & Format(Range(""A"" & i), ""0##,##0"") _ & vbTab & Format(Range(""B"" & i), ""0##,##0"") & vbCrLf Next i MsgBox Mes End Sub" Hücredeki verinin diğer sayfada altbilgi olarak gözükmesi Sheets(1).PageSetup.CenterFooter = Sheets(2).[A1] Hücredeki veriyi txtboxta göstermek 1 "Private Sub UserForm_Activate() i=1 For Each Hucre In Range(""A5:F5"") Controls(""TextBox"" & i) = Hucre i = i + 1 Next End Sub" Hücredeki veriyi txtboxta göstermek 2 "Private Sub UserForm_Activate() range(""a4"").select For i = 1 To 7 Controls(""Textbox"" & i).Value = activecell.offset(i,0).Value Next End Sub" Hücredeki yazı tersinden "Sub ReverseText() Dim strText As String, strReverseText As String Dim intPos As Integer, intLen As Integer strText = Selection.Text intLen = Len(strText) For intPos = 1 To Len(strText) strReverseText = strReverseText & Mid(strText, intLen - intPos + 1, 1) Next intPos ActiveCell.FormulaR1C1 = strReverseText End Sub" HÜcredekİ yazi karakterİnİn rengİne gÖre fİltreleme "Aşağıdaki kodu kopyala ve sayfaya yapıştır. Function renkkodu(hucre As Range) hucre1 = hucre.Address(ColumnAbsolute:=False, RowAbsolute:=False) renkkodu = Range(hucre1).Font.ColorIndex End Function Kaydet ve Editörü kapat. Renkkodu adında yeni bir fonksiyon yaratmış olduk. Toblonun en sağındaki hücrelere =renkkodu(adres) yaz (adres rengine göre filtreleme yapacağın hücre) Aynı formülü tablonun tüm satırlarına karşılık gelecek şekilde kopyala. Böylece sözkonusu hücrenin renk kodunu yazdırmış olduk. à imdi bu kolon üzerinden istediğin renk koduna göre filtre yapabilirsin. Biraz özgün bir çözüm oldu, umarım işine yarar. Başka kullanıcılardan farklı öneriler de gelebilir sanırım." Hücredekine göre hücre temizleme "Sub SİL() Sheets(""Sayfa1"").Select Set ALAN1 = [A2] 'A5:E10 örnek Set ALAN2 = [B2] ' If ALAN1 <> """" Then Sheets(""Sayfa1"").Range(ALAN1).ClearContents If ALAN2 <> """" Then Sheets(""Sayfa2"").Range(ALAN2).ClearContents Sheets(""Sayfa1"").Select MsgBox ""İŞLEM TAMAMLANMIŞTIR."", vbInformation End Sub" Hücreler arasına tıklayınca userform çıkar "Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Dim RaBereich As Range Set RaBereich = Range(""B3:C20,D1:D7"") If Not Intersect(Range(Target.Address), RaBereich) Is Nothing Then UserForm1.Show Set RaBereich = Nothing End Sub" Hücreler arasını seçer ve yakınlaştırır "Sub screen_opt() Range(""A1:N29"").Select ActiveWindow.Zoom = True Range(""A1"").Select End Sub" Hücreler boş geçilemez b1:b8 "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect(Target, Range(""B1:B8"")) Is Nothing Then Exit Sub If row <> 0 Then If Cells(row, col) = """" And Target.row <> row Then MsgBox (""boş geçemezsiniz"") Cells(row, col).Select Exit Sub End If End If If Target.row <> row Then row = Target.row col = Target.Column End If End Sub" HÜcreler renklİ yanip sÖner "A1 İLE M8 HÜCRELERİN ARKASINDA YEŞİL IŞIK 10 DEFA YANAR SÖNER Sub FlashBack() Dim newColor As Integer Dim myCell As Range Dim x As Integer Dim fSpeed Set myCell = Range(""A1:M8"") Application.DisplayStatusBar = True Application.StatusBar = "" Select Cell to Stop and Edit or Wait for Flashing to Stop! "" newColor = 12 fSpeed = 0.2 Do Until x = 10 DoEvents Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Interior.ColorIndex = newColor Loop Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Interior.ColorIndex = xlNone Loop x = x + 1 Loop Application.StatusBar = False Application.DisplayStatusBar = Application.DisplayStatusBar End Sub " Hücrelerde font, renk yazı tipi değiştirme "Sub fontrenk() Dim Cel1 As Range Set Cel1 = Range(""A1:b10"") With Cel1.Font .Bold = True .Italic = True .Name = ""Courier"" .Size = 10 .Color = RGB(255, 0, 0) End With End Sub" Hücrelerde yuvarlama formülü 1 "Sub yuvarla() Range(""A3"").Formula = Round((Range(""a1"").Value + Range(""a2"").Value) / 50000) * 50000 End Sub" Hücrelerde yuvarlama formülü 2 Range("A1").Formula = Round(("A1 HÜCRESİNDEKİ FORMÜL TIRNAKLAR OLMADAN") / 50000) * 50000 Hücrelerde yuvarlama formülü 3 [A1] = "=ROUND(" & [A1].Value & "/50000,0)*50000" Hücrelerdeki formüllerin değere dönüşmesi 1 "Sub metnecevır() Col = 1 DerLig = Cells(65536, Col).End(xlUp).Row For i = 1 To DerLig Cells(i, Col).Formula = ""'"" & Cells(i, Col) Cells(i, Col).Formula = """" & Cells(i, Col) Next i End Sub" Hücrelerdeki formüllerin değere dönüşmesi 2 "Sub formullerideğeryap() For Each fCell In Selection fCell.Value = fCell.Value Next fCell End Sub" Hücrelerdeki verileri birleştirme "Sub birlestir() For a=1 To cells(65536,1).end(xlup).row cells(a,3)=cells(a,1) & "" "" & cells(a,2) Next End Sub " Hücrelerden biri veya birkaçı boş olunca yazdırmayı iptal etme "sayfaların kod bölümlerine Option Explicit 'Thisworkbook a Option Explicit Private Sub Workbook_BeforePrint(Cancel As Boolean) If Worksheets(""Tabelle1"").Range(""A1"").Value = """" Or _ Worksheets(""Tabelle1"").Range(""B3"").Value = """" Or _ Worksheets(""Tabelle1"").Range(""D5"").Value = """" Or _ Worksheets(""Tabelle1"").Range(""D7"").Value = """" Then MsgBox (""Im Tabellenblatt ''Tabelle1'' sind nicht alle ''Pficht''-Zellen gefüllt !"") Cancel = True End If End Sub 'Modüle Option Explicit Sub Makro1() Range(""A1,B3,D5,D7"").Select Range(""D7"").Activate End Sub" Hücrelerden hangisi dolu ise(a2:e2) onu diğer hücreye yaz (a5) "Sub doluhucre_yaz() Dim ran Sheets(""Sayfa1"").Activate ran = range(""A2:E2"").Select For Each ran In Selection If ran > 0 Then range(""A5"").Value = ran.Value End If Next End Sub" Hücrelere 100 yazdırma diğer sütuna 2 satır ekleyerek atama "Sub RempliUnion() Worksheets(""Feuil1"").Activate Set MaPlage = Application.Union(Range(""A1:D10""), Range(""F1:H12"")) MaPlage.Value = 100 End Sub" HÜcrelere verİ gİrİŞİ yapildiktan sonra "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then Target.Offset(1, -1).Select If Target.Column = 3 Then Target.Offset(1, -2).Select If Target.Column = 4 Then Target.Offset(1, -3).Select If Target.Column = 5 Then Target.Offset(1, -4).Select End Sub" HÜcrelerİ boŞ geÇmemek , boŞ geÇecek olursam uyari versİn "change olayı eğer değer girilmedi ise oluşmayacağı için kullanmak gereksizdir. bunun yerine module 'e Kod: Public col As Integer Public row As Integer worksheet in selection change ine Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect(Target, Range(""B1:B8"")) Is Nothing Then Exit Sub If row <> 0 Then If Cells(row, col) = """" And Target.row <> row Then MsgBox (""boş geçemezsiniz"") Cells(row, col).Select Exit Sub End If End If If Target.row <> row Then row = Target.row col = Target.Column End If End Sub " Hücreleri doldurmadan yazdırmaz "Private Sub Workbook_BeforePrint(Cancel As Boolean) If Worksheets(""Tabelle1"").Range(""A1"").Value = """" Or _ Worksheets(""Tabelle1"").Range(""B3"").Value = """" Or _ Worksheets(""Tabelle1"").Range(""D5"").Value = """" Or _ Worksheets(""Tabelle1"").Range(""D7"").Value = """" Then MsgBox (""Im Tabellenblatt ''Tabelle1'' sind nicht alle ''Pficht''-Zellen gefüllt !"") Cancel = True End If End Sub" Hücreleri İmage nesnesi olarak kopyalama "Sub Copy_Sel_Image() Range(""B2:C4"").Copy Range(""B6"").Select ActiveSheet.Pictures.Paste Application.CutCopyMode = False End Sub" Hücreleri resim olarak kopyalamak "Option Explicit Private Sub SaveRngAsJPG(Rng As Range, FileName As String) Dim Cht As Chart, bScreen As Boolean, Shp As Shape bScreen = Application.ScreenUpdating Application.ScreenUpdating = False Set Cht = Workbooks.Add(xlChart).Charts(1) Cht.ChartArea.Clear Rng.CopyPicture xlScreen, xlPicture Cht.Paste With Cht.Shapes(1) .Left = 0 .Top = 0 .Width = Cht.ChartArea.Width .Height = Cht.ChartArea.Height End With Cht.Export FileName, ""JPEG"", False Cht.Parent.Close False Application.ScreenUpdating = bScreen End Sub Sub TestIt2() Dim Rng As Range, Fn As String Set Rng = Range(""A1:H20"") Fn = ""C:\ExcelSayfam.jpg"" SaveRngAsJPG Rng, Fn End Sub" Hücreleri seç 2 çeşit madde imi koysun silsin (sırayla 3 tıklama) "Option Explicit Sub AddBullets() Dim Bullet As String Dim Dash As String Dim Cel As Range Dim Str As String Dim i As Long Bullet = ""• "" Dash = "" - "" 'select which cells to perform an action on For Each Cel In Selection Str = Cel.Value 'If there is already a bullet there then put a dash in its place If Left(Str, Len(Bullet)) = Bullet Then Str = Right(Str, Len(Str) - 2) Cel.Value = Dash & Str Else 'If there is already a dash there then trim back to normal text If Left(Str, Len(Dash)) = Dash Then Str = Trim(Cel.Value) i = Len(Str) - 1 If i >= 0 Then Cel.Value = Trim(Right(Str, i)) End If Else 'Otherwise add the bullet Cel.Value = Bullet & Str End If End If 'Go to the next cell in the selection and do the same thing Next Cel End Sub" Hücrelerin açıklamasını otomatik daralt, rengini değiştir "Sub FormatCommentaire() Dim wks As Worksheet, MyCmt As Comment For Each wks In Worksheets For Each MyCmt In wks.Comments MyCmt.Shape.OLEFormat.Object.AutoSize = True With MyCmt.Shape.OLEFormat.Object.Font .Name = ""Verdana"" .Size = 10 .ColorIndex = 9 .Bold = True End With MyCmt.Shape.OLEFormat.Object.ShapeRange.Fill.ForeColor.SchemeColor = 35 Next MyCmt Next wks End Sub" HÜcrelerİn baŞindakİ ( ' ) tek tirnak sembolÜnÜ makro İle nasil kaldirabİlİrİm. "Önce G1 hücresine 1 yazın sonra aşağıdaki makroyu çalıştırın. Bu makro dolu hücreleri 1 ile çarpar ve ' işareti ortadan kalkar. visual basic kodu: Sub Makro1() Range(""G1"").Select Selection.Copy Selection.SpecialCells(xlCellTypeConstants, 23).Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Range(""A1"").Select End Sub " Hücrenin adını siler yani tanımlanan adını siler "Sub DeleteRangeNames() Dim rName As Name For Each rName In ActiveWorkbook.Names rName.Delete Next rName End Sub" Hücrenin ayrıntılı bilgisi (adresi) "Sub hucre_adresi() Worksheets(1).Select With ActiveCell MsgBox .Address MsgBox .Address(False) MsgBox .Address(, False) MsgBox .Address(False, False) MsgBox .Row & "" .satır"" MsgBox .Column & "" .sütun"" MsgBox ""Satır Numarası: "" & .Row & _ "" - Sütun Numarası:"" & .Column End With End Sub" Hücrenin bulunduğu satır ve sütunu sıra ile mesajla bildirme "Sub ColLigne() Colonne = Left$(ActiveCell.Address(0, 0), (ActiveCell.Column < 27) + 2) Ligne = ActiveCell.Row MsgBox Colonne & Ligne MsgBox Colonne MsgBox Ligne End Sub" Hücrenin çıktısını alma "Sub PrintRpt2() Range(""H1:A2"").PrintOut End Sub" Hücrenin değerlerine göre hücreler renklerle dolar "Private Sub Worksheet_Change(ByVal Target As Range) Select Case Target Case "" "": Target.Interior.ColorIndex = 15 ' gri Case ""A"": Target.Interior.ColorIndex = 3 ' kırmızı Case ""B"": Target.Interior.ColorIndex = 3 Case ""A&B"": Target.Interior.ColorIndex = 3 Case ""-"": Target.Interior.ColorIndex = 4 ' yeşil Case Else: Target.Interior.ColorIndex = xlNone End Select End Sub" Hücrenin içeriği değişince mesaj verir "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column > 0 And Not Target = """" Then MsgBox ""içerik değişti"" End If End Sub" Hücrenin içi kırmızı ,yazılar ise beyaz renkte olsun.Ve italık ve bold olsun "Dim eski Private Sub Worksheet_SelectionChange(ByVal Target As Range) If eski <> Empty Then Range(eski).Interior.ColorIndex = 6 Range(eski).Font.ColorIndex = 3 Range(eski).Font.Bold = False Range(eski).Font.Italic = False End If If Target.Column = 1 And Target.Row < 21 Then Selection.Interior.ColorIndex = 3 Selection.Font.ColorIndex = 6 Selection.Font.Bold = True Selection.Font.Italic = True eski = Target.Address(False, False) End If End Sub" Hücrenin zemin renginin sayısal kodu "Sub renk() yazirenkkodu = Range(""A1"").Font.ColorIndex hucrerenkkodu = Range(""A1"").Interior.ColorIndex End Sub" Hücresi belli aktif kolonu seçer "Sub sec() Range(""A2"").EntireColumn.Select End Sub" Hücresi belli aktif satırı seçer "Sub satsec() Range(""A2"").EntireRow.Select Do While ActiveCell.Value <> """" Loop End Sub" Hücresi belli aktif satırı seçer "Sub satsec() ActiveCell.EntireRow.Select End Sub" Hücreye açıklama ekle (mesaj kutusu ile) "Sub InsertionComment() Dim MyCmt As String Dim LaCell As Range Set LaCell = Application.InputBox(""Cliquez sur une cellule"", Default:=ActiveCell.Address, Type:=8) MyCmt = InputBox(""Inscrivez votre commentaire"") On Error Resume Next With LaCell .AddComment With .Comment .Visible = True .Text Text:=MyCmt End With End With End Sub" Hücreye ad ver, o hücreye yazı yaz, sayfa ismi o olsun "Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range) If Target.Address = Sh.Range(""pir"").Address Then Sh.Name = szRenameSheet(Sh, Target) End If End Sub Private Function szRenameSheet(ByVal Sh As Worksheet, ByVal Target As Excel.Range) As String Dim szName As String If Not IsNull(Target) Then szName = CStr(Target.Value) With Application.WorksheetFunction szName = .Substitute(szName, "":"", """") szName = .Substitute(szName, ""/"", """") szName = .Substitute(szName, ""\"", """") szName = .Substitute(szName, ""?"", """") szName = .Substitute(szName, ""*"", """") szName = .Substitute(szName, ""["", """") szName = .Substitute(szName, ""]"", """") End With szRenameSheet = Left$(szName, 31) End If End Function" Hücreye check atma "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Cancel = True 'Get out of edit mode If LCase(Target.Font.Name) <> ""wingdings 2"" Then Exit Sub If Len(Target.Value) > 1 Then Exit Sub If Trim(Target.Value) = """" Then Target.Value = ""P"" Else Target.Value = """" End If End Sub Not: hücrenin yazı fontu wingdings 2 olmalı." Hücreye değer girince picture görünmesi "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address(False, False) <> ""A1"" Then Exit Sub If Target <> """" Then Image1.Picture = LoadPicture(""C:\1.jpg"") Else Image1.Picture = LoadPicture("""") End If End Sub" Hücreye değer yazınca başka hücreye gitme "Private Sub Worksheet_Change(ByVal Target As Range) If Range(""A1"").Value = 1 Then Range(""D54"").Select ElseIf Range(""A1"").Value = 2 Then Range(""C12"").Select ElseIf Range(""A1"").Value = 3 Then Range(""H45"").Select End If End Sub" Hücreye değer yazınca toplama, başka hücreye yazma "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address(False, False) = ""A1"" And Not Target = """" Then Range(""C1"") = Range(""A1"") + Range(""B1"") End If End Sub" Hücreye formül atama Range(“C3”).Formula =”=D3+D4” - ->Formul atanır. Hücreye formül ekleme "Sub ModifFormule() Application.SendKeys ""{f2}"" 'Envoie la touche F2 For I = 1 To 10 'Boucle pour mettre le curseur à gauche Application.SendKeys ""{f3}"" Next I Application.SendKeys ""{f4}"" 'Pour écrire à droite du signe = Application.SendKeys ""{P}{r}{i}{x}{.}{x}{l}{s}{!}"" Application.SendKeys ""{Enter}"" 'Valide la formule End Sub" Hücreye formül girme, kitaba link "Sub einlesen() datnam = InputBox(""Geben Sie den Dateinamen ein (ohne Endung):"") Range(""B4"").Formula = ""=["" & datnam & "".xls]Tabelle1!A1"" Range(""A4"") = ""Wert aus der Datei "" & datnam & "".xls :"" End Sub" Hücreye formül girmek "Sub EnterFormula() Worksheets(""Sayfa1"").Range(""D6"").Formula = ""=SUM(D2:D5)"" End Sub" HÜcreye formÜl yazdirirken referans ÇeŞİtlerİ "Birçok yolu var da, bir tanesi : Kod: ilkhucre = ActiveCell.Offset(0, 1).Address sonhucre = ActiveCell.Offset(0, 2).Address ActiveCell.Offset(0, 1).Formula = ""=Sum("" & ilkhucre & "":"" & sonhucre & "")"" __ Burası Excel vadisi . __ Teşekkürler raider.. bu syntaxte hata yaptım diye 10 çeşidini denedim ama sen yazınca emin oldum ve başka yerde olduğunu anladım hatanın.. Sorarken address'leri yazmamışım ama oda değil koddaki hata.. ilk satırda ilkhucre'yi hücre referansı olarak alıp sonraki satırda onu toplamda kullanmışım.. Tabi ilkhucre, birincihucre, enilkhucre diye isimler verince bana müstehaktır. Kod: ilkhucre = ActiveCell.Offset(SatirSayisi + 2, 1) .address sonhucre = ActiveCell.Offset(ilkhucre + KacFatura, 1).address " Hücreye gelindiğinde makro çalıştır "A1:A10 arasi hücrelerinin uzerine gelindiginde makro calisin. Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Intersect(Target, Range(""a1:a10"")) Is Nothing Then Exit Sub makroadi() End Sub" HÜcreye gİrdİĞİm sayiya gÖre Şeklİn enİnİn bÜyÜyÜp kÜÇÜlmesİnİ İstİyorum. "Private Sub Worksheet_SelectionChange(ByVal Target As Range) ActiveSheet.Shapes(""Rectangle 1"").Height = Range(""A1"") / 10 * 3.2 * 72 / 2.54 End Sub" Hücreye girilen sayının açıklamada (123,00) şeklinde yazılması "Private Sub Worksheet_Change(ByVal Target As Excel.Range) 'Von Thomas Ramel Dim rngZelle As Range Dim rngNachfolger As Range On Error Resume Next For Each rngZelle In Target rngZelle.NoteText Format(rngZelle.Value, ""#,##0.00"") For Each rngNachfolger In rngZelle.Dependents rngNachfolger.NoteText Format(rngNachfolger.Value, ""#,##0.00"") Next rngNachfolger Next rngZelle End Sub" Hücreye git "Sub GetRange() Dim Rng As Range On Error Resume Next Set Rng = Application.InputBox(prompt:=""Enter range"", Type:=8) If Rng Is Nothing Then MsgBox ""Operation Cancelled"" Else Rng.Select End If End Sub" Hücreye gitme "Sub SelectCell() Application.GoTo Reference:=ActiveSheet.Range(""F1""), Scroll:=True End Sub" Hücreye inputbox ile veri girme "Sub range_input() Dim pir As String pir = InputBox(""Formülde Girebilirsiniz"", ""Hücreye yazılacak metni yazınız"") Range(""A1"").Value = pir End Sub" Hücreye o anki saati , zamanı eklemek "Option Explicit Sub setKey() Application.OnKey ""+^:"", ""EnterTime"" End Sub Sub resetKey() Application.OnKey ""+^:"" End Sub Sub EnterTime() With ActiveCell .Value = Time() .NumberFormat = ""hh:mm:ss"" End With End Sub" Hücreye sayı veya değer girme Range (“B5”).Value=36 - -> B5 hücresine 36 atanır. Hücreye silinecek veri aralığını yaz silsin (sayfa1de a2,b2ye yaz,sayfa1 ve sayfa2den siler) "Sub SİL() Sheets(""Sayfa1"").Select Set ALAN1 = [A2] Set ALAN2 = [B2] If ALAN1 <> """" Then Sheets(""Sayfa1"").Range(ALAN1).ClearContents If ALAN2 <> """" Then Sheets(""Sayfa2"").Range(ALAN2).ClearContents Sheets(""Sayfa1"").Select MsgBox ""İŞLEM TAMAMLANMIŞTIR."", vbInformation End Sub" HÜcreye Şİfre vermek "Örnek kodu biraz değiştirdim. Aşağıdaki şekilde deneyin. Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, [a1:b7]) Is Nothing Or Not Intersect(Target, [c18:c21]) Is Nothing Then If sifre = False Then c = InputBox(""Şifre yazınız. (şifre : 123 )"", ""Onay şifresi"") If c <> 123 Then Application.Undo Else sifre = True End If End If End If Application.EnableEvents = True End Sub" Hücreye tıklayınca otomatik olarak sütunun istenilen genişlikte açılması "Private Sub Worksheet_SelectionChange(ByVal Target As Range) Zelle = Target.Address Select Case Zelle Case ""$D$2"" Range(""$D$2"").ColumnWidth = 52 'entspricht 369 Pixel Case Else Range(""$D$2"").ColumnWidth = 16.43 'entspricht 120 Pixel End Select End Sub" Hücreye tıklayınca otomatik olarak sütunun istenilen genişlikte açılması 2 "Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range Set rng = Columns(""B:B"") If Not (Intersect(Target, rng) Is Nothing) Then rng.ColumnWidth = 30 Else rng.ColumnWidth = 10.71 End If End Sub" Hücreye tıklayınca userform açılsın "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address(False, False) = ""A1"" Then UserForm1.Show End Sub" Hücreye veri girince uyarı alma "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = ""$C$3"" Then MsgBox ""Changed It!"" End If End Sub" Hücreye yazı yaz ve fontunu kalın yap "Sub Labels() With Worksheets(""Sheet1"") .Range(""A1"") = ""Name"" .Range(""B1"") = ""Address"" .Range(""A1:B1"").Font.Bold = True End With End Sub" Hücreye yazı yazmak "Sub Macro1() Sheets(""Sheet1"").Select Range(""A1"").Select ActiveCell.FormulaR1C1 = ""Name"" Range(""B1"").Select ActiveCell.FormulaR1C1 = ""Address"" Range(""A1:B1"").Select Selection.Font.Bold = True End Sub" Hücreyi basamak şeklinde renklendirme "Sub UniondePlage() Dim plg1, plg2, ToutePlage As Range Set plg1 = Sheets(""Feuil1"").Range(""A1:A10"") Set plg2 = Sheets(""Feuil1"").Range(""B10:B20"") Set ToutePlage = Union(plg1, plg2) ToutePlage.Interior.ColorIndex = 5 End Sub" Hücreyi göster virgülden sonra rakam eklesin "Sub pourcentage() Dim mycell, myvaleur, pourcent pourcent = InputBox(""Quel pourcentage appliquer?"") If IsNumeric(pourcent) Then For Each mycell In Application.Selection.Cells myvaleur = mycell.Value If IsNumeric(myvaleur) Then 'teste si la cellule n'est pas vide ou contient une formule If Not (IsEmpty(myvaleur) Or mycell.HasFormula) Then mycell.Value = myvaleur * (pourcent / 100 + 1) End If End If Next mycell End If End Sub" Hücreyi metin biçiminde biçimlendirmek: Range("A1").NumberFormat = "@" HÜcreyİ para bİrİmİ yapmak "Sub Makro1() Range(""A2,B4,E6,F2:F21"").Select Range(""F2"").Activate Selection.NumberFormat = ""[$$-409]#,##0.00"" Range(""A1"").Activate End Sub" Hüreler farklı olursa uyarı mesajı "Private Sub Worksheet_Change(ByVal Target As Range) If [a10].Value <> [c10].Value Then MsgBox (""Girdiğiniz rakamlar farklı"") End Sub" I1:i13 hücrelerinde yazılı yazılı olan veriler 0'a eşit değilse 0 yapar çevirir "Sub ResetTest3() For Each amount In Range(""I1:I13"") If amount.Value <> 0 Then amount.Value = 0 End If Next amount End Sub" If mantığı "Sub OZamanSizeİfinMantığınıAnlatayımSizÇözümleyin() If [A1].Value >= 1 Then [B1].Value = 1 'Eğer A1 >= ise 1 e [B1]=1 yaz If [A1].Value >= 2 And [A1].Value <= 3 Then [B1].Value = 3 'Eğer A1 >= 2 ise ve [A1].Value <= 3 ise [B1]=3 yaz End Sub" If, else "hücrenin a1 hücresi, 'hücre değeri + ise ""hücrede + işareti var"" değil ise ""hücrede + işareti yok"" 'mesajını vermek istediğimizi varsayarsak. If cells(1,1) = ""+"" Then msgbox ""hücrede + işareti var"" Else msgbox ""hücrede + işareti yok"" End If" Inputbox ile sayfa ekleme ve adlandırma "Sub NeuesTabBlatt() Dim NewName As String ActiveSheet.Copy Before:=Sheets(1) 'ganz links anordnen 'ActiveSheet.Copy Before:=ActiveSheet 'links neben Original anordnen NewName = InputBox(""Geben Sie einen Tabellenblattnamen ein"") On Error Resume Next ActiveSheet.Name = NewName End Sub" Inputbox'ta cancel ile textbox'a değer atamak "Sub a() b = InputBox(""aaaa"") If b = """" Then [a1]=1 End If End Sub" Inputbox'ta cancel seÇİlİrse "Aşağıdaki kod sanırım işinizi görecektir. Cancel butonuna bastığınızda A1 hücresine 1 yazar;""[a1]=1"" yazan yere kendi kodunuzu yazınız. selamlar Kod: Sub a() b = InputBox(""aaaa"") If b = """" Then [a1]=1 End If End Sub " Ip numarasını bulan makro "Private Declare Function apiGetUserName Lib _ ""advapi32.dll"" Alias ""GetUserNameA"" _ (ByVal lpBuffer As String, _ nSize As Long) _ As Long ' Sub Auto_Close() Sheets(1).Range(""A1"") = ""Son Kullanıcı :"" Sheets(1).Range(""B1"") = fGetUserName Sheets(1).Range(""C1"") = Now End Sub ' Function fGetUserName() As String Dim lngLen As Long, lngRet As Long Dim strUserName As String strUserName = String$(254, 0) lngLen = 255 lngRet = apiGetUserName(strUserName, lngLen) If lngRet Then fGetUserName = Left$(strUserName, lngLen - 1) End If End Function " İç Içe 12 tane eğer #REF! İç Içe 17 tane if kullanmak "Sub a() If [A1] = 1 Then [A2].Value = 1 ElseIf [A1] = 2 Then [A2].Value = 2 ElseIf [A1] = 3 Then [A2].Value = 3 ElseIf [A1] = 4 Then [A2].Value = 4 ElseIf [A1] = 5 Then [A2].Value = 5 ElseIf [A1] = 6 Then [A2].Value = 6 ElseIf [A1] = 7 Then [A2].Value = 7 ElseIf [A1] = 8 Then [A2].Value = 8 ElseIf [A1] = 9 Then [A2].Value = 9 ElseIf [A1] = 10 Then [A2].Value = 10 ElseIf [A1] = 11 Then [A2].Value = 11 ElseIf [A1] = 12 Then [A2].Value = 12 ElseIf [A1] = 13 Then [A2].Value = 13 ElseIf [A1] = 14 Then [A2].Value = 14 ElseIf [A1] = 15 Then [A2].Value = 15 ElseIf [A1] = 16 Then [A2].Value = 16 ElseIf [A1] = 17 Then [A2].Value = 17 End If End Sub" İç Içe eğer komutu "Sub deneme() MsgBox (IIf(IIf(Range(""I2"").Value = Range(""E2"").Value, Range(""G2"").Value - Range(""F2""), (Range(""G2"").Value - Range(""F2"").Value) - Range(""A500"").Value) > 0, IIf(Range(""I2"").Value = Range(""E2"").Value, Range(""G2"").Value - Range(""F2""), (Range(""G2"").Value - Range(""F2"").Value) - Range(""A500"").Value), 0)) End Sub " İF lerden sadece bİrİ ÇaliŞiyor? "Merhaba aşağıdaki kodda if lerden sadece birini çalıştırıyor eğer >< bu işaretlerin yanına = işareti koyarsam = işareti olan çalışıyor ' Sheets(""canlısayfa"").Select If Range(""L6"") > Range(""m6"") Then UserForm1.Label3.Caption = ""x"" End If If Range(""L6"") < Range(""m6"") Then UserForm1.Label3.Caption = ""$"" End If If Range(""L6"") = Range(""m6"") Then UserForm1.Label3.Caption = ""--"" End If " İKİ hÜcrenİn formÜl sonucu farkli olduĞu zaman msgbox u "Private Sub Worksheet_Change(ByVal Target As Range) If [a10].Value <> [c10].Value Then MsgBox (""Girdiğiniz rakamlar farklı"") End Sub Bu ilk sorunuza cevap olabilir. Çalışmanız ne şekilde tam bilemiyorum ama sanki Koşullu Biçimlendirme daha çok işinizi görür gibi geldi bana. C sütununu seçip Biçim>Koşullu Biçimlendirme>eşit değil>=a1 deyip biçim ayarından da rengini değiştirseniz hem eşit olmayan hücreyi hem de toplamın eşit olup olmadığını görürsünüz. Üstelik Tamam'a tıklama olmadan hemen düzeltme yapabilirsiniz. " İKi saat arasındaki farkı dakika formatında yazmak "Public cik As Integer 'Bu kısım kodlarınızın en başında olmalı. Private Sub UserForm_Activate() Do Label9 = format(Now, ""dd.mm.yyyy hh,mm,ss"") bugün.Value = format(Date, ""dddd"") tarih.Value = format(Now, ""dd,mm,yyyy"") saat.Value = format(Time, ""hh,mm"") DoEvents Loop While cik <> 1 End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) cik = 1 Unload Me End Sub" İKi tarih arasını listele " ‘A1 de başlangıç, A2 de bitiş tarihi, sayfa2 A1 den itibaren aşağıya doğru günleri yazar başlangıç ve bitiş tarihi de dahil Sub Listele() Baslangic = Sheets(""Sayfa1"").Range(""A1"").Value Bitis = Sheets(""Sayfa1"").Range(""A2"").Value Gun = Baslangic Satir = 1 Do Sheets(""Sayfa2"").Cells(Satir, 1).Value = Gun Gun = Gun + 1 Satir = Satir + 1 Loop While Gun <= Bitis End Sub" İKi tarih arasını listele " ‘A1 de başlangıç, B1 de bitiş tarihi, A2 den itibaren aşağıya doğru günleri yazar başlangıç ve bitiş tarihi hariç Private Sub CommandButton1_Click() Dim i, j As Integer j = Worksheets(""Sayfa1"").Range(""B1"") - Worksheets(""Sayfa1"").Range(""A1"") If j < 2 Then Exit Sub End If For i = 1 To j - 1 Cells(i + 1, 1) = Cells(1, 1) + i Next i End Sub" İKİ tarİh arasindakİ verİlerİn lİstbox1 'e aktarilmasi "Private Sub CommandButton1_Click() Dim x As Date For i = 2 To Sheets(""EVRAK DEFTERİ"").Cells(65536, 1).End(xlUp).Row x = Sheets(""EVRAK DEFTERİ"").Cells(i, 3) If x >= CDate(ComboBox1.Value) And x <= CDate(ComboBox2.Value) Then listbox1.additem Sheets(""EVRAK DEFTERİ"").Cells(i, 1) & ""-"" & Sheets(""EVRAK DEFTERİ"").Cells(i, 2) & ""-"" & Sheets(""EVRAK DEFTERİ"").Cells(i, 3) & ""-"" & Sheets(""EVRAK DEFTERİ"").Cells(i, 4) & ""-"" & Sheets(""EVRAK DEFTERİ"").Cells(i, 5) End If Next i End Sub" İKİ tarİh arasini sÜz ve "Range(""AZ2:BC65536"").ClearContents Set ad = Sheets(""DATA"") sat = WorksheetFunction.CountA(ad.Range(""A2:A65536"")) c = 0 d = 0 For satr = 2 To sat + 2 If ad.Cells(satr, 2).Value >= CDate(TextBox1.Value) And ad.Cells(satr, 2).Value <= CDate(TextBox2.Value) Then c = c + 1 d = d + ad.Cells(satr, 4).Value Cells(c + 1, 52) = ad.Cells(satr, 1).Value Cells(c + 1, 53) = ad.Cells(satr, 2).Value Cells(c + 1, 54) = ad.Cells(satr, 3).Value Cells(c + 1, 55) = ad.Cells(satr, 4).Value End If Next satr If c = 0 Then MsgBox (""Bu tarihler arası veri bulunamadı"") Exit Sub End If TextBox4 = d adres = ""ANAMENÜ!AZ2:BC"" & c + 1 ListBox1.RowSource = adres End Sub " İLgİlİ sayfaya gİtme "Gitmek İstenilen Sayfalara Bir Buton ekleyin.Sayfaların adları Ana Sayfa ve UL185213 olsun.Modülede şu kodları yazın Kod: Sub UL185213() Sheets(""UL185213"").Select Range(""A1"").Select End Sub UL185213 Sayfasınada aynı butondan ekleyin. Modülede Kod: Sub anasayfa() Sheets(""Ana Sayfa"").Select Range(""A1"").Select End Sub" İLk aÇiliŞta optİonbutton1 İŞaretlİ olsun "Private Sub UserForm_Initialize() OptionButton1.Value = True End Sub " İLk boş hücreyi seçer "Range(""A1"").select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop '----------------- 'A1 dolu ise A2 yi seçecektir, oda dolu ise A3 ü 'Kaydınızı sıra ile kaydedebilirsiniz." İLk harf büyük diğerleri küçük (yazım düzeni) "Sub SentenceCase() For Each cell In Selection.Cells s = cell.Value Start = True For i = 1 To Len(s) ch = Mid(s, i, 1) Select Case ch Case ""."" Start = True Case ""?"" Start = True Case ""a"" To ""z"" If Start Then ch = UCase(ch): Start = False Case ""A"" To ""Z"" If Start Then Start = False Else ch = LCase(ch) End Select Mid(s, i, 1) = ch Next cell.Value = s Next End Sub" İLk harfler büyük yazım düzeni "Sub TitleCase() Dim cell As Range For Each cell In Selection.Cells If cell.HasFormula = False Then cell = Application.Proper(cell) End If Next End Sub" İLk satıra yaztığım tarihe bakarak tek bir hareket ile o aya ait çalışma günlerini aşağıya doğru diğer hücrelere açmak. Yani aradaki tatil günlerini otomatik olarak yok saymak veya,sayfa açmak için kullandığım makroda düğmeye tıkladığımda c1 hücresine bakarak o ayın çalışma günlerine göre aşağıya sayfalar açtır "Sub sayfaolustur() Application.ScreenUpdating = False ad = ActiveSheet.Name tarih = [c1] [c:c].ClearContents songun = Day(DateSerial(Year(tarih), Month(tarih) + 1, 1) - 1) For a = 1 To songun deg = Weekday(DateSerial(Year(tarih), Month(tarih), a), vbMonday) If deg < 6 Then c = c + 1 Cells(c, ""c"") = DateSerial(Year(tarih), Month(tarih), a) Sheets.Add After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = a Sheets(ad).Select End If Next End Sub" İMlecİn boŞ hÜcreyİ atlamasi "Private Sub Worksheet_selectionChange(ByVal Target As Range) If Target.Column = 1 And IsEmpty(Target.Next) Then Target.Offset(0, 2).Select End Sub " İMlecİn ÜÇ hÜcre atlamasi "Üç hücre atlayıp 4 üncü hücre seçilecek sanırım Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, [c1:c20]) Is Nothing Then Exit Sub If Target <> 0 Then Target.Offset(0, 4).Select End Sub" İMleç textbox4'te iken textbox6'ya veya textbox7'ye tıklansa bile imleç textbox5'e gider "Private Sub TextBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox5.SetFocus End Sub Private Sub TextBox4_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then TextBox5.SetFocus ElseIf KeyCode = 40 Then TextBox5.SetFocus End If End Sub " İNdis hücredekinin vba kodu " Sub indistest2() sonuc = WorksheetFunction.Index(Sheets(""tablo"").Range(""A1:G16""), _ WorksheetFunction.Match(Sheets(""tablo"").Range(""K1""), _ Sheets(""tablo"").Range(""A1:A16""), 0), _ WorksheetFunction.Match(Sheets(""tablo"").Range(""L1""), _ Sheets(""tablo"").Range(""A1:G1""), 0)) MsgBox (sonuc) End Sub" İNdİs İŞlevİnİn vba kodu olarak karŞiliĞi "Hüseyin bey verdiğiniz her iki kodda gayet güzel çalışıyor. Her ikisinide kullanmam mümkün,fakat tercihimi birinci koddan yana kullanıyorum. Vermiş olduğunuz kodda bazı değişiklikler yaparak tek satıra kadar indirdim, belki bu kısaltmadan istifade eden arkadaşlar olur düşüncesiyle kodun kısaltılmış halini veriyorum. selamlar visual basic kodu: Sub indisdene() sonuc = Cells(Range(""A2:A16"").Find([K1]).Row, Range(""B1:G1"").Find([L1]).Column).Value MsgBox (sonuc) End Sub " İNdis vba kodu " Sub indisdene() sonuc = Cells(Range(""A2:A16"").Find([K1]).Row, Range(""B1:G1"").Find([L1]).Column).Value MsgBox (sonuc) End Sub " İNdİsİn vba makrosu hakkinda "Sub dene() MsgBox WorksheetFunction.Index([ADI], 2) End Sub" İNput ile sayfa kopyalama "Sub inputsheetcopy() Dim TBName$, WBName$ TBName = InputBox(""Blattname:"") If TBName = """" Then Exit Sub WBName = InputBox(""Dateiname:"") If WBName = """" Then Exit Sub Worksheets(TBName).Copy ActiveWorkbook.SaveAs WBName ActiveWorkbook.Close End Sub" İNputbox çift satırlı örnek "Sub DecideUserInput() Dim bText As String, bNumber As Integer ' here is the INPUTBOX-function : bText = InputBox(""Insert in a text"", ""This accepts any input"") ' here is the INPUTBOX-method : bNumber = Application.InputBox(""Insert a number"", ""This accepts numbers only"", , , , , , 1) MsgBox ""You have inserted :"" & Chr(13) & _ bText & Chr(13) & bNumber, , ""Result from INPUT-boxes"" End Sub" İNputbox İÇİne yazilan karakterler "*****" Şeklİnde Çikabİlİr mİ? "Public MyPass ' Bu satir Modulün General_Declarations kisminda olucak (en üstte). ' Sub MainProgram() ' 'Ana programin kodlari buralarda ' ' 'Asagidaki satirla ""*"" karakterli sifre girme kutusunu çagiriyoruz ' MyPasswBox ' 'Eger kullanici bir sifre girdiyse, 'asagidaki satirlarda, kullanicinin girdigi sifreyi '""çiplak"" olarak görüntülüyoruz. ' 'Sizin yapmaniz gereken If - End If satirlari arasinda 'sifre kontrolunu yaptirip, kodlari çalismaniza göre yönlendirmek olucak If MyPass <> """" Then MsgBox ""Girilen sifre : "" & MyPass End If ' 'Ana programin kodlarinin devami buralarda ' End Sub ' Sub MyPasswBox() Dim PassWForm Set PassWForm = ThisWorkbook.VBProject.VBComponents.Add(3) PassWForm.properties(""Width"") = 200 PassWForm.properties(""Height"") = 90 Set NewTextBox = PassWForm.Designer.Controls.Add(""forms.TextBox.1"") PassWForm.properties(""Caption"") = ""Sifre girisi !"" With NewTextBox .Width = 120 .Height = 18 .Left = 8 .Top = 20 .PasswordChar = ""*"" .ForeColor = vbRed End With Set NewCommandButton1 = PassWForm.Designer.Controls.Add(""forms.CommandButton.1"") With NewCommandButton1 .Caption = ""Vazgeç"" .Height = 18 .Width = 50 .Left = 140 .Top = 18 End With Set NewCommandButton2 = PassWForm.Designer.Controls.Add(""forms.CommandButton.1"") With NewCommandButton2 .Caption = ""Tamam"" .Height = 18 .Width = 50 .Left = 140 .Top = 42 End With With PassWForm.CodeModule X = .CountOfLines .InsertLines X + 1, ""Sub CommandButton1_Click()"" .InsertLines X + 2, ""Unload Me"" .InsertLines X + 3, ""End Sub"" .InsertLines X + 4, ""Sub CommandButton2_Click()"" .InsertLines X + 5, ""MyPass = TextBox1"" .InsertLines X + 6, ""Unload Me"" .InsertLines X + 7, ""End Sub"" .InsertLines X + 8, ""Sub UserForm_Activate()"" .InsertLines X + 9, ""Me.SpecialEffect=3"" .InsertLines X + 10, ""End Sub"" End With VBA.UserForms.Add(PassWForm.Name).Show ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=PassWForm End Sub" İNputbox ile aktif hücreye açıklama ekleme "Sub input_comment() Dim pir Dim n As Variant Dim l As Long pir = InputBox(""Yazı yazın açıklama olarak eklesin."", _ ""input_açıklama"") n = ActiveCell.NoteText l = Len(n) If l > 0 Then ActiveCell.NoteText Text:="" / "" & pir, Start _ :=l + 1 Else ActiveCell.NoteText Text:=pir End If End Sub" İNputbox ile filtreleme ve filtreleneni silme "Sub Filtrele() sec = InputBox(""Neyi Filtrelemek İstiyorsunuz"", , ""Pazartesi"") Range(""A1:"" & [A65536].End(xlUp).Address).AutoFilter 1, sec End Sub Sub FiltrleneniSil() Range(""A2:"" & [A65536].End(xlUp).Address).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp End Sub" İNputbox la doğru rakamı girmeye zorlama "Sub hesaplama() zamoranı: z = InputBox(""Zam oranını giriniz ! Ondalık kısmı varsa virgülle ayırınız !"") If Not IsNumeric(z) Then GoTo zamoranı Cells(1, 23) = (z + 100) / 100 End Sub" İNputbox la mesaj alma "Sub GetInput() Dim MyInput MyInput = InputBox(""Enter your name"") MsgBox (""Hello "") & MyInput End Sub" İNputbox yılı yaz, ayları sayfa olarak eklesin "Sub Jahreskalender() Dim strJahr As String Dim lngNumSheets As Long Dim intI As Integer, intJahr As Integer strJahr = InputBox(""Kalender anlegen für Jahr:"", , Year(Date)) If strJahr = """" Or Not IsNumeric(strJahr) Then Exit Sub intJahr = CInt(strJahr) lngNumSheets = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 12 Workbooks.Add Application.SheetsInNewWorkbook = lngNumSheets Application.DisplayAlerts = False Application.ScreenUpdating = False Windows(1).Caption = ""Jahreskalender "" & strJahr For intI = 1 To 12 Worksheets(intI).Activate Call MonatAnlegen(intJahr, intI) Next intI Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Private Sub MonatAnlegen(intJahr As Integer, intMonat As Integer) Dim intI As Integer Dim lngDate As Long lngDate = CLng(DateSerial(intJahr, intMonat, 1)) ActiveSheet.Name = Format(lngDate, ""mmmm"") 'zB ""Januar"" Range(""A1"") = ""Datum"" Range(""C1"") = ""Eintragung"" Range(""D1"") = ""Geburtstage"" With Range(""A1:D1"") With .Font .Bold = True .Size = 10 .ColorIndex = 6 End With .Interior.ColorIndex = 11 End With intI = DateSerial(intJahr, intMonat + 1, 1) - lngDate + 1 Range(""A2"") = lngDate Range(""A3"").Formula = ""=A2+1"" Range(""A3:A"" & intI).FillDown Range(""A2:A"" & intI).Copy Range(""A2:A"" & intI).PasteSpecial (xlValues) Range(""A2:A"" & intI).NumberFormat = ""dd.mm.yy"" Columns(1).Copy Columns(2) Range(""B1"") = ""Tag"" Range(""B1"").HorizontalAlignment = xlRight Range(""B2:B"" & intI).NumberFormat = ""dddd"" 'zB ""Samstag"" Range(""C2"").Select intI = 2 Do Until IsEmpty(Cells(intI, 1)) Select Case Weekday(Cells(intI, 1)) Case vbSaturday Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 40 'Orange Case vbSunday Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 3 'Rot End Select Cells(intI, 3).Value = Feiertag(Cells(intI, 1).Value) intI = intI + 1 Loop ActiveSheet.UsedRange.Columns.AutoFit End Sub 'http://home.t-online.de/home/t.igel/xlostern.htm Private Function Feiertag(datum As Long) As String Dim temp As Variant Feiertag = """" Select Case Month(datum) Case 1 Select Case Day(datum) Case 1 Feiertag = ""Neujahr"" Case 6 Feiertag = ""Heiligen 3 Könige"" End Select Case 2 To 6 osSo = OsterSo(Year(datum)) Select Case datum Case osSo - 48 Feiertag = ""Rosenmontag"" Case osSo - 47 Feiertag = ""Fasching"" Case osSo - 46 Feiertag = ""Aschermittwoch"" Case osSo - 2 Feiertag = ""Karfreitag"" Case osSo - 1 Feiertag = ""Karsamstag"" Case osSo Feiertag = ""Ostersonntag"" Case osSo + 1 Feiertag = ""Ostermontag"" Case DateSerial(Year(datum), 5, 1) Feiertag = ""Tag der Arbeit"" Case osSo + 39 Feiertag = ""Christi Himmelfahrt"" Case osSo + 48 Feiertag = ""Pfingstsamstag"" Case osSo + 49 Feiertag = ""Pfingstsonntag"" Case osSo + 50 Feiertag = ""Pfingstmontag"" Case osSo + 60 Feiertag = ""Fronleichnam"" End Select Case 8 Select Case Day(datum) Case 15 Feiertag = ""Maria Himmelfahrt"" End Select Case 10 Select Case Day(datum) Case 3 Feiertag = ""Tag der Dt. Einheit"" End Select Case 11 temp = DateSerial(Year(datum), 12, 25) Select Case datum Case DateSerial(Year(datum), 11, 1) Feiertag = ""Allerheiligen"" Case (temp - Weekday(temp, vbMonday) - 32) Feiertag = ""Buß- und Bettag"" End Select Case 12 Select Case Day(datum) Case 24 Feiertag = ""Heilig Abend"" Case 25 Feiertag = ""1. Weihnachtsfeiertag"" Case 26 Feiertag = ""2. Weihnachtsfeiertag"" Case 31 Feiertag = ""Silvester"" End Select End Select End Function Private Function OsterSo(jahr As Integer) As Variant Dim d As Variant d = (((255 - 11 * (jahr Mod 19)) - 21) Mod 30) + 21 OsterSo = DateSerial(jahr, 3, 1) + d + (d > 48) + _ 6 - ((jahr + jahr \ 4 + d + (d > 48) + 1) Mod 7) End Function" İNputboxa göre boş satırları seçmek "Sub BoslariSec() On Error Resume Next Dim x, y As Integer x = InputBox(""x değerini gir"") y = InputBox(""y değerini de gir"") Range(""A1"").Clear For Each sec In Range(""J"" & x & "":J"" & y) If sec.Value = """" Then k = k + sec.Address & "","" End If Next sec k = Mid(k, 1, Len(k) - 1) Range(k).Select End Sub" İNputboxa göre çıktı sayısı "Sub Makro1() On Error Resume Next kaç = InputBox(""Bu sayfadan kaç adet yazdırmak istiyorsunuz?"") ActiveWindow.SelectedSheets.PrintOut Copies:=kaç, Collate:=True End Sub" İNputboxa göre çıktı sayısı2 "Sub yazdir() ilk=inputbox(""Yazdırmaya başlanacak Sayfa Numarası"") son=inputbox(""sonlandırılacak Sayfa Numarası"") Kopyasayisi=inputbox(""Kopya Sayısını Giriniz"") ActiveWindow.SelectedSheets.PrintOut From:=ilk, To:=son, Copies:=Kopyasayisi, Collate:=True End Sub" İNputboxla a1 e veri girme "Sub Wert_aus_inputBox_in_A1() Cells(1, 1) = InputBox(""Bitte geben Sie den Wert ein, der in Zelle A1 geschrieben werden soll:"") End Sub" İNputbox'la bulma "Sub FindExactMatch() Dim MyStr As String, InfoMsg As String Dim Rng1 As String, LookupValue As String Dim MyQ As VbMsgBoxResult Dim FoundRng As Variant MyStr = Trim(Application.InputBox(""Aranacak metni girin !"", _ ""Find exact match "")) If Not MyStr = ""False"" Then Set FoundRng = Cells.Find(MyStr, LookIn:=xlValues, LookAt:=xlPart) If Not FoundRng Is Nothing Then Rng1 = FoundRng.Address FoundRng.Activate ResumeSub2: If Right(FoundRng.Value, 1) <> "" "" Then LookupValue = FoundRng.Value & "" "" MyData = Split(LookupValue, "" "", , vbTextCompare) For i = LBound(MyData) To UBound(MyData) If MyData(i) = MyStr Then InfoMsg = ""Aranan metin "" & FoundRng.Address(False, False) _ & "" hücresinde bulundu."" _ & vbCrLf & vbCrLf & ""Bulunan hücrenin içeriği :"" _ & vbCrLf & vbCrLf & FoundRng.Value & vbCrLf _ & vbCrLf & ""Aramaya devam etmek istiyormusunuz ?"" MyQ = MsgBox(InfoMsg, vbInformation + vbYesNo, _ ""Arama sonucu "") If MyQ = vbYes Then GoTo ResumeSub1: Exit Sub End If Next Else MsgBox ""Aranan değer bulunamadı !"", vbInformation, ""Arama sonucu "" Exit Sub End If ResumeSub1: Set FoundRng = Cells.FindNext(FoundRng) If Rng1 = FoundRng.Address Then MsgBox ""Aranan değerden başka bulunamadı !"", vbInformation, _ ""Arama sonucu "" Exit Sub End If FoundRng.Activate GoTo ResumeSub2: End If Set FoundRng = Nothing End Sub " İnputboxla sayfa bulma "Private Sub CommandButton3_Click() On Error GoTo 10 Application.DisplayAlerts = False sor = InputBox(""Silinecek sayfa adını yazınız."") If sor = """" Then Exit Sub mesaj = MsgBox(""silmek istediğinizden eminmisiniz"", vbYesNo) If mesaj = vbNo Then Exit Sub Sheets("""" & sor).Delete Exit Sub 10 MsgBox ""sayfa bulunamadı"" End Sub" İnputboxla sayfaya gitme "Private Sub CommandButton2_Click() On Error Resume Next Dim Sayfa As Variant Sayfa = InputBox(""Sayfa Numarasını Giriniz"", ""UYARI"", ""1"") Sheets(Sayfa).Select End Sub" İNputboxlarda yazılanları çarpar "Sub CalcPay() On Error GoTo HandleError Dim hours Dim hourlyPay Dim payPerWeek hours = InputBox(""Please enter number of hours worked"", ""Hours Worked"") hourlyPay = InputBox(""Please enter hourly pay"", ""Pay Rate"") payPerWeek = CCur(hours * hourlyPay) MsgBox ""Pay is: "" & Format(payPerWeek, ""$##,##0.00""), , ""Total Pay"" HandleError: End Sub" İNputboxta cancel'e değer aatmak "Sub a() b = InputBox(""aaaa"") If b = """" Then [a1]=1 End If End Sub" İNputboxta soru cevap "Sub DecideUserInput() Dim bText As String, bNumber As Integer ' here is the INPUTBOX-function : bText = InputBox(""Insert in a text"", ""This accepts any input"") ' here is the INPUTBOX-method : bNumber = Application.InputBox(""Insert a number"", ""This accepts numbers only"", 1) MsgBox ""You have inserted :"" & Chr(13) & _ bText & Chr(13) & bNumber, , ""Result from INPUT-boxes"" End Sub ‘Accepted input: ‘0 A formula ‘1 A number ‘2 Text ‘4 A logical value (True or False) ‘8 A cell reference, e.g. a Range-object ‘16 An error value, e.g. #N/A ‘64 An array of values " İNputboxta tarih formatı "Sub Tarihi_Kontrol_Et() vade = InputBox(""Vade tarihini aa/gg/2004 Formatında Giriniz"", ""Lütfen Vade Kriter Tarihini Giriniz"", ""00.00.2004"") If vbOKCancel = vbOK Then If vade = Range(""A1"").Text Then MsgBox ""Tamam"" End If End Sub" İNputboxta yazılan hücreye gider "Sub GetRange() Dim Rng As Range On Error Resume Next Set Rng = Application.InputBox(prompt:=""Enter range"",Type:=8) If Rng Is Nothing Then MsgBox ""Operation Cancelled"" Else Rng.Select End If End Sub" İNternet bağlantısı olduğunda veya olmadığında raporunu word'e yazar "Option Explicit Sub MessageAbrufen() Dim appWord As Object Dim docWord As Object Dim txt As String txt = LoadURL(Range(""A1"").Value) Set appWord = CreateObject(""Word.Application"") Set docWord = appWord.documents.Add With docWord.Range With .Font .Name = ""Courier New"" .Size = 8 End With .Text = txt End With appWord.Visible = True Set appWord = Nothing Set docWord = Nothing End Sub Function LoadURL(URL As String) As String Dim IEApp As Object Dim IEDocument As Object Set IEApp = CreateObject(""InternetExplorer.Application"") IEApp.Visible = False IEApp.Navigate URL Do: Loop Until IEApp.Busy = False Do: Loop Until IEApp.Busy = False Set IEDocument = IEApp.Document LoadURL = IEDocument.Body.innerText IEApp.Quit Set IEDocument = Nothing Set IEApp = Nothing End Function" İNternet sayfası açma istenilen adres "Sub LanceIE() Dim IE As Object Set IE = CreateObject(""InternetExplorer.Application"") IE.Navigate ""http://dj.joss.free.fr"" IE.AddressBar = True IE.MenuBar = True IE.Toolbar = True IE.Width = 800 IE.Height = 600 IE.Resizable = True IE.Visible = True Set IE = Nothing End Sub" İNternete dial up la bağlanmak için " Private Declare Function IsNetworkAlive Lib ""SENSAPI.DLL"" (ByRef lpdwFlags As Long) As Long Private Declare Function InternetAutodial Lib ""wininet.dll"" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Boolean Private Declare Function InternetAutodialHangup Lib ""wininet.dll"" (ByVal dwReserved As Long) As Boolean Const NETWORK_ALIVE_LAN = &H1 Const NETWORK_ALIVE_WAN = &H2 Sub baglan() If IsNetworkAlive(lRet) = 0 Then InternetAutodial 1, 0 End If End Sub Sub kes() If IsNetworkAlive(lRet) <>0 Then InternetAutodialHangup 0 End If End Sub ‘otomatik bağlanması için de Sub baglan() If IsNetworkAlive(lRet) = 0 Then InternetAutodial 2, 0 End If End Sub ‘şifre için Call Shell(""c:\windows\system32\rasdial.exe "" & Chr$(34) & ""ttnet"" & Chr$(34) & "" "" & ""sirenko"" & "" "" & ""sifre"")" İNternetten dosya indirmek "Option Explicit Private Declare Function InternetGetConnectedState _ Lib ""wininet"" ( _ ByRef lpdwFlags As Long, _ ByVal dwReserved As Long) _ As Long Private Declare Function InternetAutodial _ Lib ""wininet.dll"" ( _ ByVal dwFlags As Long, _ ByVal dwReserved As Long) _ As Long Private Declare Function InternetAutodialHangup _ Lib ""wininet.dll"" ( _ ByVal dwReserved As Long) _ As Long Private Declare Function URLDownloadToFile Lib ""urlmon"" _ Alias ""URLDownloadToFileA"" ( _ ByVal pCaller As Long, _ ByVal szURL As String, _ ByVal szFileName As String, _ ByVal dwReserved As Long, _ ByVal lpfnCB As Long) _ As Long Private Const INTERNET_CONNECTION_CONFIGURED = &H40 Private Const INTERNET_CONNECTION_LAN = &H2 Private Const INTERNET_CONNECTION_MODEM = &H1 Private Const INTERNET_CONNECTION_OFFLINE = &H20 Private Const INTERNET_CONNECTION_PROXY = &H4 Private Const INTERNET_RAS_INSTALLED = &H10 Private Const INTERNET_AUTODIAL_FORCE_ONLINE = 1 Private Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2 Private Const S_OK = &H0 Private Const E_ABORT = &H80004004 Private Const E_ACCESSDENIED = &H80070005 Private Const E_OUTOFMEMORY = &H8007000E Const strDownLoad As String = ""http://www.salipazari-meb.gov.tr/programlar/kayit.zip"" Const strDest As String = ""C:\kayit.zip"" Sub GetFile() Dim DwnLoadOK As Boolean DwnLoadOK = DownloadFile(strDownLoad, strDest) If Not DwnLoadOK Then MsgBox ""Error downloading "" & strDownLoad & vbCr & IeState Else MsgBox ""Succesfully downloaded:= "" & strDest End If End Sub Public Function DownloadFile( _ URL As String, _ SaveAsFileName As String) As Boolean Dim lngRetVal As Long DownloadFile = False End Function Private Function IeState() As String Dim Ret As Long Dim Msg As String InternetGetConnectedState Ret, 0& If (Ret And INTERNET_CONNECTION_CONFIGURED) = _ INTERNET_CONNECTION_CONFIGURED Then _ Msg = ""Local system has a valid connection to the Internet,"" & _ vbCr & ""but it may or may not be currently connected."" If (Ret And INTERNET_CONNECTION_LAN) = _ INTERNET_CONNECTION_LAN Then _ Msg = Msg & vbCr & ""Uses a local area network"" & _ ""to connect to the Internet."" If (Ret And INTERNET_CONNECTION_MODEM) = _ INTERNET_CONNECTION_MODEM Then _ Msg = Msg & vbCr & ""A modem is used to connect to the Internet."" If (Ret And INTERNET_CONNECTION_OFFLINE) = _ INTERNET_CONNECTION_OFFLINE Then _ Msg = Msg & vbCr & ""Local system is in offline mode."" If (Ret And INTERNET_CONNECTION_PROXY) = _ INTERNET_CONNECTION_PROXY Then _ Msg = Msg & vbCr & ""Uses a proxy server to connect to the Internet."" If (Ret And INTERNET_RAS_INSTALLED) = INTERNET_RAS_INSTALLED Then _ Msg = Msg & vbCr & ""System has RAS installed."" If Msg <> """" Then IeState = Msg End Function" İP numarasi gÖsterecek makro "Aşağıdakileri söz konusu dosyada yeni bir module yerleştirip, kaydedin. Dosyayı kapattığınız anda 1nci sayfada A1, B1 ve C1 hücrelerinde gerekli bilgiler yazılacaktır. Kod: Private Declare Function apiGetUserName Lib _ ""advapi32.dll"" Alias ""GetUserNameA"" _ (ByVal lpBuffer As String, _ nSize As Long) _ As Long ' Sub Auto_Close() Sheets(1).Range(""A1"") = ""Son Kullanıcı :"" Sheets(1).Range(""B1"") = fGetUserName Sheets(1).Range(""C1"") = Now End Sub ' Function fGetUserName() As String Dim lngLen As Long, lngRet As Long Dim strUserName As String strUserName = String$(254, 0) lngLen = 255 lngRet = apiGetUserName(strUserName, lngLen) If lngRet Then fGetUserName = Left$(strUserName, lngLen - 1) End If End Function " İSmi belirle aktif sayfayı kitap halinde kaydedip kapatsın "Sub Blatt_als_Datei() datname = InputBox(""Dateiname:"") ActiveSheet.Copy ActiveWorkbook.SaveAs datname ActiveWorkbook.Close End Sub" İStedİĞİm mÜkerrer olanlari sİlmesİ(satir sİlme olabİlİr) "denedim de, bir mantık hatası var son 2 kodda (silinen satırın yerine geçen alt satır gibi) düzeltilmiş ve biraz daha hızlandırılmışı. 1. veriler sıralı değilse Kod: z = Cells(65536, 1).End(xlUp).Row Application.ScreenUpdating = False For i = 1 To z For j = z To i + 1 Step -1 If Cells(i, 1) = Cells(j, 1) Then Range(j & "":"" & j).EntireRow.Delete End If Next j Next i 2. veriler sıralı ise Kod: z = Cells(65536, 1).End(xlUp).Row Application.ScreenUpdating = False For i = 1 To z For j = z To i + 1 Step -1 If Cells(i, 1) = Cells(j, 1) Then Range(j & "":"" & j).EntireRow.Delete Else Exit For End If Next j Next i " İStediğiniz sayfa hariç sayfadaki verileri temizler "Sub Sayfalarısıfırla() '/_ 'İstediğiniz sayfa hariç diğer sayfadaki verileri temizler 'a.küçükkaya / pir Dim i As Integer For i = 1 To Sheets.Count If Worksheets(i).Name <> ""Rapor"" Then Worksheets(i).Cells.Delete Selection.Style = ""Normal"" 'hücreyi reset eder yani ilk açılıştaki haline çevirir End If Next i End Sub Resimleri de silmek için ilave edin For j = 1 To Shapes.Count Shapes(j).Delete Next j" İStediğiniz sayfaya gider "İstediğiniz sayfaya gider Sub Ali_sayfasına_git() Sheets(""ALİ"").Select End Sub Sonraki Sayfaya geçmek için kodlar Sub SayfaSeçSonraki() On Error Resume Next If ActiveSheet.Index = Worksheets.Count Then Worksheets(1).Select Else On Error Resume Next Worksheets(ActiveSheet.Index + 1).Select End If End Sub Önceki Sayfaya geçmek için kodlar Sub SayfaSeçÖnceki() On Error Resume Next If ActiveSheet.Index = Worksheets.Count Then Worksheets(-1).Select Else Worksheets(ActiveSheet.Index - 1).Select End If End Sub " İStedİĞİnİz sayfaya gİder "İSTEDİĞİNİZ SAYFAYA GİDER Sub Ali_sayfasına_git() Sheets(""ALİ"").Select End Sub Sonraki Sayfaya geçmek için kodlar Sub SayfaSeçSonraki() On Error Resume Next If ActiveSheet.Index = Worksheets.Count Then Worksheets(1).Select Else On Error Resume Next Worksheets(ActiveSheet.Index + 1).Select End If End Sub Önceki Sayfaya geçmek için kodlar Sub SayfaSeçÖnceki() On Error Resume Next If ActiveSheet.Index = Worksheets.Count Then Worksheets(-1).Select Else Worksheets(ActiveSheet.Index - 1).Select End If End Sub " İStediğiniz yerde istediğiniz uyarıyı verdirin "Sub assist() Application.Assistant.Visible = True Assistant.Animation = msoAnimationIdle Set SB = Assistant.NewBalloon SB.Animation = msoAnimationCheckingSomething SB.BalloonType = msoBalloonTypeButtons SB.Heading = ""istediğiniz uyarı!!"" SB.Text = _ ""Ich bin Dein persönlicher Assistent"" If SB.Show = msoBalloonButtonOK Then Assistant.Visible = False End If end sub" İStedİĞİnİz yerde İstedİĞİnİz uyariyi verdİrİn "istediğiniz yerde istediğiniz uyarıyı verdirin Kod: Sub assist() Application.Assistant.Visible = True Assistant.Animation = msoAnimationIdle Set SB = Assistant.NewBalloon SB.Animation = msoAnimationCheckingSomething SB.BalloonType = msoBalloonTypeButtons SB.Heading = ""istediğiniz uyarı!!"" SB.Text = _ ""Ich bin Dein persönlicher Assistent"" If SB.Show = msoBalloonButtonOK Then Assistant.Visible = False End If end sub " İStenen araliĞi temİzler "İSTENİLEN ARALIKTAKİ VERİLERİ TEMİZLER Sub temizle() Range(""a1:a20"").Value = """" Range(""b21:b23"").Value = """" Range(""a1"").Select End Sub " İStenen hÜcreye verİ gİrme "BU KODLA İSTEDİĞİNİZ HÜCRELERE VERİ GİREBİLİRSİNİZ Sub başlıkyaz() Range(""a1"").Select ActiveCell.FormulaR1C1 = ""ali"" Range(""b1"").Select ActiveCell.FormulaR1C1 = ""veli"" Range(""c1"").Select ActiveCell.FormulaR1C1 = ""selami"" Range(""d1"").Select ActiveCell.FormulaR1C1 = ""ayşe"" Range(""e1"").Select ActiveCell.FormulaR1C1 = ""fatma"" Range(""f1"").Select ActiveCell.FormulaR1C1 = ""lale"" End Sub " İStenilen hücreleri dikey yazdırır "Sub PrintRpt1() 'To control orientation Sheets(1).PageSetup.Orientation = xlLandscape Range(""f7"").PrintOut Copies:=1 End Sub" İStenilen hücreye gitme "Sub hücresec() 'Gitmek istenilen hücreyi seçer Dim Rng As Range On Error Resume Next Set Rng = Application.InputBox(prompt:=""Gitmek istediğiniz Hücreyi Yazınız"", Type:=8) If Rng Is Nothing Then MsgBox ""Seçimden vazgeçtiniz"" Else Rng.Select End If End Sub" İStenilen makronun kodlarının görülmesi "Sub ViewCode() Application.Goto Reference:=""insertrow"" End Sub" İStenilen saat ve dakikada makro çalıştırma "Sub Alarm() Dim beepat As String beepat = InputBox(""Give Alarm at"", ""hh:mm:ss "" & _ Format(Now, ""mm:hh""), ""17:00"") If beepat = """" Then MsgBox ""cancelled"" Exit Sub End If Application.OnTime TimeValue(beepat), ""BeepMe"" End Sub" İStenilen saat ve dakikada makro çalıştırma 2 "Sub CountDownTimer() Dim beepat As String beepat = InputBox(""Count down Timer hh:mm:ss i.e. 10:00"", _ ""Time now is "" & Format(Now, ""hh:mm:ss""), ""3:00"") If beepat = """" Then MsgBox ""cancelled"" Exit Sub End If Application.OnTime (Now + TimeValue(beepat)), ""BeepMe"" End Sub Sub beepme() Beep Application.OnTime (Now + TimeSerial(0, 0, 0.8)), ""beepme2"" End Sub Sub beepme2() Beep Application.OnTime (Now + TimeSerial(0, 0, 0.8)), ""beepme3"" End Sub Sub beepme3() Beep End Sub" İStenilen saatte çıktı alma "Sub ProgrammeLaMacroTime() ' lance MacroImpression à 10h25 heures Application.OnTime TimeValue(""10:25:00""), ""MacroImpression"", , True End Sub Sub MacroImpression() 'cette macro imprime la feuille Feuil1 ThisWorkbook.Sheets(""Feuil1"").PrintOut End Sub" İStenilen saatte makro çalıştırma "Sub date_macro() datemacro = InputBox(""Örnek zaman "" & Time & _ "". zamanı belirt o zamanda makro çalışsın?"") If datemacro = """" Then Exit Sub Application.OnTime TimeValue(datemacro), ""makro1"" 'makro1 isimli makro çalışır End Sub Sub makro1() MsgBox ""makro1 çalıştı"" End Sub" İStenilen sayfa isminden başkasını eklemez "Sub Abfrage() Dim sh Dim kw As String kw = InputBox(""Bitte geben Sie Ihr Kennwort ein "") If kw = ""Meier"" Then Sheets(""Meier"").Visible = True If kw = ""Müller"" Then Sheets(""Müller"").Visible = True If kw = ""Schulz"" Then Sheets(""Schulz"").Visible = True If kw = ""Weber"" Then Sheets(""Weber"").Visible = True If kw = ""admin"" Then For Each sh In ActiveWorkbook.Sheets If sh.Name <> ""Auswahl"" Then sh.Visible = True Next sh End If End Sub" İStenilen sayfadaki istenilen hücreye gitme "Sub AllerA() Application.Goto Reference:=Worksheets(""Feuil1"").Range(""A154""), Scroll:=True End Sub" İstenilen sayfalar haricinde gizleme "For a = 1 To Sheets.Count If Sheets(a).Name <> ""GELİR İCMAL"" And Sheets(a).Name <> ""ANASAYFA"" Then Sheets(a).Visible = xlVeryHidden Next" İStenİlen sayfayi aÇabİlmek "Sub DENEME() Dim i As Double i = Sheets(""ANASAYFA"").Range(""a1"").Value Worksheets("""" & i).Select End Sub " İStenilen siteyi açma "Sub excelerator() Dim MyShell As Object Set MyShell = CreateObject(""WScript.Shell"") MyShell.Run ""http://www.excelerator.de"" End Sub" İStenİlen sutunu gİzlemek "istenilen sutun gizle-göster gizleme Kod: Sub Macro2() colx = InputBox(""Hangi sutunu gizlemek istiyorsun?"") ' Select Sheet1 and Sheet2 and make Sheet1 the active sheet. Sheets(Array(""Sayfa1"", ""Sayfa2"")).Select Sheets(""Sayfa1"").Activate ' Loop through each sheet in the selected sheets and hide column ' A on that sheet. For Each Sht In ActiveWindow.SelectedSheets Sht.Columns("""" & colx & "":"" & colx & """").Hidden = True Next End Sub göstermek: Kod: Sub Macro1() colx = InputBox(""Hangi sutunu göstermek istiyorsun?"") ' Select Sheet1 and Sheet2 and make Sheet1 the active sheet. Sheets(Array(""Sayfa1"", ""Sayfa2"")).Select Sheets(""Sayfa1"").Activate ' Loop through each sheet in the selected sheets and hide column ' A on that sheet. For Each Sht In ActiveWindow.SelectedSheets Sht.Columns("""" & colx & "":"" & colx & """").Hidden = false Next End Sub " İStenİlen sÜrece ekranda kalan userform "Private Sub UserForm_Activate() ' Récupération de l'heure d'affichage de la BdD TimeDebut = Timer ' Donne la main à excel pour facilité l'affichage de la BdD DoEvents ' Boucle tant que 2 secondes ne se sont pas écoulé While Timer < TimeDebut + 10 Wend ' Fermeture de la BdD Unload Me End Sub " İStenilen sürece ekranda kalan userform "Private Sub UserForm_Activate() ' Récupération de l'heure d'affichage de la BdD TimeDebut = Timer ' Donne la main à excel pour facilité l'affichage de la BdD DoEvents ' Boucle tant que 2 secondes ne se sont pas écoulé While Timer < TimeDebut + 10 Wend ' Fermeture de la BdD Unload Me End Sub" İStenilen sütunu gizleme "Sub Macro2() colx = InputBox(""Hangi sutunu gizlemek istiyorsun?"") ' Select Sheet1 and Sheet2 and make Sheet1 the active sheet. Sheets(Array(""Sayfa1"", ""Sayfa2"")).Select Sheets(""Sayfa1"").Activate ' Loop through each sheet in the selected sheets and hide column ' A on that sheet. For Each Sht In ActiveWindow.SelectedSheets Sht.Columns("""" & colx & "":"" & colx & """").Hidden = True Next End Sub" İStenilen sütunu gösterme "Sub Macro1() colx = InputBox(""Hangi sutunu göstermek istiyorsun?"") ' Select Sheet1 and Sheet2 and make Sheet1 the active sheet. Sheets(Array(""Sayfa1"", ""Sayfa2"")).Select Sheets(""Sayfa1"").Activate ' Loop through each sheet in the selected sheets and hide column ' A on that sheet. For Each Sht In ActiveWindow.SelectedSheets Sht.Columns("""" & colx & "":"" & colx & """").Hidden = false Next End Sub" İStenilen yazıcıyı aktif yapmak için "Sub PrinterSec() Application.ActivePrinter = ""\\PRINTSERVER\HP LaserJet 1100 (MS) on Ne02:"" End Sub Aşağıdaki kodları ThisWorkbook kısmına yazarak başka bir alternatifi de deneyebilirsiniz. Dosya açılırken belli bir yazıcı aktive edilmekte, kapanırken de başka bir yazıcı aktive edilmektedir. Private Sub Workbook_Open() Application.ActivePrinter = ""Microsoft Office Document Image Writer on Ne01:"" End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.ActivePrinter = ""\\PRINTSERVER\HP LaserJet 1100 (MS) on Ne02:"" End Sub " İş Günlerini hesaplayan fonksiyon "Function Isgunu(Bas_Trh As Date, Son_Trh As Date) Dim Say As Integer For mars = Son_Trh To Bas_Trh Step -1 If Weekday(mars, vbMonday) = 6 Then Say = Say + 1 If Weekday(mars, vbMonday) = 7 Then Say = Say + 1 Next mars Isgunu = (Son_Trh - Bas_Trh) + 1 - Say End Function '=Isgunu(A1;B1)" İŞGÜnlerİne aİt sheet aÇmak. "Sub Auto_Open() Dim tarih As Date, i As Integer 'tarih olarak sizin isgunu fonksiyonundan çıkan 'tarihi kullandım tarih = isgunu(Date) If Format(tarih, ""mmmm-yy"") & "".xls"" <> ThisWorkbook.Name Then If MsgBox(""Bu aya ait bir çalışma kitabı olmadığı için yeni sayfa açmadım.Şinci farklı kaydet yapacağım kabul mü?"", vbYesNo) = vbYes Then ThisWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & Format(Date, ""mmmm-yy"") Sheets.Add.Name = Format(tarih, ""dd-mm-yyyy"") For Each sh In ThisWorkbook.Sheets If sh.Name <> Format(tarih, ""dd-mm-yyyy"") Then Application.DisplayAlerts = False 'veri varsa sormadan silecek. sh.Delete End If Next Exit Sub Else MsgBox ""bu kitaba da yeni sayfa açmadım, farklı kaydette yapmadım, hiç bir şey yapmadım"" Exit Sub End If End If Sayfaadi = Format(tarih, ""dd-mm-yyyy"") Application.DisplayAlerts = true For i = 1 To Sheets.Count If Sheets(i).Name = Sayfaadi Then Exit Sub Next i Sheets.Add.Name = Sayfaadi End Sub" İŞGÜnlerİne aİt yenİ sayfa oluŞturma "Sub Auto_Open() Sheets(Sheets.Count).Copy After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = Format(Date, ""dd mm yy"") End Sub" İşLemci bilgilerini hücreye aktarma "Sub InfoCPU() Dim MyOBJ As Object Dim MyCPU As Variant Dim MyMsg As String On Error Resume Next Set MyOBJ = GetObject(""WinMgmts:"").instancesOf _ (""Win32_Processor"") If Err.Number <> 0 Then MsgBox ""WMI yüklenmemiş! Programdan çıkılacak "", vbExclamation, _ ""Windows Management Instrumentation"" Exit Sub On Error GoTo 0 End If For Each MyCPU In MyOBJ [A1] = ""İşlemci : "" & Trim(MyCPU.Name) [A2] = ""Üretici Firma : "" & MyCPU.Manufacturer [A3] = ""CPU ID : "" & MyCPU.ProcessorId [A4] = ""CPU hızı : "" & MyCPU.CurrentClockSpeed [A5] = ""Max CPU hızı : "" & MyCPU.MaxClockSpeed Next End Sub " İşLemci hızı "Option Explicit Sub ProcessorSpeed() Dim objWMI As Object Dim Cpu As Object Set objWMI = GetObject(""WinMgmts:"").instancesOf(""Win32_Processor"") '// Don't forget the computer maybe multiprocessor! For Each Cpu In objWMI MsgBox Cpu.Name & "" "" & Cpu.CurrentClockSpeed & "" Mhz"", _ vbInformation Next Set objWMI = Nothing End Sub" İşLemciyi uyutma "Declare Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long) 'Kullanımı; '1000 milisaniye kadar işlemciyi durdurur. ""DoEvents"" 'e benzer. Sub cal() Call Sleep(1000) End Sub" İşLetim sistemini öğrenme "Function OSis32BIT() As Boolean OSis32BIT = False If InStr(Application.OperatingSystem, ""32-bit"") Then OSis32BIT = True End If End Function Sub TestOSis32BIT() If OSis32BIT Then MsgBox ""You use a 32bit operating system"", , _ Application.OperatingSystem Else MsgBox ""You don't use a 32bit operating system"", , _ Application.OperatingSystem End If End Sub" İşLev ekle penceresi "Sub Dialog_35() Application.Dialogs(xlDialogFunctionWizard).Show End Sub" Jpeg resmi ekleme ve silme "Sub auto_open() Dim jpgekle As Object Set jpgekle = ActiveSheet.Pictures.Insert(""C:\arnold.jpg"") Application.Wait (Now + TimeSerial(0, 0, 10)) jpgekle.Delete End Sub" Kaç satır seçili olduğunu bulur "Sub Count() mycount = Selection.Rows.Count MsgBox mycount End Sub" Kaç sayfa var hesaplasın "Sub sayfasay() say= Application.Sheets.Count MsgBox (say) End Sub" Kaçıncı hafta olduğunu bulan fonksiyon "Function hafta(tarih As Date) As Integer ek = 7 - Day(DateSerial(Year(tarih), 1, 1) + 7 - Weekday(DateSerial(Year(tarih), 1, 1), vbMonday)) hafta = ((tarih + 7 - Weekday(tarih, vbMonday)) - DateSerial(Year(tarih), 1, 1) + 1 + ek) / 7 End Function" Kaçıncı hafta olduğunu bulan fonksiyon "Dim tarih As Date, hafta As Integer tarih = Date hafta = DatePart(""ww"", tarih, vbMonday, vbFirstJan1) MsgBox ""Bugün: "" & Date & "" --> Yılın "" & hafta & "". Haftası""" Kaçıncı hafta olduğunu bulan fonksiyon kodları "=Kwoche(J20) Function Kwoche(d) Dim t t = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1) Kwoche = ((d - t - 3 + (Weekday(t) + 1) Mod 7)) \ 7 + 1 End Function" Kaçıncı hafta, hangi gün sorusunun cevabı "Private Sub CommandButton1_Click() MsgBox Weekday(Date, vbMonday) Select Case Weekday(Date, vbMonday) Case 1: gun = ""Bugün pazartesi, "" Case 2: gun = ""Salı"" Case 3: gun = ""Çarşamba "" Case 4, 5: gun = ""Hafta içi son günler "" Case Is > 5: gun = ""Hafta Sonu"" Case Else: gun=""Böyle bir gün olamaz"" End Select MsgBox gun End Sub" Kaçıncı satır kaçıncı sütun "Sub MyPosition() myRow = ActiveCell.Row & "".satır"" myCol = ActiveCell.Column & "".sütun"" MsgBox myRow & "" , "" & myCol End Sub" Kaçıncı satır kaçıncı sütuna ne girecen "Sub negircen() sutun = InputBox(""Kaçıncı Sütun:"") satir = InputBox(""Kaçıncı Satır:"") yaz = InputBox(""yaz:"") Range(""A1"").Select ActiveCell.Offset(satir - 1, sutun - 1).Range(""A1"").Select ActiveCell.Value = yaz End Sub" Kalın olanları topla "kullanılışı '=kalintop(a1:a10) Function kalintop(rngCells As Range) As Double Application.Volatile Dim cell As Range kalintop = 0 On Error Resume Next For Each cell In rngCells If cell.Font.Bold Then kalintop = kalintop + cell.Value Next cell End Function" Kapalı dosyalardan verileri toplayarak almak "Aşağıdaki kod ile ""C:\Temp\"" klasöründe kapalı durumda olan tüm çalışma 'kitaplarındaki Sheet1 isimli sayfalarında A1:E10 aralığındaki tüm hücreler 'toplanarak, kodun yazıldığı kitapta yine A1:E10 aralığındaki hücrelere yazılırlar. Const MyPath As String = ""C:\Temp\"" Const MySh As String = ""Sheet1"" Dim MyArg As String ' Sub Test() 'Raider Dim MyFile As String Dim i As Long, j As Integer Range(""A1:E10"").ClearContents MyFile = Dir(MyPath & Application.PathSeparator & ""*.xls"", vbDirectory) Do While MyFile <> """" If MyFile = ThisWorkbook.Name Then GoTo ResumeSub: MyArg = ""'"" & MyPath & ""["" & MyFile & ""]"" & MySh & ""'!R"" For j = 1 To 5 For i = 1 To 10 Cells(i, j) = Cells(i, j) + ExecuteExcel4Macro(MyArg & i & ""C"" & j) Next Next ResumeSub: MyFile = Dir Loop End Sub" Kapalı kitap ontime " ‘kitabı kapat, vakit geldiğinde açılıp ve gerekli uyarıyı verir Sub dene() Application.OnTime Now + TimeValue(""00:00:10""), ""deneme"" End Sub Sub deneme() MsgBox ""oldu"" End Sub" Kapalı kitap ontime "Public soru Sub auto_open() soru = MsgBox(""Gizlensin mi?"", vbYesNo) If soru = vbYes Then Application.Visible = False Call dene End If End Sub Sub dene() Application.OnTime Now + TimeValue(""00:00:03""), ""deneme2"" End Sub Sub deneme2() günler = MsgBox(""günü dolanlar var"" & vbCrLf & ""Excel çalışma kitabı açılsın mı?"", vbYesNo) If günler = vbNo Then Call dene Else Application.Visible = True End If End Sub Private Sub Workbook_Activate() If soru = vbYes Then Application.Visible = False End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) soru2 = MsgBox(""Zamanlanmış görevi olan dosyada kapansın mı?"", vbYesNo) If soru2 = vbYes Then Exit Sub Cancel = True End Sub" Kapalı olan sayfanın boş olan bir alttaki satırına kayıt "Sub datagonder() Rows(2).Copy Windows(""notdata.xls"").Activate son = [a65356].End(3).Row + 1 Rows(son).PasteSpecial Windows(""notisleme.xls"").Activate End Sub" Kapali durumdakİ c:\test.Xls dosyasi aÇilacak ve İÇİne c:\userform1.Frm İlave edİldİkten sonra kaydedİlerek kapatilacaktir "Kullanıcıya göndereceğin B.xls dosyasındaki kod; Kod: Sub Test() Myfile = ""C:\Test.xls"" MyForm = ""C:\UserForm1.frm"" If Dir(Myfile) <> Empty And Dir(MyForm) <> Empty Then Workbooks.Open Myfile On Error GoTo ErrHandler: Workbooks(Dir(Myfile)).VBProject.VBComponents.Import MyForm Workbooks(Dir(Myfile)).Close SaveChanges:=True MsgBox ""İşlem tamam !"" Exit Sub Else MsgBox Myfile & "" ve "" & MyForm & "" dosyalarının isimlerini ve doğru"" _ & "" yerleştirildiğini kontrol edin !"" Exit Sub End If ErrHandler: Select Case Err.Number Case 60061 MsgBox ""Dosyada "" & Dir(MyForm) & "" zaten mevcut !"" Case Else MsgBox Err.Number & vbCrLf & Err.Description End Select Workbooks(Dir(Myfile)).Close SaveChanges:=False End Sub Yapılan iş; yukarıdaki kodlar çalıştırıldığında kapalı durumdaki C:\Test.xls dosyası açılacak ve içine C:\UserForm1.frm ilave edildikten sonra kaydedilerek kapatılacaktır. Kodlar çalıştırılmadan önce yapılması gereken ise; kullanıcının C:\Test.xls ve C:\UserForm1.frm dosyalarını kendi bilgisayarlarında, kodlarda belirtilen yerlere yerleştirmiş olmasıdır." Kapanış-çıkış makrosu "Sub auto_close() Sheets(""Bir"").Select Range(""C2"").Select End Sub" KapaniŞ mesaji "Public Sub CommandButton13_Click() cevap = MsgBox("" PROGRAMI KAPATMAK İSTEDİĞİNİZDEN EMİNMİSİNİZ ? "", vbYesNo, """") If cevap = vbNo Then Exit Sub Unload Me Application.Quit If cevap = vbYes Then auto_close End If End Sub Private Sub CommandButton13_Click() Cevap = MsgBox("" PROGRAMI KAPATMAK İSTEDİĞİNİZDEN EMİNMİSİNİZ ? "", vbYesNo, """") If Cevap = vbNo Then Exit Sub Unload Me kullanici = Application.UserName saat = Format(Now, ""hh:mm:ss"") tarih = Format(Date, ""d mmmm yyyy dddd"") sor = MsgBox("" GÖRÜŞMEK ÜZERE "" & kullanici & Chr(10) & Chr(10) & _ ""………..BÜROSU/ 0212 …………."" & Chr(10) & Chr(10) & _ ""Tarih : "" & tarih & Chr(10) & Chr(10) _ & ""Saat : "" & saat & Chr(10) & Chr(10) _ & ""………. BÜROSU iyi Çalışmalar Diler."" & Chr(10) & Chr(10) & _ ""Dosyanızın kaydedilmesini istiyor musunuz?"", 4, """") If sor = vbYes Then ActiveWorkbook.Save ActiveWorkbook.Close Else Application.DisplayAlerts = False ActiveWorkbook.Close 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