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


rastgele seçme

ID : 1651
ISLEM : rastgele seçme
MAKRO KODU : Sub Rastgele() say = WorksheetFunction.CountA([A:A]) b = Int((say * Rnd) + 1) MsgBox Range("A" & b) Range("A" & b).EntireRow.Delete End Sub

references kontrolü

ID : 1652
ISLEM : references kontrolü
MAKRO KODU : Sub referanskontrol() On Error GoTo 10 For a = 1 To ThisWorkbook.VBProject.References.Count aranan = ThisWorkbook.VBProject.References.Item(a).Name If aranan = "Outlook" Then MsgBox "ARANAN REFERANS İŞARETLİDİR" Exit Sub End If Next sor = MsgBox("REFERANS BULUNARAK İŞARETLENSİN Mİ?", vbYesNo) If sor = vbYes Then ThisWorkbook.VBProject.References.AddFromGuid "{00062FFF-0000-0000-C000-000000000046}", 1, 0 MsgBox "REFERANS İŞARETLENDİ" Exit Sub 10 MsgBox "REFERANS MEVCUT DEĞİL" End Sub

register de yeni anahtar oluşturmak

ID : 1653
ISLEM : register de yeni anahtar oluşturmak
MAKRO KODU : Yazmak için; Kod: Sub WriteReg() Dim WSH_Shell As Object RegKey = "HKCU\Software\Microsoft\Internet Explorer\Main\Ornek " Set WSH_Shell = CreateObject("WScript.Shell") WSH_Shell.RegWrite RegKey, 1, "REG_DWORD" End Sub Silmek için; Kod: Sub DelReg() Dim WSH_Shell As Object RegKey = "HKCU\Software\Microsoft\Internet Explorer\Main\Ornek " Set WSH_Shell = CreateObject("WScript.Shell") WSH_Shell.RegDelete RegKey End Sub

registry'den bilgi almak

ID : 1654
ISLEM : registry'den bilgi almak
MAKRO KODU : This program needs 3 buttons Const REG_SZ = 1 ' Unicode nul terminated string Const REG_BINARY = 3 ' Free form binary Const HKEY_CURRENT_USER = &H80000001 Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long 'retrieve nformation about the key lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize) If lResult = 0 Then If lValueType = REG_SZ Then 'Create a buffer strBuf = String(lDataBufSize, Chr$(0)) 'retrieve the key's content lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize) If lResult = 0 Then 'Remove the unnecessary chr$(0)'s RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1) End If ElseIf lValueType = REG_BINARY Then Dim strData As Integer 'retrieve the key's value lResult = RegQueryValueEx(hKey, strValueName, 0, 0, strData, lDataBufSize) If lResult = 0 Then RegQueryStringValue = strData End If End If End If End Function Function GetString(hKey As Long, strPath As String, strValue As String) Dim Ret 'Open the key RegOpenKey hKey, strPath, Ret 'Get the key's content GetString = RegQueryStringValue(Ret, strValue) 'Close the key RegCloseKey Ret End Function Sub SaveString(hKey As Long, strPath As String, strValue As String, strData As String) Dim Ret 'Create a new key RegCreateKey hKey, strPath, Ret 'Save a string to the key RegSetValueEx Ret, strValue, 0, REG_SZ, ByVal strData, Len(strData) 'close the key RegCloseKey Ret End Sub Sub SaveStringLong(hKey As Long, strPath As String, strValue As String, strData As String) Dim Ret 'Create a new key RegCreateKey hKey, strPath, Ret 'Set the key's value RegSetValueEx Ret, strValue, 0, REG_BINARY, CByte(strData), 4 'close the key RegCloseKey Ret End Sub Sub DelSetting(hKey As Long, strPath As String, strValue As String) Dim Ret 'Create a new key RegCreateKey hKey, strPath, Ret 'Delete the key's value RegDeleteValue Ret, strValue 'close the key RegCloseKey Ret End Sub Private Sub Command1_Click() Dim strString As String 'Ask for a value strString = InputBox("Please enter a value between 0 and 255 to be saved as a binary value in the registry.", App.Title) If strString = "" Or Val(strString) > 255 Or Val(strString) -

renk saydırma hangi renkten kaç tane var buldurma

