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


klasör oluşturuyormuşuz gibi bir dizin oluşturur

ID : 1351
ISLEM : klasör oluşturuyormuşuz gibi bir dizin oluşturur
MAKRO KODU : Sub Dizin_İsmi_Oluştur() Dim ds, a Set ds = CreateObject("Scripting.FileSystemObject") a = ds.BuildPath("C:\SXSİ", "\A") MsgBox a End Sub

klasör silme

ID : 1352
ISLEM : klasör silme
MAKRO KODU : Sub Klasör_Sil() Dim ds Set ds = CreateObject("Scripting.FileSystemObject") ds.DeleteFolder "C:\SXS\Deneme" End Sub

klasör ve dosya makrolarındaki yolları kendine göre düzenle

ID : 1353
ISLEM : klasör ve dosya makrolarındaki yolları kendine göre düzenle
MAKRO KODU : Sub DosyaKlasorYol() 'Aktif Çalışma Kitabının ismini Çalışma kitabının başlığına (en üste yazdırır) ActiveWindow.Caption = ActiveWorkbook.FullName 'Aktif Çalışma Kitabının ismini aktif hücreye yazdırır ActiveCell = ActiveWorkbook.FullName 'Aktif hücreye aktif sayfanın isminin yazdırılması ActiveCell.Value = ActiveSheet.Name 'Aktif Çalışma sayfasının isminin Çalışma kitabının başlığına (en üste) yazdırır ActiveWindow.Caption = ActiveSheet.Name 'belirtilen dizindeki dosyanın boyutunu verir MsgBox FileLen("C:\Ahmet\taşınan.xls") 'Belirtilen sürücüdeki klasörün ismini değiştirir Name "C:\Ahmet\Alihan\12.xls" As "C:\Veli\taşınan.xls" 'Belirtilen sürücüdeki klasörün ismini değiştirir Name "C:\Alis" As "C:\Ahmet" 'Yeni Klasör dizin oluşturur MkDir "c:\Alihan" End Sub

klasördeki dosyalari comboboxta göstermek

ID : 1354
ISLEM : klasördeki dosyalari comboboxta göstermek
MAKRO KODU : Private Sub UserForm_Initialize() MyPath = "C:\Temp\" MyObj = Dir(MyPath, vbDirectory) Do While MyObj "" i = i + 1 If (GetAttr(MyPath & MyObj) And vbDirectory) = vbDirectory Then If MyObj ".." And MyObj "." Then ComboBox1.AddItem MyObj End If End If MyObj = Dir Loop End Sub -

klasördeki tüm xls dosyalarını sxs klasörüne kopyala

ID : 1355
ISLEM : klasördeki tüm xls dosyalarını sxs klasörüne kopyala
MAKRO KODU : Sub Dosya_Kopyala() Dim ds Set ds = CreateObject("Scripting.FileSystemObject") ds.CopyFile "D:\ExcelÖrnekleri\*.xls", "C:\SXS" End Sub

klasördeki veya dizindeki xls dosyasının boyutunu öğrenme

ID : 1356
ISLEM : klasördeki veya dizindeki xls dosyasının boyutunu öğrenme
MAKRO KODU : Sub Groesse() Dim sFileName As String 'sFileName = ThisWorkbook.Name sFileName = "C:\xls.xls" 'C:\pir\xls.xls MsgBox "Diese Mappe hat eine Grösse von " & FileLen(sFileName) & " kB" End Sub

klasörden çalişma sayfasi açma köprü kurma

ID : 1357
ISLEM : klasörden çalişma sayfasi açma köprü kurma
MAKRO KODU : Sayfa1'e A1 hücresinden başlayarak aşağıdoğru klasör içindeki doyalara köprü kurar, anasayfanın adı "anasayfa.xls" olmalı veya kodu değiştirin Private Sub Workbook_Open() Dim fs, f, f1, fc, s Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(ActiveWorkbook.Path) Set fc = f.Files i = 1 For Each f1 In fc If f1.Name "anasayfa.xls" Then Sheets("Sayfa1"). Range("a" & i).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=f1.Name, _ TextToDisplay:=Mid(f1.Name, 1, Len(f1.Name) - 4) i = i + 1 End If Next End Sub -

klasöre gözat penceresini çağırır

ID : 1358
ISLEM : klasöre gözat penceresini çağırır
MAKRO KODU : Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type '32-bit API declarations Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer bInfo.pidlRoot = 0& If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If bInfo.ulFlags = &H1 x = SHBrowseForFolder(bInfo) path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Range("A1") = GetDirectory Else GetDirectory = "" End If End Function

klasöre gözat xls listele

