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


seçilen hücreyi sol üst köşeye alır

ID : 1951
ISLEM : seçilen hücreyi sol üst köşeye alır
MAKRO KODU : Sub TopLeft() ActiveCell.Select With ActiveWindow .ScrollColumn = ActiveCell.Column .ScrollRow = ActiveCell.Row End With End Sub

seçilen tüm hücreleri 0 yapar

ID : 1952
ISLEM : seçilen tüm hücreleri 0 yapar
MAKRO KODU : Sub ResetValues() On Error GoTo ErrorHandler For Each n In ActiveSheet.UsedRange If n.Value 0 Then n.Value = 0 End If TypeMismatch: Next n ErrorHandler: If Err = 13 Then 'Type Mismatch Resume TypeMismatch End If End Sub -

seçileni word belgesi olarak açar ve kopyalar

ID : 1953
ISLEM : seçileni word belgesi olarak açar ve kopyalar
MAKRO KODU : Sub WordSheetRangeCopy() Dim WordObj As Object Selection.Copy Set WordObj = CreateObject("Word.Basic") With WordObj .AppShow .FileNew .EditPaste End With Set WordObj = Nothing End Sub

seçilenin yazdırılması ve sorulması

ID : 1954
ISLEM : seçilenin yazdırılması ve sorulması
MAKRO KODU : Sub PrintSelectedCells() ' prints selected cells, use from a toolbar button or a menu Dim aCount As Integer, cCount As Integer, rCount As Integer Dim i As Integer, j As Long, aRange As String Dim rHeight() As Single, cWidth() As Single Dim AWB As Workbook, NWB As Workbook If UCase(TypeName(ActiveSheet)) "WORKSHEET" Then Exit Sub ' useful only in worksheets aCount = Selection.Areas.Count If aCount = 0 Then Exit Sub ' no cells selected cCount = Selection.Areas(1).Cells.Count If aCount > 1 Then ' multiple areas selected Application.ScreenUpdating = False Application.StatusBar = "Printing " & aCount & " selected areas..." Set AWB = ActiveWorkbook rCount = ActiveSheet.Cells.SpecialCells(xlLastCell).Row cCount = ActiveSheet.Cells.SpecialCells(xlLastCell).Column ReDim rHeight(rCount) ReDim cWidth(cCount) For i = 1 To rCount ' find the row height of every row in the selection rHeight(i) = Rows(i).RowHeight Next i For i = 1 To cCount ' find the column width of every column in the selection cWidth(i) = Columns(i).ColumnWidth Next i Set NWB = Workbooks.Add ' create a new workbook For i = 1 To rCount ' set row heights Rows(i).RowHeight = rHeight(i) Next i For i = 1 To cCount ' set column widths Columns(i).ColumnWidth = cWidth(i) Next i For i = 1 To aCount AWB.Activate aRange = Selection.Areas(i).Address ' the range address Range(aRange).Copy ' copying the range NWB.Activate With Range(aRange) ' pastes values and formats .PasteSpecial Paste:=xlValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False .PasteSpecial Paste:=xlFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False End With Application.CutCopyMode = False Next i NWB.PrintOut NWB.Close False ' close the temporary workbook without saving Application.StatusBar = False AWB.Activate Set AWB = Nothing Set NWB = Nothing Else If cCount -

seçili alanları durum çuğunda anlık toplar

