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


multipage geçiş şifreli

ID : 1561
ISLEM : multipage geçiş şifreli
MAKRO KODU : Private Sub UserForm_Initialize() MultiPage1.Value = 0 End Sub Private Sub MultiPage1_Click(ByVal Index As Long) If Index = 1 Then CommandButton6.Enabled = False CommandButton7.Enabled = False sor = InputBox("ŞİFREYİ GİRİNİZ", "ŞİFRE GİR") If sor = "şifre" Then CommandButton6.Enabled = True CommandButton7.Enabled = True Exit Sub End If MsgBox "HATALI ŞİFRE" End If End Sub

multipage geçişi

ID : 1562
ISLEM : multipage geçişi
MAKRO KODU : Private Sub CommandButton1_Click() MultiPage1.Value = MultiPage1.Value + 1 End Sub

multipage te gezinti butonla

ID : 1563
ISLEM : multipage te gezinti butonla
MAKRO KODU : '// Birinci sayfayi gosterir MultiPage1.Value = 0 '// Ikinci sayfayi gosterir MultiPage1.Value = 1

multipage te gezinti scroll barla

ID : 1564
ISLEM : multipage te gezinti scroll barla
MAKRO KODU : Userforma bir scrollbar ekleyin ve aşağıdaki kodu scrollbara yazın. Private Sub ScrollBar1_Change() MultiPage1.Value = ScrollBar1.Value End Sub 'Eğer hep page üç açılsın diyorsanız, bu durumda hangi nesneyi kullanıyorsanız ona aşağıdaki kodu yazmak yeterlidir. MultiPage1.Value = 2

multipage zemin rengi

ID : 1565
ISLEM : multipage zemin rengi
MAKRO KODU : Gerçekten bu durum çok enterasan. Form üzerinde herşeyi yapabiliyorsunuz fakat MultiPage nesnesinin zemin rengini değiştirmek için bir özelliğin olmadığını fark ediyorsunuz. Bu durumda sorulan sorunun cevabını bir kurnazlık yaparak bulmak gerekiyor. Tüm kontrolleri yerleştirdikten sonra MultiPage nesnesi üzerine bir Image nesnesi yerleştirin ve tüm kontrollerin altına gönderin ve Image nesnesinin zemin rengini istediğiniz renk yapın. Böylece MultiPage nesnesinin değişmeyen zemin rengini örtmüş olursunuz. Bu işlemi en son yapın ki düzenlemelerde bir sorunla karşılaşmayın.

multipageden sayfaya geçiş

ID : 1566
ISLEM : multipageden sayfaya geçiş
MAKRO KODU : Private Sub MultiPage1_Click(ByVal Index As Long) Select Case Index Case 0: Sheets(1).Select Case 1: Sheets(2).Select End Select End Sub

multipageler de sayfaya geçiş

ID : 1567
ISLEM : multipageler de sayfaya geçiş
MAKRO KODU : Private Sub MultiPage1_Click(ByVal Index As Long) Select Case Index Case 0: Sheets(1).Select Case 1: Sheets(2).Select End Select End Sub

mükemmel menü ekleme, dosya menüsünde yazdır, baskı önizle, sayfa yapısı kalır

ID : 1568
ISLEM : mükemmel menü ekleme, dosya menüsünde yazdır, baskı önizle, sayfa yapısı kalır
MAKRO KODU : Private Sub Workbook_Open() Dim CmdB As CommandBar, nCmdB As CommandBar Dim nCtlP As CommandBarPopup, nCtlB As CommandBarButton For Each CmdB In Application.CommandBars If CmdB.Type = msoBarTypeMenuBar And _ CmdB.Name = "Meine Menueleiste" Then CmdB.Delete End If Next CmdB Set nCmdB = Application.CommandBars.Add _ (Name:="Meine Menueleiste", Position:=msoBarTop, _ MenuBar:=True, Temporary:=True) With nCmdB .Protection = msoBarNoMove .Protection = msoBarNoChangeDock .Protection = msoBarNoChangeVisible .Protection = msoBarNoCustomize .Protection = msoBarNoVerticalDock .Visible = True End With Set nCtlP = nCmdB.Controls.Add(Type:=msoControlPopup) With nCtlP .Caption = "Mein Menue &1" End With Set nCtlB = nCtlP.Controls.Add(ID:=247) With nCtlB .Style = msoButtonCaption End With Set nCtlB = nCtlP.Controls.Add(ID:=109) With nCtlB .Style = msoButtonAutomatic End With Set nCtlB = nCtlP.Controls.Add(ID:=4) With nCtlB .BeginGroup = True .Style = msoButtonAutomatic End With Set nCtlP = nCmdB.Controls.Add(Type:=msoControlPopup) With nCtlP .Caption = "Mein Menue &2" End With Set nCtlB = nCtlP.Controls.Add(ID:=1) With nCtlB .Caption = "Mein VBA-Makro &1" .OnAction = "Me_001_Code01" .Style = msoButtonCaption End With Set nCtlB = nCtlP.Controls.Add(ID:=1) With nCtlB .BeginGroup = True .FaceId = 239 .Caption = "Mein VBA-Makro &2" .OnAction = "Me_001_Code02" .Style = msoButtonIconAndCaption End With End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Call Me_001_Delete End Sub Public Sub Me_001_Code01() MsgBox "Die Option 'Mein VBA-Makro 1' wurde gewählt!", _ vbInformation, "Code-Beispiel (Me_001)" End Sub Public Sub Me_001_Code02() MsgBox "Die Option 'Mein VBA-Makro 2' wurde gewählt!", _ vbInformation, "Code-Beispiel (Me_001)" End Sub Public Sub Me_001_Delete() On Error Resume Next Application.CommandBars("Meine Menueleiste").Delete On Error GoTo 0 End Sub

