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


sayfa silerken uyarı gelmemesi

ID : 1
ISLEM : sayfa silerken uyarı gelmemesi
MAKRO KODU : Sub Sil() Application.DisplayAlerts = False ActiveSheet.Delete End Sub 'Çıkışta Eski Haline Getirir. Sub Auto_Close() Application.DisplayAlerts = True End Sub

"a1:m8" hücrelerinin arkaplani yanip söner

ID : 2
ISLEM : "a1:m8" hücrelerinin arkaplani yanip söner
MAKRO KODU : Sub FlashBack() 'Make cell range Background color, flash x times, x fast, in x color, 'when Ctrl-a is pressed. Dim newColor As Integer Dim myCell As Range Dim x As Integer Dim fSpeed 'Make this cell range background flash! Set myCell = Range("A1:M8") Application.DisplayStatusBar = True Application.StatusBar = "... Select Cell to Stop and Edit or Wait for Flashing to Stop! " 'Make cell background flash to this color! 'Black 25, Magenta 26, Yellow 27, Cyan 28, Violet 29, Dark Red 30, 'Teal 31, Blue 32, White 2, Red 3, Light Blue 41, Dark Blue 11, 'Gray-50% 16, Gray-25% 15, Bright Cyan 8. newColor = 11 'Make the cell range flash fast: 0.01 to slow: 0.99 fSpeed = 0.2 'Make cell flash, this many times! Do Until x = 2 'Run loop! DoEvents Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Interior.ColorIndex = newColor Loop Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Interior.ColorIndex = xlNone Loop x = x + 1 Loop Application.StatusBar = False Application.DisplayStatusBar = Application.DisplayStatusBar End Sub

0 olan hücreleri geri alma

ID : 3
ISLEM : 0 olan hücreleri geri alma
MAKRO KODU : Type SaveRange Val As Variant Addr As String End Type ' Stores info about current selection Public OldWorkbook As Workbook Public OldSheet As Worksheet Public OldSelection() As SaveRange Sub ZeroRange() ' Inserts zero into all selected cells ' Abort if a range isn't selected If TypeName(Selection) "Range" Then Exit Sub ' The next block of statements ' Save the current values for undoing ReDim OldSelection(Selection.Count) Set OldWorkbook = ActiveWorkbook Set OldSheet = ActiveSheet i = 0 For Each cell In Selection i = i + 1 OldSelection(i).Addr = cell.Address OldSelection(i).Val = cell.Formula Next cell ' Insert 0 into current selection Application.ScreenUpdating = False Selection.Value = 0 ' Specify the Undo Sub Application.OnUndo "Undo the ZeroRange macro", "UndoZero" End Sub Sub UndoZero() ' Undoes the effect of the ZeroRange sub ' Tell user if a problem occurs On Error GoTo Problem Application.ScreenUpdating = False ' Make sure the correct workbook and sheet are active OldWorkbook.Activate OldSheet.Activate ' Restore the saved information For i = 1 To UBound(OldSelection) Range(OldSelection(i).Addr).Formula = OldSelection(i).Val Next i Exit Sub ' Error handler Problem: MsgBox "Can't undo" End Sub Other examples of Undo -

0 sıfırın tüm çalışma kitabında gösterilmemesi için

ID : 4
ISLEM : 0 sıfırın tüm çalışma kitabında gösterilmemesi için
MAKRO KODU : Option Explicit Sub Auto_Open() Dim sht As Worksheet For Each sht In Worksheets sht.Activate ActiveWindow.DisplayZeros = False Next sht End Sub Sub Auto_Close() Dim sht As Worksheet For Each sht In Worksheets sht.Activate ActiveWindow.DisplayZeros = True Next sht End Sub Sub BaskaBirYöntem() Dim byt As Byte For byt = 1 To Worksheets.Count Worksheets(byt).Activate ActiveWindow.DisplayZeros = False Next byt End Sub

1 den 26 ya kadar olan kolon sayısı kadar gizleme

ID : 5
ISLEM : 1 den 26 ya kadar olan kolon sayısı kadar gizleme
MAKRO KODU : Sub LeereSpalteAus() Dim i% For i = 1 To 26 If IsEmpty(Cells(Rows.Count, i).End(xlUp)) Then Columns(i).Hidden = True End If Next i End Sub

