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


tüm makroları seçtiğiniz bir klasördeki excel dosyalarının içindeki makroları listeler

ID : 2251
ISLEM : tüm makroları seçtiğiniz bir klasördeki excel dosyalarının içindeki makroları listeler
MAKRO KODU : Sub sirala() Dim sd As VBComponent Dim kodlar As CodeModule Dim Dosya Dim wb As Workbook i = 2 On Error Resume Next Application.DisplayAlerts = False Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör Seçiniz...", &H4, "") pth = ObjFolder.items.Item.Path ChDir (pth) Dosya = Dir("*.xls") While Dosya "" Set wb = Workbooks.Open(pth & "\" & Dosya) Windows(wb.Name).Visible = False For Each sd In wb.VBProject.VBComponents Set kodlar = sd.CodeModule basla = kodlar.CountOfDeclarationLines + 1 If Err.Number = 0 Then Do Until basla >= kodlar.CountOfLines If Err.Number 0 Then Err.Clear: Exit Do ThisWorkbook.Sheets(1).Cells(i, "A") = pth & "\" & Dosya ThisWorkbook.Sheets(1).Cells(i, "B") = kodlar.ProcOfLine(basla, vbext_pk_Proc) ThisWorkbook.Sheets(1).Cells(i, "C") = sd.Name basla = basla + kodlar.ProcCountLines(kodlar.ProcOfLine(basla, vbext_pk_Proc), vbext_pk_Proc) i = i + 1 Loop Else Err.Clear End If Next Dosya = Dir wb.Close False Wend End Sub -

tüm makroların listesi

ID : 2252
ISLEM : tüm makroların listesi
MAKRO KODU : ‘Referanslardan Microsoft visual Basic for Applications Extensibility x.x seçin ’Aktif kitaptaki makroları, A sütununa makronun adını, B sütununu da yerini belirtecek şekilde listeler. Sub sirala() Dim sd As VBComponent Dim kodlar As CodeModule i = 1 For Each sd In ActiveWorkbook.VBProject.VBComponents Set kodlar = sd.CodeModule basla = kodlar.CountOfDeclarationLines + 1 Do Until basla >= kodlar.CountOfLines Cells(i, "A") = kodlar.ProcOfLine(basla, vbext_pk_Proc) Cells(i, "B") = sd.Name basla = basla + kodlar.ProcCountLines(kodlar.ProcOfLine(basla, vbext_pk_Proc), vbext_pk_Proc) i = i + 1 Loop Next End Sub

tüm oppitobuttonları sıfırlar

ID : 2253
ISLEM : tüm oppitobuttonları sıfırlar
MAKRO KODU : Sub ResetAllOptionButtonsInUserForm() Dim ctrl As Control For Each ctrl In UserForm1.Controls If TypeName(ctrl) = "OptionButton" Then ctrl.Value = False End If Next ctrl End Sub

tüm resimleri silmek

ID : 2254
ISLEM : tüm resimleri silmek
MAKRO KODU : Sub Ekle_Nesne_TumSil() ActiveSheet.DrawingObjects.Delete End Sub Sub Ekle_Nesne_IstedigimiSil() Dim Picture As Object Dim Bak As String Dim Uzunluk As Byte Bak = InputBox("Hangi Türdeki Resim Silinecek?", "S. UZUNKÖPRÜ", "WordArt") Uzunluk = Len(Bak) For Each Picture In ActiveSheet.shapes If Mid(Picture.Name, 1, Uzunluk) = Bak Then Picture.Delete End If Next Picture End Sub

tüm satır sütunları gizle

ID : 2255
ISLEM : tüm satır sütunları gizle
MAKRO KODU : Sub sat_sut_giz() If TypeName(ActiveSheet) "Worksheet" Then Exit Sub If Rows(Rows.Count).Hidden = False And _ Columns(Columns.Count).Hidden = False Then Columns.Hidden = True Rows.Hidden = True With ActiveSheet.UsedRange .Columns.Hidden = False .Rows.Hidden = False End With Else Columns.Hidden = False Rows.Hidden = False End If End Sub -

tüm satır sütunları göster