mükemmel mp3 çaldırma

ID : 1569
ISLEM : mükemmel mp3 çaldırma
MAKRO KODU : Private 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 Private isPlaying As Boolean Public Sub Ap_002_Play() Dim mp3File As String 'Dim mp3File$ mp3File = Chr$(34) & "C:\mp3\muamma.mp3" & Chr$(34) If isPlaying = True Then Call mciSendString("Stop MM", 0&, 0&, 0&) Call mciSendString("Close MM", 0&, 0&, 0&) Call mciSendString("Open " & mp3File & " Alias MM", 0&, 0&, 0&) Call mciSendString("Play MM", 0&, 0&, 0&) Else Call mciSendString("Open " & mp3File & " Alias MM", 0&, 0&, 0&) Call mciSendString("Play MM", 0&, 0&, 0&) isPlaying = True End If End Sub Public Sub Ap_002_Stop() If isPlaying = False Then Exit Sub Call mciSendString("Stop MM", 0&, 0&, 0&) Call mciSendString("Close MM", 0&, 0&, 0&) End Sub

mükemmel sağ fareye menüsünü siler ve yazdır, baskı önizle, sayfa yapısını ekler

ID : 1570
ISLEM : mükemmel sağ fareye menüsünü siler ve yazdır, baskı önizle, sayfa yapısını ekler
MAKRO KODU : Private Sub Workbook_Open() Dim CmdB As CommandBar, nCmdB As CommandBar Dim nCtlB As CommandBarButton For Each CmdB In Application.CommandBars If CmdB.Type = msoBarTypePopup And _ CmdB.Name = "Mein Kontextmenue" Then CmdB.Delete End If Next CmdB Set nCmdB = Application.CommandBars.Add _ (Name:="Mein Kontextmenue", Position:=msoBarPopup, _ Temporary:=True) Set nCtlB = nCmdB.Controls.Add(ID:=1) With nCtlB .Caption = "Mein VBA-Makro &1" .OnAction = "Me_002_Code" .Style = msoButtonCaption End With Set nCtlB = nCmdB.Controls.Add(ID:=1) With nCtlB .FaceId = 239 .Caption = "Mein VBA-Makro &2" .OnAction = "Me_002_Code" .Style = msoButtonIconAndCaption End With Set nCtlB = nCmdB.Controls.Add(ID:=247) With nCtlB .BeginGroup = True .Style = msoButtonCaption End With Set nCtlB = nCmdB.Controls.Add(ID:=109) With nCtlB .Style = msoButtonAutomatic End With Set nCtlB = nCmdB.Controls.Add(ID:=4) With nCtlB .BeginGroup = True .Style = msoButtonAutomatic End With End Sub Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, _ ByVal Target As Excel.Range, Cancel As Boolean) Cancel = True On Error GoTo Fehler Application.CommandBars("Mein Kontextmenue").ShowPopup Exit Sub Fehler: Cancel = False End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Call Me_002_Delete End Sub Public Sub Me_002_Code() MsgBox "Die Option 'Mein VBA-Makro " & _ Application.CommandBars("Mein Kontextmenue") _ .Controls(Application.Caller(1)).Index & _ "' wurde gewählt!", _ vbInformation, "Code-Beispiel (Me_002)" End Sub Public Sub Me_002_Delete() On Error Resume Next Application.CommandBars("Mein Kontextmenue").Delete On Error GoTo 0 End Sub

mükerrer kayıt var ikazı