1. satirla 2. satir arasina 7 tane satir ekledi

ID : 6
ISLEM : 1. satirla 2. satir arasina 7 tane satir ekledi
MAKRO KODU : Sub SATIREKLE() For i = 2 To 8 If Cells(i, 1) Cells(i + 1, 1) Then Rows(i + 1).EntireRow.Insert End If Next i End Sub sizin yaptığınızdan esinlenerek şöyle bir şey yaptım. O da sadece 1. satırla 2. satır arasına 7 tane satır ekledi. Yani döngüde ilk if'in sağlandığı yere. -

1.pir adlı sayfayı kopyalayarak 10 adet çoğaltır ve .pir ekler

ID : 7
ISLEM : 1.pir adlı sayfayı kopyalayarak 10 adet çoğaltır ve .pir ekler
MAKRO KODU : Sub Modul_Loeschen() Dim Ini As Integer For Ini = 2 To 10 Sheets("1.pir").Copy After:=Sheets(Worksheets.Count) ActiveSheet.Name = Ini & ".pir" Next Ini With Application.VBE.ActiveVBProject .vbComponents.Remove .vbComponents("Modul1") End With End Sub

1.satır 1.sütunu seç

ID : 8
ISLEM : 1.satır 1.sütunu seç
MAKRO KODU : Sub sec() Cells(1, 1).Select End Sub

1.sayfa hariç diğerlerini uyarısız siler

ID : 9
ISLEM : 1.sayfa hariç diğerlerini uyarısız siler
MAKRO KODU : Sub birincisayfaharicsil() Application.DisplayAlerts = False While Worksheets.Count > 1 Sheets(2).Delete Wend Application.DisplayAlerts = True End Sub

1.sayfa hariç tüm sayfalari gizle

ID : 10
ISLEM : 1.sayfa hariç tüm sayfalari gizle
MAKRO KODU : Sub xlVeryHidden_All_Sheets() On Error Resume Next Dim sh As Worksheet For Each sh In Worksheets sh.Visible = xlVeryHidden Next End Sub

1.sayfayı açma

ID : 11
ISLEM : 1.sayfayı açma
MAKRO KODU : Sub FirstSheet() Sheets(1).Select End Sub

10 sn süreli mesaj

ID : 12
ISLEM : 10 sn süreli mesaj
MAKRO KODU : ThisWorkbook a Private Sub Workbook_Open() Dim WshShell Dim intText As Integer Set WshShell = CreateObject("WScript.Shell") intText = WshShell.Popup("Diese ''MsgBox'' wird nach 10 sec geschlossen", _ 10, "''MsgBox'' für 10 sec (©)2003 KMB", vbSystemModal) End Sub

10.satırdan itibaren gizleme ve gösterme

ID : 13
ISLEM : 10.satırdan itibaren gizleme ve gösterme
MAKRO KODU : Sub BenutzterBereich() Dim WsTabelle As Worksheet On Error Resume Next For Each WsTabelle In Worksheets With WsTabelle .Rows(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":65536").EntireRow.Hidden = _ Not .Rows(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":65536").EntireRow.Hidden .Range(.Cells(1, .UsedRange.SpecialCells(xlCellTypeLastCell).Column + 1), .Cells(65536, 256)).EntireColumn.Hidden = _ Not .Range(.Cells(1, .UsedRange.SpecialCells(xlCellTypeLastCell).Column + 1), .Cells(65536, 256)).EntireColumn.Hidden End With Next WsTabelle End Sub

100 buton bar ekle kaldır

ID : 14
ISLEM : 100 buton bar ekle kaldır
MAKRO KODU : Sub Auto_Open() Toolbars("100 Button Faces").Visible = True Toolbars("Custom Toolfaces").Visible = True End Sub Sub Auto_Close() Toolbars("100 Button Faces").Delete Toolbars("Custom Toolfaces").Delete End Sub

2 listboxlar arası verş taşıma

ID : 15
ISLEM : 2 listboxlar arası verş taşıma
MAKRO KODU : Private Sub UserForm_Initialize() ListBox1.RowSource = "A1:A" & Cells(65536, 1).End(xlUp).Row ListBox1.ListStyle = fmListStyleOption ListBox1.MultiSelect = fmMultiSelectMulti End Sub ' Private Sub CommandButton1_Click() ListBox2.Clear For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) = True Then ListBox2.AddItem ListBox1.List(i) End If Next End Sub