ID : 1955
ISLEM : seçili alanları durum çuğunda anlık toplar
MAKRO KODU : Option Explicit Public bColored As Integer Sub ColoredToBW() Dim cht As Chart Dim chtSC As SeriesCollection Dim x As Integer Dim iSeriesCount As Integer Dim iColors(1 To 5, 0 To 1) As Integer Dim iColor As Integer 'Set colors for BW series iColors(1, 0) = 1 'Black iColors(2, 0) = 56 'Gray-80% iColors(3, 0) = 16 'Gray-50% iColors(4, 0) = 48 'Gray-40% iColors(5, 0) = 15 'Gray-25% 'Set colors for Color series iColors(1, 1) = 55 'Indigo iColors(2, 1) = 7 'pink iColors(3, 1) = 6 'yellow iColors(4, 1) = 8 'Turquoise iColors(5, 1) = 13 'Violet 'Toggle Color/BW change 0 to 1 or 1 to 0 bColored = 1 - bColored Set cht = ActiveChart 'check that a chart is selected If cht Is Nothing Then MsgBox ("Select a chart") Exit Sub End If Set chtSC = cht.SeriesCollection 'Check for MIN of number of series or 'colors and only do the minimum iSeriesCount = Application.WorksheetFunction.Min _ (UBound(iColors), chtSC.Count) For x = 1 To iSeriesCount 'Define the color iColor = iColors(x, bColored) 'Set the LINE color chtSC(x).Border.ColorIndex = iColor 'Marker color With chtSC(x) .MarkerBackgroundColorIndex = xlNone .MarkerForegroundColorIndex = iColor End With Next x End Sub

seçili hücrelerdeki en büyük değeri bulur ve kalın yapar

ID : 1956
ISLEM : seçili hücrelerdeki en büyük değeri bulur ve kalın yapar
MAKRO KODU : Sub ValMaxi() Dim Cel As Range Dim Val As Integer Dim Adr As String For Each Cel In Selection If Val -

seçili hücreleri emaille gönderir

ID : 1957
ISLEM : seçili hücreleri emaille gönderir
MAKRO KODU : Sub Excel_an_Outlook_Aufgabe() On Error GoTo ErrorAufgabe Dim MyError As Integer Dim Faellig As Date Dim Link As String Dim myolApp As Object, myitem As Object 'Eigene Fehleroutine/Nummer eröffnen MyError = 1 'Fälligkeit ist übermorgen Faellig = Date + 1 MyError = 2 Set myolApp = CreateObject("Outlook.Application") Set myitem = myolApp.CreateItem(3) myitem.Subject = "Datei ERFASSEN !" ' Text der Aufgabe myitem.DueDate = Faellig myitem.ReminderTime = Faellig 'Ein Link kann nur erstellt werden, wenn die Pfadangabe eine 'Angabe mit einem ShareName ist myitem.Body = "\\Computername\Freigabename\dateiname.xls" myitem.Save Set myitem = Nothing ErrorExit: Exit Sub ErrorAufgabe: Select Case MyError Case 1 MsgBox "Die Datei wurde noch nicht gespeichert" Case 2 MsgBox "Outlook kann nicht gestartet werden" & Chr$(13) &_ "Aufgabe wurde nicht erstellt !" End Select Resume ErrorExit End Sub

seçili hücrelerin hepsi küçük harf (yazım düzeni)

ID : 1958
ISLEM : seçili hücrelerin hepsi küçük harf (yazım düzeni)
MAKRO KODU : Sub LowerCase() Dim cell As Range For Each cell In Selection.Cells If cell.HasFormula = False Then cell = LCase(cell) End If Next End Sub

seçili hücreye boş bir açıklama ekler

ID : 1959
ISLEM : seçili hücreye boş bir açıklama ekler
MAKRO KODU : Sub imgComment() Dim nom$ On Error Resume Next For Each C In Selection nom = C.Value With C .AddComment .Comment.Shape.Fill.UserPicture ActiveWorkbook.Path & "\" & nom & ".jpg" End With Next End Sub

seçili hücreye gider

ID : 1960
ISLEM : seçili hücreye gider
MAKRO KODU : Sub InserImage() Dim nom$ Dim fichimg$ [C10].Select With ActiveWindow y = .Selection.Width End With On Error Resume Next nom = Selection.Offset(0, -1).Value fichimg = ActiveWorkbook.Path & "\" & nom & ".jpg" ActiveSheet.Pictures.Insert(fichimg).Select Selection.ShapeRange.Width = y End Sub

seçili hücreye isim verir (ad tanımlar)

ID : 1961
ISLEM : seçili hücreye isim verir (ad tanımlar)
MAKRO KODU : Sub RngName() Selection.Name = "myRange" End Sub

seçili hücreye mesajla 100 yazdırır