ID : 1359
ISLEM : klasöre gözat xls listele
MAKRO KODU : Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Sub Verzeichnisse_auflisten() Dim Pfad1, Name1, Anzahl, X, X0, X1, X2, Verz, Anzverz, Größe Dim TB1, TB2 As Worksheet Dim msg As String Set TB1 = ThisWorkbook.Worksheets(1) Set TB2 = ThisWorkbook.Worksheets(2) start = Now TB1.[a:D] = "" TB2.[a:D] = "" 'überflüssige Tabellenblätter löschen If ThisWorkbook.Worksheets.Count > 2 Then Application.DisplayAlerts = False For X = 3 To ThisWorkbook.Worksheets.Count ThisWorkbook.Worksheets(3).Delete Next X Application.DisplayAlerts = True End If ' Pfad abfragen msg = "Wählen Sie bitte einen Ordner aus:" Pfad1 = getdirectory(msg) If Pfad1 = "" Then Exit Sub Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen. TB1.[a2] = Pfad1 Anzahl = 2 TB1.[a1] = "Pfad" TB1.[b1] = "UnterVerz." TB1.[c1] = "Anz. Dateien" TB1.[d1] = "Datgröße in Verz." X0 = 2 X1 = 2 Do While TB1.Cells(Rows.Count, 1).End(xlUp).Row TB1.Cells(Rows.Count, 2).End(xlUp).Row For X2 = X0 To X1 Pfad1 = TB1.Cells(X2, 1) ' Pfad setzen. If Right(Pfad1, 1) "\" Then Pfad1 = Pfad1 & "\" Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen. Verz = 0 Do While Name1 "" ' Schleife beginnen. ' Aktuelles und übergeordnetes Verzeichnis ignorieren. If Name1 "." And Name1 ".." Then ' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein ' Verzeichnis ist. If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then Anzahl = Anzahl + 1 TB1.Cells(Anzahl, 1) = Pfad1 & Name1 & "\" Verz = Verz + 1 'Eintrag nur anzeigen, wenn es sich um ein Verzeichnis handelt. End If End If Name1 = Dir ' Nächsten Eintrag abrufen. Loop TB1.Cells(X2, 2) = Verz Next X2 X0 = X1 + 1 X1 = X2 Loop 'Dateien aus den Verzeichnissen auslesen Anzverz = TB1.Cells(Rows.Count, 1).End(xlUp).Row i = 1 ii = 0 For Verz = 2 To Anzverz Anzahl = 0 Größe = 0 Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(TB1.Cells(Verz, 1)) Set fc = f.Files For Each f1 In fc If i = 65536 Then ii = ii + 1 ThisWorkbook.Worksheets.Add.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) ThisWorkbook.Worksheets(ii + 2).Name = "Dateien " & ii + 1 Set TB2 = ThisWorkbook.Worksheets(ii + 2) i = 1 End If i = i + 1 Anzahl = Anzahl + 1 TB2.Cells(i, 1) = f1.Name TB2.Cells(i, 2) = f & "\" & f1.Name 'Hyperlink auf die Datei einfügen TB2.Hyperlinks.Add Anchor:=TB2.Cells(i, 2), Address:= _ f & "\" & f1.Name TB2.Cells(i, 3) = FileLen(f1) TB2.Cells(i, 4) = FileDateTime(f1) Größe = Größe + FileLen(f1) Next TB1.Cells(Verz, 3) = Anzahl TB1.Cells(Verz, 4) = Größe / 1024 / 1024 Next Verz 'MsgBox (ii * 65536) + i ende = Now MsgBox "Anzahl der Verzeichnisse: " & Verz & Chr(13) & _ "Anzahl der Dateien: " & (ii * 65536) + i & Chr(13) & _ Chr(13) & "Dauer: " & Format(ende - start, "nn:ss") End Sub ' Muß erwähnt sein: Diese Funktion stammt nicht von mir. ' Die Quelle ist mir nicht mehr bekannt. Function getdirectory(Optional msg) As String Dim bInfo As BROWSEINFO Dim Path As String Dim r As Long, X As Long, pos As Integer ' Ausgangsordner = Desktop bInfo.pidlRoot = 0& ' Dialogtitel If IsMissing(msg) Then bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus." Else bInfo.lpszTitle = msg End If ' Rückgabe des Unterverzeichnisses bInfo.ulFlags = &H1 ' Dialog anzeigen X = SHBrowseForFolder(bInfo) ' Ergebnis gliedern Path = Space$(512) r = SHGetPathFromIDList(ByVal X, ByVal Path) If r Then pos = InStr(Path, Chr$(0)) getdirectory = Left(Path, pos - 1) Else getdirectory = "" End If End Function -

klasörün içinde kaç adet jpg uzantili dosya var ?