ID : 1655
ISLEM : renk saydırma hangi renkten kaç tane var buldurma
MAKRO KODU : Sub CountColors() y = 0 g = 0 p = 0 oth = 0 For Each cell In Selection Select Case cell.Interior.ColorIndex Case 36 'yellow y = y + 1 Case 35 'green g = g + 1 Case 38 'pink p = p + 1 Case Else oth = oth + 1 End Select Next cell msg = y & " Yellow" msg = msg & vbCrLf & g & " Green" msg = msg & vbCrLf & p & " Pink" msg = msg & vbCrLf & oth & " Other" msg = msg & vbCrLf & "Total: " & Selection.Count MsgBox (msg) End Sub Function SUMIFCOLOUR(TheRange As Range, TheColourCell As Range) As Variant Dim TempRange As Range Dim Result Dim Colour Application.Volatile On Error GoTo BailOut Colour = TheColourCell.Interior.Color For Each TempRange In TheRange If Colour = TempRange.Interior.Color Then Result = Result + TempRange.Value Next BailOut: SUMIFCOLOUR = Result End Function Function COUNTIFCOLOUR(TheRange As Range, TheColourCell As Range) As Varian Dim TempRange As Range Dim Result Dim Colour Application.Volatile On Error GoTo BailOut Colour = TheColourCell.Interior.Color For Each TempRange In TheRange If Colour = TempRange.Interior.Color Then Result = Result + 1 Next BailOut: COUNTIFCOLOUR = Result End Function

renk seçenekleri penceresi

ID : 1656
ISLEM : renk seçenekleri penceresi
MAKRO KODU : Sub Dialog_12() Application.Dialogs(xlDialogColorPalette).Show End Sub

renklendirilmiş hücreler harici satırları gizleme

ID : 1657
ISLEM : renklendirilmiş hücreler harici satırları gizleme
MAKRO KODU : Option Explicit Sub macro1() Dim i As Long Dim j As Long Dim sVal Dim bHide As Boolean j = 65000 For i = 1 To j If j 36 Then bHide = True End If If bHide Then Rows(i & ":" & i).Select Range("A" & i).Activate Selection.EntireRow.Hidden = True j = j - 1 End If Next i End Sub -

renkleri listeleme

ID : 1658
ISLEM : renkleri listeleme
MAKRO KODU : Sub RenkleriListele() For i = 1 To 56 With Cells(i, 1) .Interior.ColorIndex = i ' Dolgu Rengi .Font.ColorIndex = 3 'Yazıtipi rengini 3 yazdık kırmızı yani ama istersen VbRed şeklinde de yazabilirdik .HorizontalAlignment = xlCenter ' Yazıyı ortala .Value = i 'Hücrenin içine renk kodunu yaz End With Next i End Sub

renkli hücreleri saysın

ID : 1659
ISLEM : renkli hücreleri saysın
MAKRO KODU : Sub CountColor() Dim irow, icol As Integer Cells(1, 1) = 0 For irow = 1 To 20 For icol = 1 To 10 If Cells(irow, icol).Interior.ColorIndex _ xlColorIndexNone Then Cells(1, 1) = Cells(1, 1) + 1 End If Next icol Next irow End Sub -

renkli hücreleri toplama

ID : 1660
ISLEM : renkli hücreleri toplama
MAKRO KODU : Function SumIfColours(cellTextColour As Integer, _ Range1, ParamArray Range2()) As Double Dim objCell As Range ' Best to use this even if it does ' slow Excel down somewhat. Application.Volatile ' Initialise. SumIfColours = 0 ' Process first argument. ' Restrict the range to stop the loop looking ' at huge swathes of empty cells. For Each objCell In Intersect(Range1, _ Range1.Parent.UsedRange) If Application.IsNumber(objCell.Value) And _ objCell.Interior.ColorIndex = cellTextColour Then _ SumIfColours = SumIfColours + objCell.Value Next objCell ' Process additional arguments (if any) If UBound(Range2) 0 Then For intArgument = 1 To UBound(Range2) For Each objCell In Intersect(Range2(intArgument), _ Range2(intArgument).Parent.UsedRange) If Application.IsNumber(objCell.Value) And _ objCell.Interior.ColorIndex = cellTextColour Then _ SumIfColours = SumIfColours + objCell.Value Next objCell Next intArgument End If End Function -

renkli hücreleri toplama 2

ID : 1661
ISLEM : renkli hücreleri toplama 2
MAKRO KODU : D21 veya A1:D20 hücreleri dışında bir hücreye aşağıdaki fürmülü yazın. =SumIfColours(3;$A$1:$D$20)