ID : 1962
ISLEM : seçili hücreye mesajla 100 yazdırır
MAKRO KODU : Sub Message() msg = "Voulez-vous continuer ?" ' Définit le message. Style = vbYesNo + vbDefaultButton1 'Définit les boutons. Title = "Bonjour !" ' Définit les titres. Réponse = MsgBox(msg, Style, Title) If Réponse = vbYes Then ' Vous avez choisi le bouton " Oui ". Set MaSélection = Application.ActiveCell MaSélection.Value = 100 Else Range("A1:b2").Select ' Accomplit une autre chose. End If End Sub

seçili hücreyi kopyalar ve word e aktarır

ID : 1963
ISLEM : seçili hücreyi kopyalar ve word e aktarır
MAKRO KODU : Sub Nach_Word_Kopieren() Dim WordObj As Object Selection.Copy Set WordObj = CreateObject("Word.Basic") With WordObj .AppShow 'Word 6/7: .AnwAnzeigen .FileNew 'Word 6/7: .DateiNeu .EditPaste 'Word 6/7: .BearbeitenEinfügen End With Set WordObj = Nothing End Sub

seçili satırın silinmesi, siğer sütunlardaki formülleri silmeden

ID : 1964
ISLEM : seçili satırın silinmesi, siğer sütunlardaki formülleri silmeden
MAKRO KODU : Dim s as integer Dim r as integer s = 8 ActiveCell.ClearContents r = ActiveCell.Row Range("A" & r + 1 & ":A" & s).Select Selection.Cut Destination:=Range("A" & r & ":A" & s - 1) Range("a" & r).Select

seçim ekle sub çift_kayitlari_arala

ID : 1965
ISLEM : seçim ekle sub çift_kayitlari_arala
MAKRO KODU : Sub çift_kayıtlari_arala() toplamsatır = ActiveSheet.UsedRange.Rows.Count For Row = toplamsatır To 2 Step -1 If Cells(Row, 1).Value Cells(Row - 1, 1).Value Then Rows(Row).Insert Next Row End Sub -

seçli hücrelerin zoom edilmesi

ID : 1966
ISLEM : seçli hücrelerin zoom edilmesi
MAKRO KODU : Range("A1:F15").Select 'set range zoom ActiveWindow.zoom = True

seri rakam gir tarihe çevirsin

ID : 1967
ISLEM : seri rakam gir tarihe çevirsin
MAKRO KODU : Dim hucre As Integer Dim eski_hucre, eski_hucre_column As String Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next If eski_hucre_column = "1" Then veri = ActiveCell Range(eski_hucre) = Format(DateValue(Left(Range(eski_hucre).Value, 2) & "." & _ Mid(Range(eski_hucre).Value, 3, 2) _ & "." & Right(Range(eski_hucre), 4)), "dd.mm.yyyy") End If eski_hucre = ActiveCell.Address eski_hucre_column = ActiveCell.Column End Sub

sesli okutma