ID : 2256
ISLEM : tüm satır sütunları göster
MAKRO KODU : Sub sat_sut_gos() If TypeName(ActiveSheet) "Worksheet" Then Exit Sub If Rows(Rows.Count).Hidden = True And _ Columns(Columns.Count).Hidden = True Then Columns.Hidden = False Rows.Hidden = False With ActiveSheet.UsedRange .Columns.Hidden = True .Rows.Hidden = True End With Else Columns.Hidden = True Rows.Hidden = True End If End Sub -

tüm satır ve sütunları gizler

ID : 2257
ISLEM : tüm satır ve sütunları gizler
MAKRO KODU : Sub Blenden() If TypeName(ActiveSheet) "Worksheet" Then Exit Sub If Rows(Rows.Count).Hidden = False And _ Columns(Columns.Count).Hidden = False Then Columns.Hidden = True Rows.Hidden = True With ActiveSheet.UsedRange .Columns.Hidden = False .Rows.Hidden = False End With Else Columns.Hidden = False Rows.Hidden = False End If End Sub -

tüm sayfada tek ve fazla seçimde renklendirme

ID : 2258
ISLEM : tüm sayfada tek ve fazla seçimde renklendirme
MAKRO KODU : Thisworkbooka Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range) Static OldIndex As Integer Static OldCell As Range On Error Resume Next OldCell.Interior.ColorIndex = OldIndex If Not OldCell Is Nothing Then OldIndex = Target.Interior.ColorIndex End If Target.Interior.ColorIndex = 6 Set OldCell = Target End Sub

tüm sayfalarda a1:a5, b6:b10,c1:c5, d4:d10 hücrelerinde veri var ise 0 yapar

ID : 2259
ISLEM : tüm sayfalarda a1:a5, b6:b10,c1:c5, d4:d10 hücrelerinde veri var ise 0 yapar
MAKRO KODU : Sub Reset_Values_All_WSheets() Dim wSht As Worksheet Dim myRng As Range Dim allwShts As Sheets Dim cel As Range Set allwShts = Worksheets For Each wSht In allwShts Set myRng = wSht.Range("A1:A5, B6:B10, C1:C5, D4:D10") For Each cel In myRng If Not cel.HasFormula And cel.Value 0 Then cel.Value = 0 End If Next cel Next wSht End Sub -

tüm sayfalarda resim (image) silme

ID : 2260
ISLEM : tüm sayfalarda resim (image) silme
MAKRO KODU : For Each sht In Worksheets sht.DrawingObjects.Delete Next

tüm sayfalarda zoom ayarı

ID : 2261
ISLEM : tüm sayfalarda zoom ayarı
MAKRO KODU : Thisworkbook a Private Sub Workbook_SheetActivate(ByVal Sh As Object) ActiveWindow.Zoom = 80 End Sub

tüm sayfaları gizle 1 sayfa mutlaka gözükür

ID : 2262
ISLEM : tüm sayfaları gizle 1 sayfa mutlaka gözükür
MAKRO KODU : Sub a() ‘On Error Resume Next ‘Application.DisplayAlerts = False For Each Sh In Sheets Sh.Visible = False Next Sh End Sub

tüm sayfaları gizler ve istediğiniz sayfayı gösterir ve tersini yapar

ID : 2263
ISLEM : tüm sayfaları gizler ve istediğiniz sayfayı gösterir ve tersini yapar
MAKRO KODU : Public bIsClosing As Boolean Dim wsSheet As Worksheet Sub HideAll() Application.ScreenUpdating = False For Each wsSheet In ThisWorkbook.Worksheets If wsSheet.CodeName = "Sheet1" Then wsSheet.Visible = xlSheetVisible Else wsSheet.Visible = xlSheetVeryHidden End If Next wsSheet Application.ScreenUpdating = True End Sub Sub ShowAll() bIsClosing = False For Each wsSheet In ThisWorkbook.Worksheets If wsSheet.CodeName "Sheet1" Then wsSheet.Visible = xlSheetVisible End If Next wsSheet Sheet1.Visible = xlSheetVeryHidden End Sub -

tüm sayfaları koruma altına alır, kilitler

ID : 2264
ISLEM : tüm sayfaları koruma altına alır, kilitler
MAKRO KODU : Sub protectAll() Dim myCount Dim i myCount = Application.Sheets.Count Sheets(1).Select For i = 1 To myCount ActiveSheet.Protect If i = myCount Then End End If ActiveSheet.Next.Select Next i End Sub