renkli hücreye sadece rakam girme: msgbox

ID : 1662
ISLEM : renkli hücreye sadece rakam girme: msgbox
MAKRO KODU : Aşağıdaki kodu aktif sayfaya yapıştırınız Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim myRange As Range Dim intLowerlimit As Integer Dim intUpperlimit As Integer Set myRange = Range("A2:B5,D6:E8") ' Sınırları yazın intLowerlimit = 1 ' istediğiniz alt limit intUpperlimit = 8 ' istediğiniz ust limit If Not Intersect(Target, myRange) Is Nothing Then If Not IsNumeric(Target.Value) Then MsgBox ("Sadece rakam girebilirsiniz!") Cells(Target.Row, 6).Value = "Rakam değil!" Cells(Target.Row, 6).Font.Color = RGB(255, 0, 0) ElseIf Not (Target.Value / 1 = Target.Value \ 1) Then MsgBox ("Geçerli değil") Cells(Target.Row, 6).Value = "Dogru degil" Cells(Target.Row, 6).Font.Color = RGB(255, 0, 0) ElseIf Target.Value intUpperlimit Then MsgBox ("Sayı ust limitten fazla! " _ & intLowerlimit & " and " & intUpperlimit) Cells(Target.Row, 6).Value = "Sayı limit değeri ustunde!" Cells(Target.Row, 6).Font.Color = RGB(255, 0, 0) Else Cells(Target.Row, 6).Value = "Dogru" Cells(Target.Row, 6).Font.Color = RGB(0, 255, 0) End If End If End Sub -

renkli hücreye şifreli giriş (sarı)

ID : 1663
ISLEM : renkli hücreye şifreli giriş (sarı)
MAKRO KODU : Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Dim pw As String If Target.Column = 3 And Target.Row = 2 Or Target.Row = 5 Then ' C2 ve C5 i sarı yap pw = InputBox("Bitte Passwort eingeben !") If pw "pir" Then Range("a1").Select Exit Sub Else End If End If End Sub -

resim çekmek (printscreen)

ID : 1664
ISLEM : resim çekmek (printscreen)
MAKRO KODU : Option Explicit Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Sub Command1_Click() Call keybd_event(vbKeySnapshot, 0, 0, 0) ' Hali hazırda bulunan ekranın fotoğrafını yakaladı DoEvents ' Clipboarda Çekilen Resmin Kopyalanması için Bilgisayarı beklet End Sub

resim ekleme penceresi

ID : 1665
ISLEM : resim ekleme penceresi
MAKRO KODU : Sub Dialog_42() Application.Dialogs(xlDialogInsertPicture).Show End Sub

resim ekletme mecburi dizin

ID : 1666
ISLEM : resim ekletme mecburi dizin
MAKRO KODU : Sub insertImg() Dim fichImg fichImg = Application.GetOpenFilename("Fichier image(*.gif;*.jpg;*.bmp),*.gif;*.jpg;*.bmp" _ , , "Choix de l'image", , False) 'false selection simple If fichImg = False Then Exit Sub ActiveSheet.Pictures.Insert(fichImg).Select End Sub

resmi kopyala penceresi

ID : 1667
ISLEM : resmi kopyala penceresi
MAKRO KODU : Sub Dialog_16() Application.Dialogs(xlDialogCopyPicture).Show End Sub

resmin yarısını gizleme ve gösterme

ID : 1668
ISLEM : resmin yarısını gizleme ve gösterme
MAKRO KODU : Sub Grafikteil_ausblenden() ActiveSheet.Shapes("Picture 1").Select Selection.ShapeRange.PictureFormat.Brightness = 0.5 Selection.ShapeRange.PictureFormat.Contrast = 0.5 Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic Selection.ShapeRange.PictureFormat.CropLeft = 0# Selection.ShapeRange.PictureFormat.CropRight = 0# Selection.ShapeRange.PictureFormat.CropTop = 0# Selection.ShapeRange.PictureFormat.CropBottom = 0# Range("A1").Select End Sub Sub Grafikteil_einblenden() ActiveSheet.Shapes("Picture 1").Select Selection.ShapeRange.PictureFormat.Brightness = 0.5 Selection.ShapeRange.PictureFormat.Contrast = 0.5 Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic Selection.ShapeRange.PictureFormat.CropLeft = 0# Selection.ShapeRange.PictureFormat.CropRight = 0# Selection.ShapeRange.PictureFormat.CropTop = 0# Selection.ShapeRange.PictureFormat.CropBottom = 34.02 Range("A1").Select End Sub