ID : 1360
ISLEM : klasörün içinde kaç adet jpg uzantili dosya var ?
MAKRO KODU : Sub jpgbul() Dim Dosya Dim i As Integer Dosya = Dir("C:\Evren\Resimler\*.jpg") i = 1 While Dosya "" Dosya = Dir Cells(i, 1) = Dosya i = i + 1 Wend MsgBox i - 1 End Sub -

klavye ok yönleri ile mesaj alma

ID : 1361
ISLEM : klavye ok yönleri ile mesaj alma
MAKRO KODU : Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = vbKeyEscape Then MsgBox "Escape'e bastın" End If If KeyCode = vbKeyRight Then MsgBox "sağ ok'a bastın" End If If KeyCode = vbKeyLeft Then MsgBox "sol ok'a bastın" End If If KeyCode = vbKeyUp Then MsgBox "ileri ok'a bastın" End If If KeyCode = vbKeyDown Then MsgBox "geri ok'a bastın" End If End Sub

kod yazarak showmodal durumunu ayarlamak.

ID : 1362
ISLEM : kod yazarak showmodal durumunu ayarlamak.
MAKRO KODU : Bir modul ilave edip, içine aşağıdakileri yapıştırın. Daha sonra da bir şekilde Test isimli prosedürü çalıştırın. (Formun adı - Name özelliği - UserForm1 olması ve kullanılan Excel versiyonunun 2000 veya üzerinde olması durumunda çalışır.) visual basic kodu: -------------------------------------------------------------------------------- Sub Test() UserForm1.Show 0 End Sub

kod yazarken

ID : 1363
ISLEM : kod yazarken
MAKRO KODU : Vba penceresinde kod yazarken örneğin Worksheets yazacaksınız, ancak bunu açılır pencereden seçmek için CTR + J yi, önerme veya tamamlama için ise CTR + ARA ÇUBUĞU'nu kullanabilirsiniz

koda formül adres yolunu hücreden vermek

ID : 1364
ISLEM : koda formül adres yolunu hücreden vermek
MAKRO KODU : Sub Yaz() ActiveCell.Formula = [b3].Text & ":\" & [c3].Text & "\" & [d3].Text & "\" & [e3].Text & "\[" & [e4] & ".xls]" & [e5] & " '!" & [e6] End Sub

kodlara açiklama ekleme

ID : 1365
ISLEM : kodlara açiklama ekleme
MAKRO KODU : KODLARIN BAŞINA VEYA SONUNA GİRİLDİĞİNDE AÇIKLAMA EKLER MsgBox "DENEME"

kodları kopyalama

ID : 1366
ISLEM : kodları kopyalama
MAKRO KODU : CTRL+C CTRL+V İLE KOPYALA YAPIŞTIR İŞLEMİNİ YAPABİLİRSİNİZ

kodlarin hata vermesini engeller

ID : 1367
ISLEM : kodlarin hata vermesini engeller
MAKRO KODU : BU KOD YAZDIĞINIZ KODLAR HATA VERİRSE ONU ENGELLER (KODUNUZUN BAŞINA EKLEYİN) On Error Resume Next

kolon numarasını ver kolonu bulsun

ID : 1368
ISLEM : kolon numarasını ver kolonu bulsun
MAKRO KODU : kullanılışı 'A1=5 'B1=Columnletter(A1) Function ColumnLetter(ColumnNumber As Integer) As String If ColumnNumber > 26 Then ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & Chr(((ColumnNumber - 1) Mod 26) + 65) Else ColumnLetter = Chr(ColumnNumber + 64) End If End Function

kolon sayısını yaz kolon adını harf olarak versin (ktf)

ID : 1369
ISLEM : kolon sayısını yaz kolon adını harf olarak versin (ktf)
MAKRO KODU : örnek kullanılışı =Columnletter(A1) Function ColumnLetter(ColumnNumber As Integer) As String If ColumnNumber > 26 Then ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & Chr(((ColumnNumber - 1) Mod 26) + 65) Else ColumnLetter = Chr(ColumnNumber + 64) End If End Function

komutları özelleştir penceresi

ID : 1370
ISLEM : komutları özelleştir penceresi
MAKRO KODU : Sub Dialog_18() Application.Dialogs(xlDialogCustomizeToolbar).Show End Sub

kopyala yapiştir

ID : 1371
ISLEM : kopyala yapiştir
MAKRO KODU : Tablonuzun herhangi bir hücresi seçiliyken aşağıdaki makroyu çalıştırın. Sub Makro1() Selection.CurrentRegion.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveCell.SpecialCells(xlLastCell).Select End Sub

kopyala yapiştir işlemleri