ID : 1968
ISLEM : sesli okutma
MAKRO KODU : Function seslioku(sy) On Error Resume Next sesx$ = ThisWorkbook.Path & "\" & "numaralı cihazın kaydı yapılmıştır.wav" '--Eklenen kod---- dz1 = Array(" ", "bir", "iki", "üç", "dört", "beş", "altı", "yedi", "sekiz", "dokuz") dz2 = Array(" ", "on", "yirmi", "otuz", "kırk", "elli", "altmış", "yetmiş", "seksen", "doksan") dz3 = Array(" ", "", "bin", "milyon", "milyar", "trilyon", "katrilyon") tur = Len(sy) \ 3 kalan = Len(sy) Mod 3 k = 2 sayı = "" For i = 1 To tur sya = Mid(sy, (Len(sy) - k), 3) sy1 = dz1(Mid(sya, 3, 1)): sy2 = dz2(Mid(sya, 2, 1)): sy3 = dz1(Mid(sya, 1, 1)) Select Case Mid(sya, 1, 1) Case 1 sy3 = "yüz" Case Is > 1 sy3 = sy3 & " " & "yüz" End Select If i = 2 Then Select Case Val(sya) Case 0 sy1 = "" Case 1 sy1 = "bin" Case Is > 1 sy1 = sy1 & " " & "bin" End Select Else birim = dz3(i) End If If Val(sya) > 0 Then sayı = sy3 & " " & Trim(sy2) & " " & sy1 & " " & birim & " " & Trim(sayı) k = k + 3 Else k = k + 3 End If Next i If kalan = 0 Then f = sayı p = InStr(1, LTrim(f), " ") Do While p > 0 s = Trim(Mid(f, 1, p)) f = LTrim(Mid(f, p, Len(f))) p = InStr(1, f, " ") ses$ = ThisWorkbook.Path & "\" & s & ".wav" Call PlaySound(ses$, 1, 0) Loop If f "" Then s = f ses$ = ThisWorkbook.Path & "\" & s & ".wav" Call PlaySound(ses$, 1, 0) End If Call PlaySound(sesx$, 1, 0) '-------Eklenen kod------ Exit Function Else End If syb = Mid(sy, 1, kalan) sy11 = dz1(Mid(syb, kalan, 1)): sy22 = dz2(Mid(sy, kalan - 1, 1)) If tur = 1 Then Select Case Val(Mid(syb, 1, 2)) Case 0 sy11 = "" Case 1 sy11 = "bin" Case Is > 1 sy11 = sy11 & " " & "bin" End Select Else birim1 = dz3(tur + 1) End If sayı = sy22 & " " & sy11 & " " & birim1 & " " & sayı f = LTrim(sayı) p = InStr(1, f, " ") Do While p > 0 s = Trim(Mid(f, 1, p)) f = LTrim(Mid(f, p, Len(f))) p = InStr(1, f, " ") ses$ = ThisWorkbook.Path & "\" & s & ".wav" Call PlaySound(ses$, 1, 0) Loop If f "" Then s = f ses$ = ThisWorkbook.Path & "\" & s & ".wav" Call PlaySound(ses$, 1, 0) End If Call PlaySound(sesx$, 1, 0) '-------Eklenen kod------ End Function -

sesli saat

ID : 1969
ISLEM : sesli saat
MAKRO KODU : Sub Beeper() Beep start2 = Now() + TimeSerial(0, 0, 0.9) Application.Wait start2 For i = 2 To 3 start2 = Now() + TimeSerial(0, 0, 0.8) Application.Wait start2 Beep Next i End Sub

sheet'leri bir sheette toplamak

ID : 1970
ISLEM : sheet'leri bir sheette toplamak
MAKRO KODU : Bu kodu bir module ekleyip çalıştırırsanız kendıne yenı bır sayfa olusturup ne kadar sayfa varsa yenı sayfa da bırlestırıyor. Kod: Sub SayfaBirleştir() Dim YeniSayfa As Worksheet Dim SayfaSay SayfaSay = Worksheets.Count Set YeniSayfa = Worksheets.Add(After:=Worksheets(SayfaSay)) With YeniSayfa For i = 1 To SayfaSay Worksheets(i).UsedRange.Copy .Range("A" & IIf(i = 1, 1, .UsedRange.Rows.Count + 1)) Next End With End Sub

sıfıra bölünme hatasını yakalama

ID : 1971
ISLEM : sıfıra bölünme hatasını yakalama
MAKRO KODU : Sub Button32_Click () On Error GoTo HataKontrol A = 5 B = 0 Sunuc = A / B Exit Sub 'burada programa son verilir. HataKontrol: Select Case Err.Number Case 11: Mesaj = "Sıfıra bölünme hatası oluştu!!!" End Select MsgBox Mesaj Resume Next End Sub

sıralı (artan) sayfa ekler

ID : 1972
ISLEM : sıralı (artan) sayfa ekler
MAKRO KODU : örnek pir1, pir2, pir3 Option Explicit Public addShtCount As Long Public Sub AddSheets() addShtCount = addShtCount + 1 Dim straddShtCount As String straddShtCount = addShtCount newShtName = "pir" + straddShtCount Worksheets.Add ActiveSheet.Name = newShtName End Sub