rgb kodları ile hücreyi renklendirme

ID : 1669
ISLEM : rgb kodları ile hücreyi renklendirme
MAKRO KODU : Sub CouleurRGB() Range("a1").Interior.Color = RGB(0, 0, 0) Range("a2").Interior.Color = RGB(255, 0, 0) End Sub

saat farkı hesaplatma

ID : 1670
ISLEM : saat farkı hesaplatma
MAKRO KODU : Sub MASA1() Cells(3, 3) = "=NOW()" Cells(3, 3).Select Selection.NumberFormat = "h:mm" Cells(3, 4) = Cells(3, 3).Value - Cells(3, 2).Value Range("E1").Select End Sub

saat formatı

ID : 1671
ISLEM : saat formatı
MAKRO KODU : sub saat () Do Range("a1") = Format(Now(), "dd mm yyyy") Range("a2") = Format(Now(), "hh:mm:ss") DoEvents Loop End Sub

saat tarih fonksiyonları

ID : 1672
ISLEM : saat tarih fonksiyonları
MAKRO KODU : LABEL KUTULARINA SAAT&TARİH EKLER Private Sub tarih_Click() Label1.Caption = time Label2.Caption = Date End Sub 'TARİH&SAAT'İ AYNI ANDA GÖSTERİR. Private Sub Label3_Click() Label1.Caption = Now() End Sub

saat tarih fonksiyonlari

ID : 1673
ISLEM : saat tarih fonksiyonlari
MAKRO KODU : LABEL KUTULARINA SAAT&TARİH EKLER Private Sub tarih_Click() Label1.Caption = time Label2.Caption = Date End Sub 'TARİH&SAAT'İ AYNI ANDA GÖSTERİR. Private Sub Label3_Click() Label1.Caption = Now() End Sub

saati menü olarak ekleme

ID : 1674
ISLEM : saati menü olarak ekleme
MAKRO KODU : Option Explicit Private Declare Function FindWindow _ Lib "user32" _ Alias "FindWindowA" _ ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String _ ) _ As Long Private Declare Function SetTimer _ Lib "user32" _ ( _ ByVal hWnd As Long, _ ByVal nIDEvent As Long, _ ByVal uElapse As Long, _ ByVal lpTimerFunc As Long _ ) _ As Long Private Declare Function KillTimer _ Lib "user32" _ ( _ ByVal hWnd As Long, _ ByVal nIDEvent As Long _ ) _ As Long Private Declare Function GetCurrentVbaProject _ Lib "vba332.dll" _ Alias "EbGetExecutingProj" _ ( _ hProject As Long _ ) _ As Long Private Declare Function GetFuncID _ Lib "vba332.dll" _ Alias "TipGetFunctionId" _ ( _ ByVal hProject As Long, _ ByVal strFunctionName As String, _ ByRef strFunctionID As String _ ) _ As Long Private Declare Function GetAddr _ Lib "vba332.dll" _ Alias "TipGetLpfnOfFunctionId" _ ( _ ByVal hProject As Long, _ ByVal strFunctionID As String, _ ByRef lpfnAddressOf As Long _ ) _ As Long Private WindowsTimer As Long Private ClockCBControl As CommandBarButton Sub StartClockinMenu() Set ClockCBControl = _ Application.CommandBars(1).Controls.Add( _ Type:=msoControlButton, Temporary:=True) ClockCBControl.Style = msoButtonCaption ClockCBControl.Caption = Format(Now, "Long Time") fncWindowsTimer 1000 End Sub Sub StopClockinMenu() fncStopWindowsTimer ClockCBControl.Delete End Sub Private Function fncWindowsTimer( _ TimeInterval As Long _ ) As Boolean Dim WindowsTimer As Long WindowsTimer = 0 If Val(Application.Version) > 8 Then WindowsTimer = SetTimer _ ( _ hWnd:=FindWindow("XLMAIN", Application.Caption), _ nIDEvent:=0, _ uElapse:=TimeInterval, _ lpTimerFunc:=AddrOf_cbkCustomTimer _ ) Else WindowsTimer = SetTimer _ ( _ hWnd:=FindWindow("XLMAIN", Application.Caption), _ nIDEvent:=0, _ uElapse:=TimeInterval, _ lpTimerFunc:=AddrOf("cbkCustomTimer") _ ) End If fncWindowsTimer = CBool(WindowsTimer) End Function Private Function fncStopWindowsTimer() KillTimer _ hWnd:=FindWindow("XLMAIN", Application.Caption), _ nIDEvent:=WindowsTimer End Function Private Function cbkCustomTimer _ ( _ ByVal Window_hWnd As Long, _ ByVal WindowsMessage As Long, _ ByVal EventID As Long, _ ByVal SystemTime As Long _ ) _ As Long Dim CurrentTime As String On Error Resume Next ClockCBControl.Caption = Format(Now, "Long Time") End Function Private Function AddrOf _ ( _ CallbackFunctionName As String _ ) _ As Long Dim aResult As Long Dim CurrentVBProject As Long Dim strFunctionID As String Dim AddressOfFunction As Long Dim UnicodeFunctionName As String UnicodeFunctionName = StrConv(CallbackFunctionName, vbUnicode) If Not GetCurrentVbaProject(CurrentVBProject) = 0 Then aResult = GetFuncID _ ( _ hProject:=CurrentVBProject, _ strFunctionName:=UnicodeFunctionName, _ strFunctionID:=strFunctionID _ ) If aResult = 0 Then aResult = GetAddr _ ( _ hProject:=CurrentVBProject, _ strFunctionID:=strFunctionID, _ lpfnAddressOf:=AddressOfFunction _ ) If aResult = 0 Then AddrOf = AddressOfFunction End If End If End If End Function Private Function AddrOf_cbkCustomTimer() As Long AddrOf_cbkCustomTimer = vbaPass(AddressOf cbkCustomTimer) End Function Private Function vbaPass(AddressOfFunction As Long) As Long vbaPass = AddressOfFunction End Function Sub StartClock() StartClockinMenu End Sub Sub StopClock() StopClockinMenu End Sub