ID : 1571
ISLEM : mükerrer kayıt var ikazı
MAKRO KODU : Private Sub CommandButton2_Click() For Each ayni In Range("b2:b1000") If ayni.Value = CStr(TextBox2.Value) Then DUR4 = MsgBox("GİRMİŞ OLDUĞUNUZ VERGİ NUMARASI KAYITLARDA BULUNMAKTADIR", vbYes, "YANLIŞ") TextBox2.Value = "" Exit Sub End If Next End Sub

mükerrer kayıtlarda yeniden kayıt yapılsın mı olayı

ID : 1572
ISLEM : mükerrer kayıtlarda yeniden kayıt yapılsın mı olayı
MAKRO KODU : Private Sub CommandButton1_Click() If TextBox2.Value "" Then Sheets("Sayfa1").Activate Cells(1, 1).Select Do While ActiveCell.Value "" If Trim(ActiveCell.Value) = Trim(Me.TextBox1.Value) Then If MsgBox(Me.TextBox1 & " isimli işçi kayıtlı" & " Yeniden kayıt yapılsın mı?", vbYesNo) = vbNo Then Exit Sub End If ActiveCell.Offset(1, 0).Activate Loop ActiveCell.Value = TextBox1.Value ActiveCell.Offset(0, 1).Value = TextBox2.Value End If End Sub -

mükerrer kayıtları siler

ID : 1573
ISLEM : mükerrer kayıtları siler
MAKRO KODU : Sub çift_kayıtları_kaldır() Cells.Sort Key1:=Range("A1") totalrows = ActiveSheet.UsedRange.Rows.Count Count = 1 For Row = totalrows To 2 Step -1 If Cells(Row, 1).Value = Cells(Row - 1, 1).Value Then Rows(Row).Delete Count = Count + 1 End If Next Row End Sub

mükerrer kayıtları siler (mükerrer kayıt raporlar)

ID : 1574
ISLEM : mükerrer kayıtları siler (mükerrer kayıt raporlar)
MAKRO KODU : Sub RemoveDuplicates() Cells.Sort Key1:=Range("A1") totalrows = ActiveSheet.UsedRange.Rows.Count Count = 1 For Row = totalrows To 2 Step -1 If Cells(Row, 1).Value = Cells(Row - 1, 1).Value Then Rows(Row).Delete Count = Count + 1 Else Cells(Row, 3).Value = Count Count = 1 End If Next Row Cells(1, 3).Value = Count End Sub

mükerrer olanları kırmızı ile tespit etmek

ID : 1575
ISLEM : mükerrer olanları kırmızı ile tespit etmek
MAKRO KODU : Sub mukerrer() For a = 1 To [a65536].End(xlUp).Row If WorksheetFunction.CountIf(Columns(1), Cells(a, 1)) > 1 Then Cells(a, 1).Interior.ColorIndex = 3 Next End Sub

negetif sayıları toplama

ID : 1576
ISLEM : negetif sayıları toplama
MAKRO KODU : Sub SommeNégative() For Each Cell In Range("A1:A10") If Cell.Value -

nesne ekleme penceresi

ID : 1577
ISLEM : nesne ekleme penceresi
MAKRO KODU : Sub Dialog_41() Application.Dialogs(xlDialogInsertObject).Show End Sub

nesne özelliğini tek seferde değiştirme

ID : 1578
ISLEM : nesne özelliğini tek seferde değiştirme
MAKRO KODU : Sorunuz üzerinde düşündüm tam bir çözüm olmasada şu şekilde yapılabilir. çok daha iyi öneriler çıkacaktır mutlaka. textboxların bulunduğu userformun içine aşağıdaki kodu yazınız. Fakat bunu sadece userform_click olayında gerçekleştirebildim. Yani formatların değiştirilmesi için userforma bir kere tıklamak gerekiyor. Kod: Private Sub UserForm_Click() For a = 1 To 16 UserForm1.Controls("TextBox" & a) = Format(UserForm1.Controls("TextBox" & a), "###.#######") Next a End Sub diğer bir çözümde;eğer textboxlardan sonra örneğin bir command buton seçilecekse aynı kodlar bu butonun içine yazılabilir. Kod: Private Sub CommandButton1_Enter() For a = 1 To 16 UserForm1.Controls("TextBox" & a) = Format(UserForm1.Controls("TextBox" & a), "###.#######") Next a End Sub Başka önerileri açıkçası bende merakla bekliyorum.

networkteki yazıcı da yazdırır