sıralı sayfa ekler

ID : 1973
ISLEM : sıralı sayfa ekler
MAKRO KODU : Sub sayfaekle() For a = 1 To [a3] Sheets.Add.Move After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = a Next End Sub

sıralı ve hücre genişliğinde textbox oluşturma

ID : 1974
ISLEM : sıralı ve hücre genişliğinde textbox oluşturma
MAKRO KODU : Sub textbox_olustur() Dim a, b, c, d, e, f, g, h, i, j, Button Set a = [A2]: Set b = [B2]: Set c = [C2]: Set d = [D2]: Set e = [E2] Set f = [A4]: Set g = [B4]: Set h = [C4]: Set i = [D4]: Set j = [E4] '******************************************************************************************* Set Button = ActiveSheet.Buttons.Add(a.Left, a.Top, a.Width, a.Height) Set Button = ActiveSheet.Buttons.Add(b.Left, b.Top, b.Width, b.Height) Set Button = ActiveSheet.Buttons.Add(c.Left, c.Top, c.Width, c.Height) Set Button = ActiveSheet.Buttons.Add(d.Left, d.Top, d.Width, d.Height) Set Button = ActiveSheet.Buttons.Add(e.Left, e.Top, e.Width, e.Height) '******************************************************************************************* Set Button = ActiveSheet.Buttons.Add(f.Left + 3, f.Top + 3, f.Width - 4, f.Height - 4) Set Button = ActiveSheet.Buttons.Add(g.Left + 3, g.Top + 3, g.Width - 4, g.Height - 4) Set Button = ActiveSheet.Buttons.Add(h.Left + 3, h.Top + 3, h.Width - 4, h.Height - 4) Set Button = ActiveSheet.Buttons.Add(i.Left + 3, i.Top + 3, i.Width - 4, i.Height - 4) Set Button = ActiveSheet.Buttons.Add(j.Left + 3, j.Top + 3, j.Width - 4, j.Height - 4) End Sub

sırasıyla, b,c,d sütunlarına göre sıralama yapar.

ID : 1975
ISLEM : sırasıyla, b,c,d sütunlarına göre sıralama yapar.
MAKRO KODU : Sub sirala() [b3:f65536].Sort Key1:=[B3], Key2:=[C3], Key3:=[D3] End Sub

sil penceresi

ID : 1976
ISLEM : sil penceresi
MAKRO KODU : Sub Dialog_26() Application.Dialogs(xlDialogFileDelete).Show End Sub

simgeleri, menüleri ve butonları sayfaya ekleyin

ID : 1977
ISLEM : simgeleri, menüleri ve butonları sayfaya ekleyin
MAKRO KODU : Dim cbb As CommandBarButton, ComBar As CommandBar, cbc As CommandBarControl Sub CommandBarControlID_List() Dim a, b, c Application.ScreenUpdating = False For Each ComBar In Application.CommandBars If ComBar.Name = "test" Then ComBar.Delete Next Set ComBar = Application.CommandBars.Add(Name:="test", Position:=msoBarTop) b = 0 c = 1 For a = 1 To 50000 On Error Resume Next Set cbb = ComBar.Controls.Add(ID:=a) If Err.Number 0 Then GoTo weiter cbb.CopyFace With Workbooks("FaceIDs").Sheets(1) .Cells((c Mod 100) + 1, (c \ 100) + b + 1).Formula = a .Cells((c Mod 100) + 1, (c \ 100) + b + 2).Activate ActiveSheet.Paste .Cells((c Mod 100) + 1, (c \ 100) + b + 3).Formula = cbb.Caption End With If (c + 1) Mod 100 = 0 Then b = b + 3 c = c + 1 weiter: Application.CommandBars("test").FindControl(ID:=a).Delete Err.Clear Next End Sub Sub CommandBarFaceID_List() Dim a, b Application.ScreenUpdating = False For Each ComBar In Application.CommandBars If ComBar.Name = "test" Then ComBar.Delete Next On Error Resume Next Set ComBar = Application.CommandBars.Add(Name:="test", Position:=msoBarTop) Set cbb = ComBar.Controls.Add(ID:=1) b = 0 For a = 1 To 3518 With cbb .FaceId = a .CopyFace End With With ThisWorkbook.Sheets(1) .Cells((a Mod 100) + 1, (a \ 100) + b + 1).Formula = a .Cells((a Mod 100) + 1, (a \ 100) + b + 2).Activate ActiveSheet.Paste End With If (a + 1) Mod 100 = 0 Then b = b + 2 Next End Sub Sub CommandBar_List() Application.ScreenUpdating = False Dim a, b, c, cbc, d b = 1 d = 0 For Each a In Application.CommandBars Cells(b + d, 1) = a.Name Cells(b + d, 2) = "Item-no: " & b For Each cbc In a.Controls d = d + 1 Cells(b + d, 3) = cbc.Caption Cells(b + d, 4) = Cells(cbc.Type, 10) Cells(b + d, 5) = "Type: " & cbc.Type Cells(b + d, 6) = "ID: " & cbc.ID Next b = b + 1 Next End Sub -