2 listboxlar arası verş taşıma

ID : 16
ISLEM : 2 listboxlar arası verş taşıma
MAKRO KODU : Private Sub UserForm_Initialize() ListBox1.ColumnCount = 6 ListBox2.ColumnCount = 6 ListBox1.ListStyle = fmListStyleOption ListBox1.MultiSelect = fmMultiSelectMulti ListBox1.RowSource = "A1:F" & Cells(65536, 1).End(xlUp).Row End Sub ' Private Sub CommandButton1_Click() Dim MyArray() ListBox2.Clear For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) = True Then For j = 0 To 5 ReDim Preserve MyArray(5, xx) MyArray(j, xx) = ListBox1.List(i, j) Next xx = xx + 1 End If Next ListBox2.List() = WorksheetFunction.Transpose(MyArray) End Sub

2 tane userform_initialize olayini birleştirme

ID : 17
ISLEM : 2 tane userform_initialize olayini birleştirme
MAKRO KODU :

2.sütunda çift tıkla eklenecek satırı belirle

ID : 18
ISLEM : 2.sütunda çift tıkla eklenecek satırı belirle
MAKRO KODU : Private Sub Worksheet_BeforeDoubleClick(ByVal _ Target As Range, Cancel As Boolean) 'D.McRitchie, 2004-09-21, nsert more rows up ' until 15, no deletions of rows If Target.Column 2 Then Exit Sub If Not IsNumeric(Target) Then Exit Sub Cancel = True Dim i As Long, curv As Long, tov As Long curv = Target.Value tov = InputBox("supply new total rows", _ "Rows input", curv + 1) If tov -

3 boyutlu hücreye kenarlık

ID : 19
ISLEM : 3 boyutlu hücreye kenarlık
MAKRO KODU : Sub Makro1() With ActiveCell.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With ActiveCell.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With End Sub

3 kere şifre hakkı

ID : 20
ISLEM : 3 kere şifre hakkı
MAKRO KODU : Sub auto_open() Static sayac As Integer Do If sayac = 3 Then ThisWorkbook.Close False Else If InputBox("Şifreyi girin") = "1" Then GoTo devam Else sayac = sayac + 1 End If End If Loop devam: End Sub

3 sn içerisinde msg box alarm

ID : 21
ISLEM : 3 sn içerisinde msg box alarm
MAKRO KODU : Sub timerMsg() Dim alertTime MsgBox "The alarm will go off in 3 seconds!" alertTime = Now + TimeValue("00:00:03") Application.OnTime alertTime, "msg" End Sub Sub msg() MsgBox "Three Seconds is up!" End Sub

30 excel dosyasi içinde bir kelime aratma

ID : 22
ISLEM : 30 excel dosyasi içinde bir kelime aratma
MAKRO KODU : Alpenin çözümüde olur ama kod olarak da;Dosyaları Sayfanıza ekliyerek,Görerek Bulabilirsiniz.Burada excellerin yolu olarak D:\Belgelerim aldım.Siz yolu değiştirebilrsiniz.Kodları modüle yapıştırın.Daha sonra Butona FileList makrosunu atayın.Kod: Sub FileList() Dim FileNamesList As Variant, i As Integer FileNamesList = CreateFileList("*.xls", True) Range("A:B").ClearContents For i = 1 To UBound(FileNamesList) Cells(i + 1, 1) = FileNamesList(i) Cells(i + 1, 2) = FileSize(Dir(FileNamesList(i))) Next Columns("A:B").AutoFit End Sub Function CreateFileList(FileFilter As String, IncludeSubFolder As Boolean) As Variant Dim FileList() As String, FileCount As Long CreateFileList = "" Erase FileList With Application.FileSearch .NewSearch .LookIn = "D:\Belgelerim\" .Filename = FileFilter .SearchSubFolders = IncludeSubFolder If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function ReDim FileList(.FoundFiles.Count) For FileCount = 1 To .FoundFiles.Count FileList(FileCount) = .FoundFiles(FileCount) Next End With CreateFileList = FileList Erase FileList End Function Function FileSize(filespec) Dim fs, f, f1, fc Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder("D:\Belgelerim\") Set fc = f.Files For Each f1 In fc If f1.Name = filespec Then FileSize = f1.Size / 1024 & " Kb" Next End Function Dosyalar Geldikten Sonra şu makro ile Dosyaların adlarını ayırarak İstediğin dosyayı fonksiyonlarla Bulabilirsin..Tabi bu yöntem tam istediğiniz değil ama yinede örnek olarak bulunsun.Kod: Sub ayır() Columns("A:A").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _ :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)) ActiveWindow.ScrollColumn = 2 End Sub

