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


ekle (hücre) penceresi

ID : 781
ISLEM : ekle (hücre) penceresi
MAKRO KODU : Sub Dialog_38() Application.Dialogs(xlDialogInsert).Show End Sub

eklentiler penceresi

ID : 782
ISLEM : eklentiler penceresi
MAKRO KODU : Sub Dialog_03() Application.Dialogs(xlDialogAddinManager).Show End Sub

eklentileri mesajla öğrenin

ID : 783
ISLEM : eklentileri mesajla öğrenin
MAKRO KODU : Sub afficheComplement() For Each a In AddIns MsgBox a.FullName Next a End Sub

eklentinin varlığını kontrol etme

ID : 784
ISLEM : eklentinin varlığını kontrol etme
MAKRO KODU : Sub testUtilitAnalyse() If AddIns("Query manager").Installed = True Then MsgBox "Utilitaire d'analyse installé" Else MsgBox "Utilitaire d'analyse non installé" End If End Sub

ekran çözünürlüğü ayarlama

ID : 785
ISLEM : ekran çözünürlüğü ayarlama
MAKRO KODU : 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) End Sub Sub ChangeTo1024_768() Call ChangeScreenResolution(1024, 768) 'buradaki değerleri değiştirerek ayarlayabilirsiniz. End Sub

ekran çözünürlüğünü ayarlatma

ID : 786
ISLEM : ekran çözünürlüğünü ayarlatma
MAKRO KODU : 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) End Sub Sub ChangeTo1024_768() Call ChangeScreenResolution(1024, 768) End Sub

ekran çözünürlüğünü ayarlattırmak

ID : 787
ISLEM : ekran çözünürlüğünü ayarlattırmak
MAKRO KODU : 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 End Sub -

ekran çözünürlüğünü öğrenme

ID : 788
ISLEM : ekran çözünürlüğünü öğrenme
MAKRO KODU : 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 End Sub 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 End Function Sub GetScreenSize() Debug.Print ScreenResolution() End Sub

ekran çözünürlüğünün 800x600 ayarlı olarak sayfanın gösterilmesi

ID : 789
ISLEM : ekran çözünürlüğünün 800x600 ayarlı olarak sayfanın gösterilmesi
MAKRO KODU : Private Sub Worksheet_Activate() Call GetScreenSize End Sub 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 End Function 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 End Sub

ekran çözünürlüğünüzü öğrenin

ID : 790
ISLEM : ekran çözünürlüğünüzü öğrenin
MAKRO KODU : 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 End Sub

ekrandaki araç çubuklarını kaldırır ve getirir

ID : 791
ISLEM : ekrandaki araç çubuklarını kaldırır ve getirir
MAKRO KODU : 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 End Sub 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 End Sub

email ayıklama

ID : 792
ISLEM : email ayıklama
MAKRO KODU : 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, ",", ""), "e-mail:", ""), Chr(160), "")) End If Next elem Next x Sheets("sayfa2").Select End Sub

email linki ekleme

ID : 793
ISLEM : email linki ekleme
MAKRO KODU : Sub Email() ActiveWorkbook.SendMail Recipients:="pir@yahoo.com" End Sub

email linki verme ve açma

ID : 794
ISLEM : email linki verme ve açma
MAKRO KODU : Sub HyperlinkMitEmailEinfuegen() Range("A1").Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= "mailto:machero@aol.com" End Sub Sub HyperlinkAktivieren() Range("A1").Select Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True End Sub

en alttaki boş hücre

ID : 795
ISLEM : en alttaki boş hücre
MAKRO KODU : 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 End Sub

en son aktf hücrenin bulunduğu sütunu söyler

ID : 796
ISLEM : en son aktf hücrenin bulunduğu sütunu söyler
MAKRO KODU : Sub test_A() Colonne = Left$(ActiveCell.Address(0, 0), (ActiveCell.Column -

en son aktif hücreye gider

ID : 797
ISLEM : en son aktif hücreye gider
MAKRO KODU : Sub LetzteZelle() Rows.SpecialCells(xlCellTypeLastCell).Rows.Activate End Sub

en son boşluklu kelimeyi bulur =pir(a3)

ID : 798
ISLEM : en son boşluklu kelimeyi bulur =pir(a3)
MAKRO KODU : 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)) End Function

en son dolu hücrenin bulunduğu kolon numarasını verir

ID : 799
ISLEM : en son dolu hücrenin bulunduğu kolon numarasını verir
MAKRO KODU : Sub AnzahlVerwendeteZeilen() i = ActiveSheet.UsedRange.Rows.Count MsgBox i End Sub

en son girilen verinin satır numarasını söyler (a sütununda)

ID : 800
ISLEM : en son girilen verinin satır numarasını söyler (a sütununda)
MAKRO KODU : Sub LastRow() MsgBox Cells.Find("*", searchdirection:=xlPrevious).Row End Sub

en son hüc.yukaridakilerini siler

ID : 801
ISLEM : en son hüc.yukaridakilerini siler
MAKRO KODU : Ç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 End Sub 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 End Sub

en son kaydedilen hücre

ID : 802
ISLEM : en son kaydedilen hücre
MAKRO KODU : 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 End Sub

en son kayıt tarihini açılışta öğren

ID : 803
ISLEM : en son kayıt tarihini açılışta öğren
MAKRO KODU : Private Sub Workbook_Open() MsgBox ActiveWorkbook.BuiltinDocumentProperties(12).Name & ActiveWorkbook.BuiltinDocumentProperties(12) End Sub

en son kayıtlı hücreye gider a sütununda

ID : 804
ISLEM : en son kayıtlı hücreye gider a sütununda
MAKRO KODU : Sub der() Range("A1").Select If Cells(ActiveCell.Row + 1, ActiveCell.Column).Value "" Then ActiveCell.End(xlDown).Select End If End Sub -

enter tuşunun geri gelsin

ID : 805
ISLEM : enter tuşunun geri gelsin
MAKRO KODU : Sub ResetEnterReturn() Application.OnKey "{ENTER}" Application.OnKey "~" End Sub

enter tuşunun geri gelsin 2

ID : 806
ISLEM : enter tuşunun geri gelsin 2
MAKRO KODU : Sub Auto_Close() Application.MoveAfterReturn = True End Sub

enter tuşunun iptali

ID : 807
ISLEM : enter tuşunun iptali
MAKRO KODU : Private Sub Worksheet_Activate() Application.OnKey "{ENTER}", "Macro1" Application.OnKey "~", "Macro1" End Sub

entere basilinca istediğimiz bir hücrenin aktif olmasi

ID : 808
ISLEM : entere basilinca istediğimiz bir hücrenin aktif olmasi
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row > 4 Then Cells(1, Target.Column + 1).Activate End Sub

esc tuşuyla userformunuzu

ID : 809
ISLEM : esc tuşuyla userformunuzu
MAKRO KODU : 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 End Sub

eski formülleri geri getirme (förmül yenileme)

ID : 810
ISLEM : eski formülleri geri getirme (förmül yenileme)
MAKRO KODU : 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 End Sub

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