saati saniyeye çevirme

ID : 1675
ISLEM : saati saniyeye çevirme
MAKRO KODU : Private Sub CommandButton1_Click() TextBox3 = Hour(TextBox2) * 3600 + Minute(TextBox2) * 60 + Second(TextBox2) End Sub

saati ve tarihi öğrenme

ID : 1676
ISLEM : saati ve tarihi öğrenme
MAKRO KODU : Sub Datum() Dim tag Dim uhr tag = Date uhr = Time MsgBox "Heute ist der " & Date & "," & Chr$(13) & Chr$(13) & " es ist " & Time & " Uhr.", vbOKOnly, "www.excel-lex.de.vu" End Sub

sadece a1 hücresinin yazdırılması

ID : 1677
ISLEM : sadece a1 hücresinin yazdırılması
MAKRO KODU : Sub Druck_Bestimmte_Seite() ActiveWindow.View = xlPageBreakPreview Dim seitenzahl As String seitenzahl = InputBox(" Geben Sie die Nr. der" & Chr(13) & Chr(13) & "auszudruckenden Seite ein:", "Seitenzahl eingeben") If seitenzahl = "" Then MsgBox "Keine Seite ausgewählt" Exit Sub Else ActiveWindow.SelectedSheets.PrintOut From:=seitenzahl, To:=seitenzahl, Copies:=1, Collate _ :=True ActiveWindow.View = xlNormalView End If End Sub

sadece harf veya rakam girme

ID : 1678
ISLEM : sadece harf veya rakam girme
MAKRO KODU : Private Sub TextBox1_Change() If Not (IsNumeric(TextBox1)) Then SendKeys "{bs}" End Sub Private Sub TextBox2_Change() If Right(TextBox2, 1) Like "[0-9]" Then SendKeys "{bs}" End Sub

sadece hücredeki değerleri silme

ID : 1679
ISLEM : sadece hücredeki değerleri silme
MAKRO KODU : Sub Makro1() x = WorksheetFunction.CountA(Range("A1:A65000")) For a = 1 To x b = Cells(a, 1).Value For c = a + 1 To x d = Cells(c, 1).Value If b = d Then Cells(c, 1).ClearContents End If Next c Next a End Sub

sadece rakam girme

ID : 1680
ISLEM : sadece rakam girme
MAKRO KODU : Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If KeyAscii 8 Then 'Allow BACKSPACE through 'Only digits are valid characters. If Chr(KeyAscii) "9" Then KeyAscii = 0 'Set character to null if out of range Beep End If End If End Sub -

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