4 işlem programı(basit)

ID : 23
ISLEM : 4 işlem programı(basit)
MAKRO KODU : Private Sub Command1_Click() Dim sayı1, sayı2, sonuç As Double sayı1 = Val(Text1.Text) sayı2 = Val(Text2.Text) If Option1 = True Then sonuç = sayı1 + sayı2 If Option2 = True Then sonuç = sayı1 - sayı2 If Option3 = True Then sonuç = sayı1 * sayı2 If Option4 = True Then sonuç = sayı1 / sayı2 Text3.Text = Str(sonuç) End Sub

4. satırda işlem yapılırsa macro otomatik çalışsın

ID : 24
ISLEM : 4. satırda işlem yapılırsa macro otomatik çalışsın
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Row = 4 Then MsgBox "Aşkından Selamlar" End Sub

4. sütunda işlem yapılırsa macro otomatik çalışsın

ID : 25
ISLEM : 4. sütunda işlem yapılırsa macro otomatik çalışsın
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Column = 4 Then MsgBox "Aşkın'dan Selamlar" End Sub

5 dk da bir kitabı kaydetme

ID : 26
ISLEM : 5 dk da bir kitabı kaydetme
MAKRO KODU : Sub auto_open() Application.OnTime Now + TimeValue("00:05:00"), "Kayıt" End Sub Sub Kayıt() ActiveWorkbook.Save MsgBox "Kitap Kaydedildi" Call auto_open End Sub

5. sütünundaki hücreye girilen veriye karşılık farklı farklı makroların çalışması

ID : 27
ISLEM : 5. sütünundaki hücreye girilen veriye karşılık farklı farklı makroların çalışması
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column 6 Then Exit Sub Select Case Target.Value Case "a" A_Makrosu Case "b" B_Makrosu Case "c" C_Makrosu End Select End Sub -

65536 dan çoksa diğer sheet ' e atsin istiyorum....

ID : 28
ISLEM : 65536 dan çoksa diğer sheet ' e atsin istiyorum....
MAKRO KODU : Sub GetTxtData2() 'Raider ® Dim MyFile As String MyFile = "C:\Test.txt" j = 0 Set NewSh = Worksheets.Add j = j + 1 NewSh.Name = "TextSheet-" & j Open MyFile For Input As #1 Do While Not EOF(1) i = i + 1 Line Input #1, InputData Cells(i, 1) = InputData If i > 65535 Then Set NewSh = Worksheets.Add j = j + 1 NewSh.Name = "TextSheet-" & j i = 0 End If Loop Close #1 Set NewSh = Nothing End Sub

9 farkli değer için koşullu biçimlendirme

ID : 29
ISLEM : 9 farkli değer için koşullu biçimlendirme
MAKRO KODU : Aşağıdaki kodu sayfanın kod sayfasına kopyalayın. A1 hücresine yazdığınız sayı renk indexi olarak kabul edilmiştir. visual basic kodu: Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address "$A$1" Or IsNumeric(Target) = False Then Exit Sub Target.Interior.ColorIndex = Target End Sub -

a hücresindeki değere göre sayfaya kaydetme

ID : 30
ISLEM : a hücresindeki değere göre sayfaya kaydetme
MAKRO KODU : Sub aktar() Set verisayfasi = Sheets(1) Select Case Range("a1").Value Case "A" Set sayfam = Sheets(1) Case "B" Set sayfam = Sheets(2) Case "C" Set sayfam = Sheets(3) Case "D" Set sayfam = Sheets(4) End Select ensonhucre = sayfam.Range("A65000").End(xlUp).Row 'son hucreye A sutunundan baktım For i = 1 To 5 sayfam.Cells(ensonhucre, i) = verisayfasi.Cells(2, i) Next End Sub

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