siralama alttaki ayni numarayi seçtiğimde seçili numaranin bilgilerinin textboxa alinmasini istiyorum

ID : 1978
ISLEM : siralama alttaki ayni numarayi seçtiğimde seçili numaranin bilgilerinin textboxa alinmasini istiyorum
MAKRO KODU : bl = combobox1.ListIndex+1 cells(bl,2).select TextBox1.Value = ActiveCell.Offset(0, 0).Value TextBox2.Value = ActiveCell.Offset(0, 1).Value TextBox3.Value = ActiveCell.Offset(0, 2).Value TextBox4.Value = ActiveCell.Offset(0, 3).Value TextBox5.Value = ActiveCell.Offset(0, 4).Value TextBox6.Value = ActiveCell.Offset(0, 5).Value TextBox7.Value = ActiveCell.Offset(0, 6).Value TextBox8.Value = ActiveCell.Offset(0, 7).Value TextBox9.Value = ActiveCell.Offset(0, 8).Value TextBox10.Value = ActiveCell.Offset(0, 9).Value TextBox11.Value = ActiveCell.Offset(0, 10).Value TextBox12.Value = ActiveCell.Offset(0, 11).Value TextBox13.Value = ActiveCell.Offset(0, 12).Value TextBox14.Value = ActiveCell.Offset(0, 13).Value

sistem raporu

ID : 1979
ISLEM : sistem raporu
MAKRO KODU : Sub SysInfo() Dim s As String, oSystem As Object, item As Object Set oSystem = GetObject("winmgmts:").instancesOf("Win32_ComputerSystem") For Each item In oSystem s = "Computer Info" & vbCrLf s = s & "-------------------------------" & vbCrLf s = s & "Name: " & item.Name & vbCrLf s = s & "Status: " & item.Status & vbCrLf s = s & "Type: " & item.SystemType & vbCrLf s = s & "Mfg: " & item.Manufacturer & vbCrLf s = s & "Model: " & item.Model & vbCrLf s = s & "RAM: " & item.TotalPhysicalMemory \ 1024000 & "mb" & vbCrLf s = s & "Domain: " & item.Domain & vbCrLf s = s & "Role: " & TranslateDomainRole(item.DomainRole) & vbCrLf s = s & "Current User: " & item.UserName & vbCrLf MsgBox s Next Set oSystem = Nothing End Sub Function TranslateDomainRole(ByVal roleID) As String Dim RetString As String Select Case roleID Case 0 RetString = "Standalone Workstation" Case 1 RetString = "Member Workstation" Case 2 RetString = "Standalone Server" Case 3 RetString = "Member Server" Case 4 RetString = "Backup Domain Controller" Case 5 RetString = "Primary Domain Controller" Case Else RetString = "Unknown" End Select TranslateDomainRole = RetString End Function

sistem tarihini açma

ID : 1980
ISLEM : sistem tarihini açma
MAKRO KODU : Private Sub cmdSetClock_Click() Shell "rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", vbNormalFocus End Sub

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