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


bütün excel dosyalarının %85 ile açılması

ID : 511
ISLEM : bütün excel dosyalarının %85 ile açılması
MAKRO KODU : Sub Auto_Open() ActiveWindow.Zoom = 85 End Sub 'Dosyayı kaydedin. Mesela Kucult.XLS ismini verin. 'Dosyayı C:\Windows\Application Data\Microsoft\Excel\Xlstart klasörüne kopyalayın.

bütün pencereler minimize

ID : 512
ISLEM : bütün pencereler minimize
MAKRO KODU : Sub ButunPencerelerMinimize() Dim Pencere As Window For Each Pencere In Windows If Pencere.Visible = False Then Pencere.Visible = True Pencere.WindowState = xlMinimized Next End Sub

büyük-küçük harf dönüştürür, dönüştürülen hücreleri belirtir. (toggle)

ID : 513
ISLEM : büyük-küçük harf dönüştürür, dönüştürülen hücreleri belirtir. (toggle)
MAKRO KODU : Sub ToggleCase() Dim Upr, Lwr, Ppr Set OriginalCell = ActiveCell Set OriginalSelection = Selection If IsEmpty(ActiveCell) Then GoTo NoneFound On Error GoTo Limiting If OriginalCell = OriginalSelection Then Selection.Select GoTo Converting Else Resume Next End If Limiting: On Error GoTo NoneFound Selection.SpecialCells(xlCellTypeConstants, 3).Select Converting: Application.StatusBar = "Ändere Gross- und Kleinschreibung..." For Each DCell In Selection.Cells Upr = UCase(DCell) Lwr = LCase(DCell) If Upr = DCell.Value Then DCell.Value = Lwr Else DCell.Value = Upr End If Next DCell Application.StatusBar = False Exit Sub NoneFound: MsgBox "Alle Zellen der aktuelllen Auswahl enthalten Formeln oder sindleer!", vbExclamation, " Fehler aufgetreten" OriginalSelection.Select OriginalCell.Activate End Sub

c de test isimli klasör oluşturur

