Makro Kod Listesi
Excel de kullanılan Makro Kodlarının Listesi


güncelleştirme otomatik

ID : 961
ISLEM : güncelleştirme otomatik
MAKRO KODU : Private Sub Workbook_Open() Application.AskToUpdateLinks = False ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources End Sub

haftanın gününü bulma

ID : 962
ISLEM : haftanın gününü bulma
MAKRO KODU : 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ü?

ID : 963
ISLEM : haftanin kaçinci günü?
MAKRO KODU : Private Sub CommandButton1_Click() MsgBox Application.Weekday(CDate(TextBox1), 2) End Sub

hangi butona basıldığını bildirir (commandbutton)

ID : 964
ISLEM : hangi butona basıldığını bildirir (commandbutton)
MAKRO KODU : ö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

ID : 965
ISLEM : hangi hücreye gitmek istiyorsan gider scroll yaparak
MAKRO KODU : Sub git_hucre() Application.Goto Reference:=Range("Q6"), Scroll:=True End Sub

hangi hücreye yazarsan yaz a1 kaydetsin

ID : 966
ISLEM : hangi hücreye yazarsan yaz a1 kaydetsin
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$1" Then Application.MoveAfterReturn = False

hangi sayfalar korumalı öğrenin

ID : 967
ISLEM : hangi sayfalar korumalı öğrenin
MAKRO KODU : 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

ID : 968
ISLEM : hangi tuşa basarsan o makro çalışır
MAKRO KODU : 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

ID : 969
ISLEM : hangi tuşa basıldığını bulan api
MAKRO KODU : 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 -

hangi tuşa basildiğini bilebilmek

ID : 970
ISLEM : hangi tuşa basildiğini bilebilmek
MAKRO KODU : İş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

ID : 971
ISLEM : hard disk formatlama
MAKRO KODU : SHFormatDrive hwnd, 2, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK

harddisk hakkında ayrıntılı rapor

ID : 972
ISLEM : harddisk hakkında ayrıntılı rapor
MAKRO KODU : 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

ID : 973
ISLEM : harddisk seri numarası alma a1 hücresine
MAKRO KODU : 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

ID : 974
ISLEM : harddiske format atma
MAKRO KODU : Sub FormatageDSK() ValRetour = Shell("C:\WINDOWS\RUNDLL32.EXE shell32,SHFormatDrive", 1) End Sub

harddiskin boş alanını vs.. öğrenme

ID : 975
ISLEM : harddiskin boş alanını vs.. öğrenme
MAKRO KODU : 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

ID : 976
ISLEM : hareket ettirilemeyen userform
MAKRO KODU : Private Sub UserForm_Layout() Me.Move Application.Width / 2 - Me.Width / 2, Application.Height / 2 - Me.Height / 2 End Sub

hareketsiz inputbox

ID : 977
ISLEM : hareketsiz inputbox
MAKRO KODU : 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

ID : 978
ISLEM : hareketsiz userform
MAKRO KODU : 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ığı

ID : 979
ISLEM : hareketsiz userform başlığı
MAKRO KODU : 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 -

harf değişimi

ID : 980
ISLEM : harf değişimi
MAKRO KODU : 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 ise alttaki hücreye yaz 1

ID : 981
ISLEM : harf sayısı 100'den fazla ise alttaki hücreye yaz 1
MAKRO KODU : 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 ise alttaki hücreye yaz 2

ID : 982
ISLEM : harf sayısı 100'den fazla ise alttaki hücreye yaz 2
MAKRO KODU : 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

ID : 983
ISLEM : hata mesajını yoksaymak
MAKRO KODU : on error resume next

hata mesajını yoksaymak

ID : 984
ISLEM : hata mesajını yoksaymak
MAKRO KODU : Sub Test() On Error GoTo ExitProc: ' ' ' Kodlar ' ' ' Exit Sub ExitProc: End Sub

hataya mesaj yazma 1

ID : 985
ISLEM : hataya mesaj yazma 1
MAKRO KODU : 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

ID : 986
ISLEM : hataya mesaj yazma 2
MAKRO KODU : 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

ID : 987
ISLEM : hedef ara penceresi
MAKRO KODU : Sub Dialog_36() Application.Dialogs(xlDialogGoalSeek).Show End Sub

hedef hücreye gitme

ID : 988
ISLEM : hedef hücreye gitme
MAKRO KODU : 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

ID : 989
ISLEM : hepsi bir arada toplama çarpma bölme
MAKRO KODU : 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 -

her 3 saniyede alt alta formül girme

ID : 990
ISLEM : her 3 saniyede alt alta formül girme
MAKRO KODU : 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

* Görseller ve İçerik tekif hakkına sahip olabilir