tüm sayfaları seçip alfabetik olarak son sayfayı aktif kılma

ID : 2265
ISLEM : tüm sayfaları seçip alfabetik olarak son sayfayı aktif kılma
MAKRO KODU : Sub SelectSheets1() Dim mySheet As Object For Each mySheet In Sheets With mySheet If .Visible = True Then .Select Replace:=False End With Next mySheet End Sub

tüm sayfaları seçme

ID : 2266
ISLEM : tüm sayfaları seçme
MAKRO KODU : Sub SelectSheets() Dim myArray() As Variant Dim i As Integer For i = 1 To Sheets.Count ReDim Preserve myArray(i - 1) myArray(i - 1) = i Next i Sheets(myArray).Select End Sub

tüm sayfaları seçme 2

ID : 2267
ISLEM : tüm sayfaları seçme 2
MAKRO KODU : Sub SelectSheets() Dim myArray() As Variant Dim i As Integer Dim j As Integer j = 0 For i = 1 To Sheets.Count If Sheets(i).Visible = True Then ReDim Preserve myArray(j) myArray(j) = i j = j + 1 End If Next i Sheets(myArray).Select End Sub

tüm sayfaların a1 değerlerini toplar mesajla bildirir

ID : 2268
ISLEM : tüm sayfaların a1 değerlerini toplar mesajla bildirir
MAKRO KODU : Sub Addieren() Dim Summen! Summen = 0 For i = 1 To Worksheets.Count Summen = Summen + Worksheets(i).[A1] Next MsgBox Summen End Sub

tüm sürücüleri gösterir

ID : 2269
ISLEM : tüm sürücüleri gösterir
MAKRO KODU : Sub Show_all_Drives() Dim myFSO As Object, myDrv As Object, drvCount, drvStr As String, vName As String, drvTyp As String Set myFSO = CreateObject("Scripting.FileSystemObject") Set drvCount = myFSO.Drives On Error Resume Next drvStr = "" For Each myDrv In drvCount Select Case myDrv.DriveType Case 0: drvTyp = "Unknown" Case 1: drvTyp = "Removable" Case 2: drvTyp = "Fixed" Case 3: drvTyp = "Network" Case 4: drvTyp = "CD-ROM" Case 5: drvTyp = "RAM Disk" End Select drvStr = drvStr & drvTyp & ": " & myDrv.DriveLetter & " - " '3 = Netzlaufwerk If myDrv.DriveType = 3 Then vName = myDrv.ShareName Else vName = myDrv.VolumeName End If drvStr = drvStr & vName & vbCrLf Next MsgBox drvStr End Sub

tüm şifreli sayfaları geri açma

ID : 2270
ISLEM : tüm şifreli sayfaları geri açma
MAKRO KODU : Sub UnProtectAllSheets() Dim ws As Worksheet Dim sOrigSheet As String Dim sOrigCell As String Dim J As Integer Application.ScreenUpdating = False sOrigSheet = ActiveSheet.Name sOrigCell = ActiveCell.Address For Each ws In Worksheets ws.Select ws.Unprotect Password:="Password" Next ws Application.GoTo Reference:=Worksheets("" & sOrigSheet & "").Range("" & sOrigCell & "") Application.ScreenUpdating = True End Sub

tüm textboxların içeriğini temizler

ID : 2271
ISLEM : tüm textboxların içeriğini temizler
MAKRO KODU : Private Sub CommandButton1_Click() Dim ctrl As Control For Each ctrl In UserForm1.Controls If TypeName(ctrl) = "TextBox" Then ctrl.Text = "" End If Next ctrl End Sub

txt dosyası açma

ID : 2272
ISLEM : txt dosyası açma
MAKRO KODU : Sub OuvreTXT() lanceur = Shell("C:\windows\notepad.exe c:\ali.txt", 1) End Sub

txt dosyasına a1 de değeri yazdırma

ID : 2273
ISLEM : txt dosyasına a1 de değeri yazdırma
MAKRO KODU : Sub a1txt() Var = [A1] FichierTXT = "C:\a\a.txt" 'à modifier If Len(Dir(FichierTXT)) > 1 Then Kill FichierTXT Open FichierTXT For Output As 1 Print #1, Var Close End Sub