ID : 1579
ISLEM : networkteki yazıcı da yazdırır
MAKRO KODU : Sub PrintToNetworkPrinterExample() Dim strCurrentPrinter As String, strNetworkPrinter As String strNetworkPrinter = GetFullNetworkPrinterName("HP LaserJet 8100 Series PCL") If Len(strNetworkPrinter) > 0 Then ' found the network printer strCurrentPrinter = Application.ActivePrinter ' change to the network printer Application.ActivePrinter = strNetworkPrinter Worksheets(1).PrintOut ' print something ' change back to the previously active printer Application.ActivePrinter = strCurrentPrinter End If End Sub Function GetFullNetworkPrinterName(strNetworkPrinterName As String) As String ' returns the full network printer name ' returns an empty string if the printer is not found ' e.g. GetFullNetworkPrinterName("HP LaserJet 8100 Series PCL") ' might return "HP LaserJet 8100 Series PCL on Ne04:" Dim strCurrentPrinterName As String, strTempPrinterName As String, i As Long strCurrentPrinterName = Application.ActivePrinter i = 0 Do While i -

normal ekran için

ID : 1580
ISLEM : normal ekran için
MAKRO KODU : Sub normal() Application.DisplayFullScreen = False End Sub

not defterini açma ve kapama

ID : 1581
ISLEM : not defterini açma ve kapama
MAKRO KODU : Public id Sub starten() id = Shell(Range("A1").Value, vbNormalFocus) End Sub Sub beenden() AppActivate id SendKeys "%{F4}", True End Sub

not defterini çağırma

ID : 1582
ISLEM : not defterini çağırma
MAKRO KODU : NOT DEFTERİNİ ÇALIŞTIRIR Sub notdefteri() Call Shell("notepad.exe.", 1) End Sub

not defterini çağirir

ID : 1583
ISLEM : not defterini çağirir
MAKRO KODU : NOT DEFTERİNİ ÇALIŞTIRIR Sub notdefteri() Call Shell("notepad.exe.", 1) End Sub

not defterini veya diğer uygulamaları açma

ID : 1584
ISLEM : not defterini veya diğer uygulamaları açma
MAKRO KODU : Sub externesProgrammAusExcelAufrufen() Status = Shell("notepad.exe", 1) End Sub 'notepad.exe 'Calc.exe = 'MSPaint.exe 'sol.exe

notepad ile txt dosyası açtırma

ID : 1585
ISLEM : notepad ile txt dosyası açtırma
MAKRO KODU : Shell "notepad.exe c:\foldername\filename.txt", vbMaximizedFocus

numfact isimli hücrenin açılış ve kapanışta artırılması

ID : 1586
ISLEM : numfact isimli hücrenin açılış ve kapanışta artırılması
MAKRO KODU : Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim chemXlt As String chemXlt = Application.TemplatesPath & "NumAuto.xlt" If ActiveWorkbook.Path = "" Then Workbooks.Open (chemXlt) [NumFact] = [NumFact] - 1 ActiveWorkbook.Close True End If End Sub Private Sub Workbook_Open() If ActiveWorkbook.Path = "" Then [NumFact] = [NumFact] + 1 ActiveWorkbook.Saved = True ActiveWorkbook.SaveCopyAs _ Application.TemplatesPath & "NumAuto.xlt" End If End Sub

numlock u açma, kapama

ID : 1587
ISLEM : numlock u açma, kapama
MAKRO KODU : Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByValbScan As Byte, ByVal dwFlags As Long, _ ByVal dwExtraInfo As Long) Public Const VK_NUMLOCK = &H90 Sub Num_Lock_On() keybd_event VK_NUMLOCK, 1, 0, 0 End Sub Sub Num_Lock_Off() keybd_event VK_NUMLOCK, 0, 0, 0 End Sub

office yardımcısına hello yazdırın

ID : 1588
ISLEM : office yardımcısına hello yazdırın
MAKRO KODU : Sub assist() Application.Assistant.Visible = True Assistant.Animation = msoAnimationIdle Set SB = Assistant.NewBalloon SB.Animation = msoAnimationCheckingSomething SB.BalloonType = msoBalloonTypeButtons SB.Heading = " H A L L O ! ! ! " SB.Text = _ "Ich bin Dein persönlicher Assistent" If SB.Show = msoBalloonButtonOK Then Assistant.Visible = False End If End Sub

ondalıklı toplam

ID : 1589
ISLEM : ondalıklı toplam
MAKRO KODU : TextBox13.Value = TextBox1*1 + TextBox2*1 + TextBox3*1+........

optionbutonla seçilen verinin yazdirilmasi

ID : 1590
ISLEM : optionbutonla seçilen verinin yazdirilmasi
MAKRO KODU : Private Sub CommandButton2_Click() Application.Visible = True UserForm1.Hide ActiveSheet.PageSetup.PrintArea = "$A$1:$H$20" ActiveSheet.PrintPreview EnableChanges:=False ActiveSheet.PrintOut copies:=2, Preview:=False 'copies:=1 kopya sayısını artırmak için Application.Visible = False UserForm1.Show End Sub

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