ID : 1372
ISLEM : kopyala yapiştir işlemleri
MAKRO KODU : KOPYALAMA YAPIŞTIRMA İŞLEMLERİ Sub kopya() Range("a1:a2").Copy Range("b1").PasteSpecial xlPasteValues Application.CutCopyMode = False Range("a1:a2").Value = "" End Sub

kopyalama ve yapıştırma

ID : 1373
ISLEM : kopyalama ve yapıştırma
MAKRO KODU : Sub autobreite() spbreite = ActiveCell.Columns.ColumnWidth Selection.Copy Range("A1").Select ActiveSheet.Paste With Selection .ColumnWidth = spbreite End With End Sub

kopyala-yapıştır

ID : 1374
ISLEM : kopyala-yapıştır
MAKRO KODU : Sub NewBar() Application.CommandBars.Add(Name:="BarPerso").Visible = True Application.CommandBars("BarPerso").Controls.Add Type:=msoControlButton, ID _ :=19, Before:=1 Application.CommandBars("BarPerso").Controls.Add Type:=msoControlButton, ID _ :=22, Before:=2 With CommandBars("BarPerso") .Left = 620 .Top = 450 .Width = 120 End With End Sub

kopyala-yapıştır'ı engelleme

ID : 1375
ISLEM : kopyala-yapıştır'ı engelleme
MAKRO KODU : Option Explicit Sub auto_open() 'kopyala kes yapıştırı açılışta pasif yapar EnableControl 21, False 'Kes EnableControl 19, False ' Kopyala EnableControl 22, False ' Yapıştır EnableControl 755, False ' özelyapıştır Application.OnKey "^c", "yasakla" Application.OnKey "^v", "yasakla" Application.CellDragAndDrop = False 'hücreyi çoğaltma ve taşıma CommandBars("ToolBar List").Enabled = False 'düzen menüsündeki ilgili menüleri gizle End Sub Sub auto_close() 'kopyala kes yapıştır kapanırken aktifleştirir EnableControl 21, True 'Kes EnableControl 19, True ' Kopyala EnableControl 22, True ' Yapıştır EnableControl 755, True ' özelyapıştır Application.OnKey "^c" Application.OnKey "^v" Application.CellDragAndDrop = True CommandBars("ToolBar List").Enabled = True End Sub Sub EnableControl(Id As Integer, Enabled As Boolean) Dim CB As CommandBar Dim C As CommandBarControl On Error Resume Next 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 Sub yasakla() MsgBox "Üzgünüm yapmak istediğiniz işlem yasaklanmıştır.!", , "www.kod.gen.tr" End Sub

korumali hücrelere siralama yapmak?

ID : 1376
ISLEM : korumali hücrelere siralama yapmak?
MAKRO KODU : Aşağıdaki makroyu sıralama işlemi için kullanıyorum. Ancak sayfa koruma yaptığım zaman doğal olarak sıralamayı yapmıyor. Kilitli ve gizli hücreleri seçerek, Diğer anlamda sayfa korumayı bozmadan sıralama işlemini nasıl yapabilirim. Sub SIRALA() Range("B6:F300").Select Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal MsgBox "BU İŞ BU KADAR ...)", vbInformation End Sub Bunun için kodlarınızın başına korumayı açan, sonunada korumayı tekrar koyan satırlar ilave edebilirsiniz. Örneğin koruma şifreniz "1234" olsun; visual basic kodu: Sub SIRALA() activesheet.unprotect "1234" Range("B6:F300").Sort Key1:=Range("B6") MsgBox "BU İŞ BU KADAR ...)", vbInformation activesheet.protect "1234" End Sub

korumali sayfada makro çalişir mi?

ID : 1377
ISLEM : korumali sayfada makro çalişir mi?
MAKRO KODU : Sub deneme() Sheets("Sayfa1").Unprotect Password:="sifre" 'Buraya sizin kodlarınız yazın. Sheets("Sayfa1").Protect Password:="sifre" End Sub

koşul sağlanıyorsa çıkarma işlemi yapsın

ID : 1378
ISLEM : koşul sağlanıyorsa çıkarma işlemi yapsın
MAKRO KODU : Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Target, Range("a1")) Is Nothing Then If Range("A1").Value = 6 Then Range("C1").Value = Range("C1").Value - Range("B1").Value End If End If End Sub

koşula göre çalişan makro

ID : 1379
ISLEM : koşula göre çalişan makro
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveCell.Address = "$A$1" And [a1] = 0 Then Call makroadı End Sub

koşullu biçimlendirme penceresi

ID : 1380
ISLEM : koşullu biçimlendirme penceresi
MAKRO KODU : Sub Dialog_14() Application.Dialogs(xlDialogConditionalFormatting).Show End Sub

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