Makro Kod Listesi

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

ID : 871
ISLEM : fare ile textbox içinin renklenmesi
MAKRO KODU : Dim txtler() As New Class1 Dim combolar() As New Class1 Dim nense As Control Private Sub UserForm_Initialize() For Each nesne In UserForm1.Controls If TypeName(nesne) = "TextBox" Then ReDim Preserve txtler(i) Set txtler(i).txt = nesne i = i + 1 ElseIf TypeName(nesne) = "ComboBox" Then ReDim Preserve combolar(i) Set combolar(i).combo = nesne i = i + 1 End If Next nesne End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) For Each nesne In UserForm1.Controls If TypeName(nesne) = "TextBox" Or TypeName(nesne) = "ComboBox" Then nesne.BackColor = vbWhite End If Next nesne End Sub ‘classmodüle Public WithEvents txt As MSForms.TextBox Public WithEvents combo As MSForms.ComboBox Private Sub txt_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) txt.BackColor = vbRed End Sub Private Sub combo_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) combo.BackColor = vbRed End Sub

ID : 872
ISLEM : fare imleci kum saati
MAKRO KODU : Sub fare_imleci() If Application.Cursor = xlWait Then Application.Cursor = xlNormal Worksheets(1).Buttons(1).Caption = "Fare İmleci Kum Saati" Else Application.Cursor = xlWait Worksheets(1).Buttons(1).Caption = "Fare İmleci Normal" End If End Sub

ID : 873
ISLEM : fare kursörünü gizlemek 1
MAKRO KODU : Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Sub Düğme1_Tıklat() DoEvents BlockInput True Sleep 5000 '5 saniye BlockInput False End Sub

ID : 874
ISLEM : fare kursörünü gizlemek 2
MAKRO KODU : Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long Sub FareGizle() Application.OnTime Now + TimeValue("00:00:05"), "FareGöster" ShowCursor False End Sub Sub FareGöster() ShowCursor True End Sub

ID : 875
ISLEM : fare kursörünü hareket ettirme
MAKRO KODU : Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long Sub Cursor1() SetCursorPos 540, 350 End Sub Sub Cursor2() SetCursorPos 220, 200 End Sub

ID : 876
ISLEM : farklı kaydederken dosya ismini otomatik yazsın
MAKRO KODU : Sub Enregistre_Sous2() Réponse = MsgBox("Voulez-vous enregistrer ce classeur ?", vbYesNo) If Réponse = vbYes Then Dim nom As String Do While nom = "" 'Répète l'instruction tant qu'aucun nom est donné nom = InputBox("Donnez un nom de fichier !" & Chr(13) & "Exemple: Rapport") Loop ChDrive "c" ChDir "c:\" 'Indiquez le répertoire ActiveWorkbook.SaveAs Filename:=(nom) Application.Dialogs(xlDialogSaveAs).Show 'pour afficher la boîte Enregistrer sous End If End Sub

ID : 877
ISLEM : farklı kaydederken dosya ismini otomatik yazsın 2
MAKRO KODU : Sub Enregistre_Sous2() Réponse = MsgBox("Voulez-vous enregistrer ce classeur ?", vbYesNo) If Réponse = vbYes Then ChDrive "c" ChDir "c:\" 'Indiquez le répertoire ActiveWorkbook.SaveAs Filename:=456 Application.Dialogs(xlDialogSaveAs).Show 'pour afficher la boîte Enregistrer sous End If End Sub

ID : 878
ISLEM : farklı kaydet butonu ekleme ve renk verme
MAKRO KODU : Sub Icon_Speichern_unter() Dim Pos As Byte ActiveSheet.Shapes("Picture 1").Copy Pos = Application.CommandBars("Standard").FindControl(, 3).Index + 1 With Application.CommandBars("Standard").Controls.Add(msoControlButton, ID:=748, before:=Pos) .Style = msoButtonIcon .PasteFace End With End Sub