ID : 514
ISLEM : c de test isimli klasör oluşturur
MAKRO KODU : Sub Cree_Repert() Dim Repert As String Repert = Dir("c:\test\", vbDirectory) If Repert = "" Then MkDir "c:\test" End If End Sub

c dizindeki klasörleri listboxta listeler

ID : 515
ISLEM : c dizindeki klasörleri listboxta listeler
MAKRO KODU : Sub Liste_Repert() Dim Repert As String Repert = Dir("c:\", vbDirectory) Do While Repert "" 'Si Repert est un dossier. If GetAttr("c:\" & Repert) = vbDirectory Then UserForm1.ListBox1.AddItem Repert End If Repert = Dir Loop End Sub -

c dizininde xls dosya sayısı

ID : 516
ISLEM : c dizininde xls dosya sayısı
MAKRO KODU : Sub ExcelDateienZählen() With Application.FileSearch .NewSearch .LookIn = "C:\" .Filename = "*.xls" .Execute MsgBox .FoundFiles.Count End With End Sub

c klasöründe .ıni dosyası oluşturur, aktif ve açık excel dosya sayısını içine yazar

ID : 517
ISLEM : c klasöründe .ıni dosyası oluşturur, aktif ve açık excel dosya sayısını içine yazar
MAKRO KODU : Sub lfdNr() Dim Nr% Dim dName$ Dim Zielordner$, Dateiname$ 'Hier den Pfad verändern Zielordner = "c:\" 'Hier den Dateinamen verändern Dateiname = "lfdNr" dName = Zielordner & Dateiname & ".ini" Close On Error Resume Next Open dName For Input As #1 If Err > 0 Then Nr = 1 Close Open dName For Output As #1 Print #1, Nr Close Exit Sub Else Input #1, Nr Close Open dName For Output As #1 Print #1, Nr + 1 Close End If ActiveCell.Value = Nr End Sub

c kolonuna tıklayınca genişler, başka hücreye tıklayınca daralır

ID : 518
ISLEM : c kolonuna tıklayınca genişler, başka hücreye tıklayınca daralır
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range Set rng = Columns("C:C") If Not (Intersect(Target, rng) Is Nothing) Then rng.ColumnWidth = 30 Else rng.ColumnWidth = 10.71 End If End Sub

c sütunu bos olan bütün satirlari silmek

ID : 519
ISLEM : c sütunu bos olan bütün satirlari silmek
MAKRO KODU : Sub sil() Range("c1").Select Application.ScreenUpdating = False Dim hucre As Range For Each hucre In Range("c1:c" & WorksheetFunction.CountA(Range("c1:c5000"))) Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop ActiveCell.EntireRow.Select Selection.Delete Shift:=xlUp Next Application.ScreenUpdating = True End Sub

c sütununda aralıklı olanları toplar

ID : 520
ISLEM : c sütununda aralıklı olanları toplar
MAKRO KODU : Sub Add_Totals() For Each NumRange In Columns("C").SpecialCells(xlConstants, xlNumbers).Areas SumAddr = NumRange.Address(False, False) NumRange.Offset(NumRange.Count, 0).Resize(1, 1).Formula = "=SUM(" & SumAddr & ")" Next NumRange End Sub

c sütununda aralıklı toplam alır

ID : 521
ISLEM : c sütununda aralıklı toplam alır
MAKRO KODU : Sub Add_Totals() For Each NumRange In Columns("C").SpecialCells(xlConstants, xlNumbers).Areas SumAddr = NumRange.Address(False, False) NumRange.Offset(NumRange.Count, 0).Resize(1, 1).Formula = "=SUM(" & SumAddr & ")" Next NumRange End Sub

c sütununda büyük harf

ID : 522
ISLEM : c sütununda büyük harf
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Application.Intersect(Target, Range("C:C")) Is Nothing Then Target(1).Value = UCase(Target(1).Value) End If Application.EnableEvents = True End Sub

c sütunundaki boş satırları gizler

ID : 523
ISLEM : c sütunundaki boş satırları gizler
MAKRO KODU : Sub bidahabossatgizle() For i = 6 To 160 If Range("c" & i) = "" Then _ Range("c" & i).EntireRow.Hidden = True Next

c sütunundakileri karşılaştırıp kaç tane olduğunu bulur ve diğer sayfaya aktarır

ID : 524
ISLEM : c sütunundakileri karşılaştırıp kaç tane olduğunu bulur ve diğer sayfaya aktarır
MAKRO KODU : Sub aktar() Dim sonsat As Long, sat As Long, i As Long, sut As Byte Sheets("2007").Select Sheets("PARCA").Range("A3:G65536").ClearContents sonsat = Cells(65536, "A").End(xlUp).Row sat = 3 If sonsat -

c sütununun otomatik genişlemesi ve daralması

ID : 525
ISLEM : c sütununun otomatik genişlemesi ve daralması
MAKRO KODU : Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range Set rng = Columns("C:C") If Not (Intersect(Target, rng) Is Nothing) Then rng.ColumnWidth = 30 Else rng.ColumnWidth = 10.71 End If End Sub

c1 hücre ismi ile kitap oluşturma

ID : 526
ISLEM : c1 hücre ismi ile kitap oluşturma
MAKRO KODU : Sub NomClasseur() Dim Chr As String 'déclare la variable Chr = Range("Sayfa1!C1") 'Feuille Essai et cellule C1 ChDrive "C" 'si C n'est pas le disque par défaut ChDir "C:\" ActiveWorkbook.SaveAs Filename:=(Chr) End Sub

c1 hücresini sağdan 3 say, c2 ile birleştir farklı kaydet ve aç

ID : 527
ISLEM : c1 hücresini sağdan 3 say, c2 ile birleştir farklı kaydet ve aç
MAKRO KODU : Sub NomClasseur1() Dim Month As String * 3 'seulement les 3 premières lettres Dim Year As String Month = Range("Feuil1!C1") Year = Right(Range("Feuil1!C2"), 2) 'pour ne renvoyer que 01 de 2001 ChDrive "C" ChDir "C:\ajeter\" ActiveWorkbook.SaveAs Filename:=(Month) & (Year) End Sub

c10 100 ise mesaj ver

ID : 528
ISLEM : c10 100 ise mesaj ver
MAKRO KODU : Private Sub Worksheet_Calculate() Static DblWert If Range("C10") = 100 Then If Range("C10") = DblWert Then Exit Sub MsgBox "Jetzt ist der Wert in A1 100!" End If DblWert = Range("C10") End Sub

c5 ile c15 arasindaki boş hücreleri saymak ve d1 e yazdirmak istiyorum

ID : 529
ISLEM : c5 ile c15 arasindaki boş hücreleri saymak ve d1 e yazdirmak istiyorum
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) Range("D1").Value = WorksheetFunction.CountBlank(Range("C5:C15")) End Sub

c5:c20 arasındaki sıra numaraları arasındaki boşlukları alır

ID : 530
ISLEM : c5:c20 arasındaki sıra numaraları arasındaki boşlukları alır
MAKRO KODU : Sub BlendeAus() Range("C5:C20").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True End Sub

c8:c18 arası hücrelerinde sola tıklayınca sağ fare menüsü çıksın

ID : 531
ISLEM : c8:c18 arası hücrelerinde sola tıklayınca sağ fare menüsü çıksın
MAKRO KODU : Sayfanın kod böümüne Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C8:C18")) Is Nothing Then Application.CommandBars("Cell").ShowPopup End If End Sub

c8:c18 arasına tıklayınca sağ fare menüsü açılır

ID : 532
ISLEM : c8:c18 arasına tıklayınca sağ fare menüsü açılır
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C8:C18")) Is Nothing Then Application.CommandBars("Cell").ShowPopup End If End Sub

calisma sayfasinin yedegini alma

ID : 533
ISLEM : calisma sayfasinin yedegini alma
MAKRO KODU : Sub Makro1() Sheets("Sayfa1").Copy ActiveWorkbook.SaveAs Filename:="C:\Documents And Settings\ocamsul\Belgelerim\[a1] End Sub

capslock u açtırma (ışığını yakma)

ID : 534
ISLEM : capslock u açtırma (ışığını yakma)
MAKRO KODU : Private Declare Function GetVersionEx Lib "kernel32" _ Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Declare Function GetKeyboardState Lib "user32" _ (pbKeyState As Byte) As Long Private Declare Function SetKeyboardState Lib "user32" _ (lppbKeyState As Byte) As Long Private Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 ' Maintenance string for PSS usage End Type Const VK_CAPITAL = &H14 Const KEYEVENTF_EXTENDEDKEY = &H1 Const KEYEVENTF_KEYUP = &H2 Const VER_PLATFORM_WIN32_NT = 2 Const VER_PLATFORM_WIN32_WINDOWS = 1 Dim Keys(0 To 255) As Byte Sub SetCapsOn() Dim o As OSVERSIONINFO Dim NumLockState As Boolean Dim ScrollLockState As Boolean Dim CapsLockState As Boolean ' CapsLock handling: o.dwOSVersionInfoSize = Len(o) GetVersionEx o CapsLockState = Keys(VK_CAPITAL) If CapsLockState True Then 'Turn capslock on If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then '===== Win95 Keys(VK_CAPITAL) = 1 SetKeyboardState Keys(0) ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then '===== WinNT 'Simulate Key Press keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0 'Simulate Key Release keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY _ Or KEYEVENTF_KEYUP, 0 End If End If End Sub -

cd açıp kapatma

ID : 535
ISLEM : cd açıp kapatma
MAKRO KODU : Option Explicit Public Declare Function SendCDcmd Lib "winmm.dll" _ Alias "mciSendStringA" ( _ ByVal lpstrCommand As String, _ ByVal lpstrReturnString As String, _ ByVal uReturnLength As Long, _ ByVal hwndCallback As Long) As Long Dim lRet As Long Public Sub EjectCD() lRet = SendCDcmd("set CDAudio door open", vbNullString, 127, 0) End Sub Public Sub CloseCD() lRet = SendCDcmd("set CDAudio door closed", vbNullString, 127, 0) End Sub

cd açma kapama

ID : 536
ISLEM : cd açma kapama
MAKRO KODU : Private Declare Function mciExecute Lib "winmm.dll" (ByVal _ lpstrCommand As String) As Long Public Sub Ap_001_Open() Call mciExecute("Set CDaudio door open") End Sub Public Sub Ap_001_Close() Call mciExecute("Set CDaudio door closed") End Sub

cd açma kapama 2

ID : 537
ISLEM : cd açma kapama 2
MAKRO KODU : Option Base 1 Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Sub main() Dim Now As String Dim a(2) As String a(1) = "set cdaudio door open" a(2) = "set cdaudio door closed" total = 1 For I = 1 To (total * 2) If Int(I / 2) = I / 2 Then Now = vbString(a(2), 0) Else Now = vbString(a(1), 0) End If Next I End Sub Function vbString(ByVal Command As String, ByVal hWnd As Long) As String Dim Buff As String Dim dwR As Long Buff = Space$(100) ' Create a buffer dwR = mciSendString(Command, ByVal Buff, Len(Buff), hWnd) vbString = Buff End Function

check atma a1:a10 hücreleri

ID : 538
ISLEM : check atma a1:a10 hücreleri
MAKRO KODU : Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range("A1:A10")) Is Nothing Then Target.Font.Name = "Marlett" If Target = vbNullString Then Target = "a" Else Target = vbNullString End If End If End Sub

checkbox onaylı ise a1 hücresine 100 yazsın 1

ID : 539
ISLEM : checkbox onaylı ise a1 hücresine 100 yazsın 1
MAKRO KODU : Private Sub CheckBox1_Click() [A1] = CheckBox1 * 20 + 120 End Sub

checkbox onaylı ise a1 hücresine 100 yazsın 2

ID : 540
ISLEM : checkbox onaylı ise a1 hücresine 100 yazsın 2
MAKRO KODU : Private Sub UserForm_Initialize() Range("a1") = 120 End Sub Private Sub CheckBox1_Click() If Me.CheckBox1.Value = False Then Range("a1") = 120 Else Range("a1") = 100 End If End Sub

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