txt dosyasını sayfada açıp içeriğini alma, txt dosyasının adı sayfa adı olur

ID : 2274
ISLEM : txt dosyasını sayfada açıp içeriğini alma, txt dosyasının adı sayfa adı olur
MAKRO KODU : Sub txt_import() pir = Application.GetOpenFilename("Txt-Dosyası , *.TXT") Workbooks.OpenText Filename:=pir, Origin:=xlWindows _ , StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon _ :=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(1, 1) End Sub

txt dosyasını seç yeni excel sayfasına yazsın

ID : 2275
ISLEM : txt dosyasını seç yeni excel sayfasına yazsın
MAKRO KODU : Sub Read_Large_File_2() Dim FileName As String Dim FileNum As Integer Dim ResultStr As String Dim wsSheet As Worksheet Dim strValues() As String Dim lngRows As Long Dim lngRow As Long Dim intSheet As Integer Dim intCounter As Integer FileName = Application.GetOpenFilename("Textdateien " & _ "(*.txt; *.csv),*.txt; *.csv") If FileName = "" Or FileName = "Falsch" Then Exit Sub FileNum = FreeFile() Open FileName For Input As #FileNum Application.ScreenUpdating = False Workbooks.Add template:=xlWorksheet lngRows = ActiveSheet.Rows.Count lngRow = 1 intSheet = 1 ReDim strValues(lngRows, 1) Application.StatusBar = "Blatt " & intSheet & " wird eingelesen" Do While Seek(FileNum) -

txt dosyasını silme

ID : 2276
ISLEM : txt dosyasını silme
MAKRO KODU : Sub DelFile() If Len(Dir("c:\metin.txt")) > 0 Then Kill "c:\metin.txt" MsgBox "Dosya silinmiştir." Else MsgBox "böyle bir dosya yok" End If End Sub

txt dosyasi açma

ID : 2277
ISLEM : txt dosyasi açma
MAKRO KODU : Örneğin C altındaki bir txt dosyasını açmak için; visual basic kodu: Shell "notepad.exe " & "c:\deneme.txt" Kendi klasöründeki bir txt dosyasını açmak içi; visual basic kodu: Shell "notepad.exe " & ActiveWorkbook.Path & "\deneme.txt"

txtbox a iki kritere göre veri getirme

ID : 2278
ISLEM : txtbox a iki kritere göre veri getirme
MAKRO KODU : Şartı seçtiğiniz comboboxa aşağıdaki kodu kopyalayın. visual basic kodu: Private Sub CmbSart_Change() For a = 2 To [a65536].End(3).Row If CmbUrun = Cells(a, "a") And CmbSart = Cells(a, "b") Then TxtFiyat = Cells(a, "c") Exit Sub End If Next End Sub Ürün comboboxuna da aşağıdaki kodu kopyalayın. visual basic kodu: Private Sub CmbUrun_Click() CmbSart_Change End Sub

undo---geri al

ID : 2279
ISLEM : undo---geri al
MAKRO KODU : Option Explicit '// This Sub creates a registry key for '// HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Excel\Options '// Creates Ref to Windows Script Host Object Model '// C:\WINDOWS\SYSTEM\WSHOM.OCX Const strKey As String = "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Excel\Options\UndoHistory" Const strType As String = "REG_DWORD" Const dVal = 16 ' Change this NB: > 100 Not recomended by Microsoft Sub ChangeXlUndoHistory() Dim objWSH As Object Set objWSH = CreateObject("WScript.Shell") objWSH.RegWrite strKey, dVal, strType Set objWSH = Nothing MsgBox ReadRegEdit(strKey) End Sub '// To Read a Key Function ReadRegEdit(key) Dim Ws, Tmp Set Ws = CreateObject("WScript.Shell") Tmp = Ws.RegRead(key) If Tmp = "" Then ReadRegEdit = "" Else ReadRegEdit = Tmp End If Set Ws = Nothing End Function

userform 1) userform başlığı

ID : 2280
ISLEM : userform 1) userform başlığı
MAKRO KODU : Private Sub UserForm_Initialize() UserForm1.Caption = "pir" End Sub

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