ID : 879
ISLEM : farklı kaydet ekranı gelmeden ve kaydetmeden çıkmak
MAKRO KODU : Sub auto_close() Application.DisplayAlerts = False ActiveWorkbook.Close End Sub

ID : 880
ISLEM : farklı kaydet ve sağ klik tuşunu disable yapma
MAKRO KODU : Sub ac() EnableControl 748, 1 End Sub Sub kapa() EnableControl 748, 0 End Sub Sub EnableControl(Id As Integer, Enabled As Boolean) Dim CB As CommandBar Dim C As CommandBarControl For Each CB In Application.CommandBars Set C = CB.FindControl(Id:=Id, recursive:=True) If Not C Is Nothing Then C.Enabled = Enabled Next End Sub

ID : 881
ISLEM : farklı kaydet ve sağ klik tuşunu disable yapma
MAKRO KODU : Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If SaveAsUI Then Cancel = True End Sub Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) Cancel = True End Sub Private Sub Workbook_BeforeSave(ByVal pir As Boolean, Cancel As Boolean) If pir Then Cancel = True End Sub

ID : 882
ISLEM : farklı kaydeti engelle
MAKRO KODU : Thisworkbook'a Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If SaveAsUI Then Cancel = True'False farklı kaydede izin verir. End If End Sub

ID : 883
ISLEM : farklı kaydetin devamlı gelmesini istiyorsanız
MAKRO KODU : ThisWorkbook'a yazınız. Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.GetSaveAsFilename End Sub

ID : 884
ISLEM : farkli kaydedi engelle
MAKRO KODU : Aşağıdaki kod kullanıcının kullanmakta olduğu dosyasını (farklı kaydet) yapmasını engeller. 'KOD Thisworkbook'a yazılacak Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If SaveAsUI Then Cancel = True'False farklı kaydede izin verir. End If End Sub

ID : 885
ISLEM : farkli uyari pencereleri
MAKRO KODU : Sub Dene() MsgBox "aa", 16, "hata" End Sub Kod: Sub Denee() MsgBox "aa", 64, "hata" End Sub

ID : 886
ISLEM : fcommandbutton hareket etsin.ormda
MAKRO KODU : 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

ID : 887
ISLEM : filigran yazdırma (sayfa artalanına silik yazı)
MAKRO KODU : 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

ID : 888
ISLEM : filtreyi (süzmeyi) iptal etme
MAKRO KODU : Private Sub CommandButton2_Click() Worksheets("Sayfa1").AutoFilterMode = False End Sub

ID : 889
ISLEM : find menüsü oluşturma
MAKRO KODU : 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

ID : 890
ISLEM : fonksiyon çalıştırma kodu
MAKRO 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

ID : 891
ISLEM : fonksiyon çalıştırma kodu2
MAKRO KODU : Sub Code2() Application.Goto Reference:="Sum_color" End Sub

ID : 892
ISLEM : fonksiyon tanımlama not puanlama
MAKRO KODU : 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

ID : 893
ISLEM : fonksiyonla kitabın açık olup olmadığını öğrenme
MAKRO KODU : 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

ID : 894
ISLEM : font isimleri a sütununda
MAKRO KODU : 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

ID : 895
ISLEM : fontları sayfaya yazdırma
MAKRO KODU : 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

ID : 896
ISLEM : form açar
MAKRO KODU : FORM AÇAR Sub formaç() Günlük.Show End Sub

ID : 897
ISLEM : form açma
MAKRO KODU : Sub formaç() Günlük.Show End Sub

ID : 898
ISLEM : form çağirir
MAKRO KODU : EKLEYECEĞİNİZ FORMU ÇAĞIRIR Private Sub CommandButton6_Click() Load UserForm1 UserForm1.Show End Sub

ID : 899
ISLEM : form dolarsa ikinci forma geçip çiktisini alsin
MAKRO KODU : 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

ID : 900
ISLEM : form kutusundan lis.kutusuna kom.verme
MAKRO KODU : 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