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


verilerin rapor olarak saklanmasi

ID : 2431
ISLEM : verilerin rapor olarak saklanmasi
MAKRO KODU : Sub veriaktar() Sheets("sayfa1").Range("D3:D12").Copy sat = Sheets("sayfa2").Cells(65536, 2).End(xlUp).Row Sheets("sayfa2").Cells(sat + 1, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True Application.CutCopyMode = False End Sub

verinin bittiği ilk boş satira yapiştirmak

ID : 2432
ISLEM : verinin bittiği ilk boş satira yapiştirmak
MAKRO KODU : Sub Düğme1_Tıklat() Selection.Copy 'seçili alanı kopyala Range("A:A").End(xlDown).Offset(1, 0).Select 'en son satıra git ActiveSheet.Paste 'yapıştır Application.CutCopyMode = False 'kopyalanları iptal et End Sub

verisiz son satıra götürür

ID : 2433
ISLEM : verisiz son satıra götürür
MAKRO KODU : SON SATIRA GÖTÜRÜR Private Sub CommandButton1_Click() Dim alan, satırsayısı, sonsatır Set alan = Cells(1, 1).CurrentRegion satırsayısı = alan.Rows.Count sonsatır = satırsayısı + 1 Cells(sonsatır, 1).Select End Sub SON HÜCREYE GÖTÜRÜR Sub ActivateNextBlankDown() Range("A1").Select ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop End Sub 'LABELDEN SAYFANIN VERİLEN ADRESİNE VERİSİZ SON HÜCREYE YAZDIRIR Private Sub Label1_Click() Range("A1").Select ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop ActiveCell.FormulaR1C1 = "ZIMPARALI VALYAN PROBLEMİ" End End Sub

verisiz son satira götürür

ID : 2434
ISLEM : verisiz son satira götürür
MAKRO KODU : SON SATIRA GÖTÜRÜR Private Sub CommandButton1_Click() Dim alan, satırsayısı, sonsatır Set alan = Cells(1, 1).CurrentRegion satırsayısı = alan.Rows.Count sonsatır = satırsayısı + 1 Cells(sonsatır, 1).Select End Sub SON HÜCREYE GÖTÜRÜR Sub ActivateNextBlankDown() Range("A1").Select ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop End Sub 'LABELDEN SAYFANIN VERİLEN ADRESİNE VERİSİZ SON HÜCREYE YAZDIRIR Private Sub Label1_Click() Range("A1").Select ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop ActiveCell.FormulaR1C1 = "ZIMPARALI VALYAN PROBLEMİ" End End Sub

veriye göre sayfa oluşturmak ve satirlari kopyalamak

ID : 2435
ISLEM : veriye göre sayfa oluşturmak ve satirlari kopyalamak
MAKRO KODU : Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) For Each linkler In ActiveWorkbook.ActiveSheet.Hyperlinks linkler.SubAddress = Right(linkler.SubAddress, Len(linkler.SubAddress) - InStr(linkler.SubAddress, "!")) Next End Sub

versiyon numaralarını öğrenme

ID : 2436
ISLEM : versiyon numaralarını öğrenme
MAKRO KODU : Sub version_number() Dim mtext mtext = "Programın Adı: " & Application.Name _ & Chr(13) & "İşletim Sistemi: " & _ Application.OperatingSystem & Chr(13) & _ "Version Numarası: " & Application.Version _ & Chr(13) & "Yapım Numarası: " & Application.Build MsgBox mtext End Sub

virgülden sonra sıfır ekleme

ID : 2437
ISLEM : virgülden sonra sıfır ekleme
MAKRO KODU : Sub SetFigures() Dim iDecimals As Integer Dim bCommas As Boolean Dim sFormat As String Dim CellRange As Range Dim TestCell As Range bCommas = False 'Change as desired Set CellRange = Selection For Each TestCell In CellRange If Abs(TestCell.Value) 0 Then sFormat = sFormat & _ "." & String(iDecimals, "0") TestCell.NumberFormat = sFormat Next TestCell End Sub -

virgüllü kelimeleri alt alta sıralar

ID : 2438
ISLEM : virgüllü kelimeleri alt alta sıralar
MAKRO KODU : Sub SplitCells() Tstring = Selection.Value For i = 1 To Len(Tstring) If Mid(Tstring, i, 1) = "," Then z = z + 1 Next i ReDim y(z + 1) For i = 1 To Len(Tstring) If Mid(Tstring, i, 1) "," Then x = x & Mid(Tstring, i, 1) End If If Mid(Tstring, i, 1) = "," Then y(c) = x c = c + 1 x = "" End If Next i y(z) = x For i = 0 To UBound(y) Selection.Offset(i + 1, 0).Value = y(i) Next i End Sub -

visual basic project erişimine güven çekbox'ini true yapmak.

ID : 2439
ISLEM : visual basic project erişimine güven çekbox'ini true yapmak.
MAKRO KODU : Sub Test3() Dim WSH_Shell As Object Dim MyVer As String, RegKey As String Dim MySetting As Integer MyVer = Application.Version RegKey = "HKLM\Software\Microsoft\Office\" & MyVer & "\Excel\Security\AccessVBOM" Set WSH_Shell = CreateObject("WScript.Shell") WSH_Shell.RegWrite RegKey, 1, "REG_DWORD" End Sub Durumu düzeltmek için aşağıdaki kodu kullanın. Kod: Sub PanZehir() Dim WSH_Shell As Object Dim MyVer As String, RegKey As String Dim MySetting As Integer MyVer = Application.Version RegKey = "HKLM\Software\Microsoft\Office\" & MyVer & "\Excel\Security\AccessVBOM" Set WSH_Shell = CreateObject("WScript.Shell") WSH_Shell.RegDelete RegKey End Sub

wait" yerine başka bir komut

ID : 2440
ISLEM : wait" yerine başka bir komut
MAKRO KODU : [i]30 Basla = Timer 40 Cells(satır, 5) = Now() Cells(satır, 6).Value = Cells(2, 4).Value Application.Wait (Now + TimeSerial(0, 0, 5)) 'Do While Timer -

wav çaldırma

ID : 2441
ISLEM : wav çaldırma
MAKRO KODU : Declare Function sndPlaySound32 Lib "winmm.dll" Alias _ "sndPlaySoundA" (ByVal lpszSoundName As String, _ ByVal uFlags As Long) As Long Sub Klang() Call sndPlaySound32("D:\Programme\ICQ\Connect.wav", 0) End Sub

wav çalma

ID : 2442
ISLEM : wav çalma
MAKRO KODU : Declare Function sndPlaySound32 Lib "winmm.dll" _ Alias "sndPlaySoundA" (ByVal lpszSoundName _ As String, ByVal uFlags As Long) As Long Sub wav_cal() On Error Resume Next ChDir "a" If Err = 76 Then GoTo pir End pir: Call sndPlaySound32("C:\excel\warning.wav", 1) End Sub

wav dosyası çalma 1

ID : 2443
ISLEM : wav dosyası çalma 1
MAKRO KODU : Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _ (ByVal lpzSoundName As String, ByVal uFlags As Long) As Long Sub Musique() If Application.CanPlaySounds Then Call sndPlaySound32("D:\creedenc.wav", 0) 'Changer le chemin...("D:\.....", 0) End If End Sub

wav dosyası çalma 2

ID : 2444
ISLEM : wav dosyası çalma 2
MAKRO KODU : Sub Auto_Open() Worksheets("Sheet1").OnCalculate = "PlayIt" End Sub Sub PlayIt() If Range("A1").Value > 5 Then ExecuteExcel4Macro ("SOUND.PLAY(, ""C:\Windows\Media\Tada.wav"")") End If End Sub

wav dosyası çalma 3

ID : 2445
ISLEM : wav dosyası çalma 3
MAKRO KODU : Declare Function sndPlaySound32 Lib "winmm.dll" Alias _ "sndPlaySoundA" (ByVal lpszSoundName As String, _ ByVal uFlags As Long) As Long Sub Klang() Call sndPlaySound32("D:\Programme\ICQ\Connect.wav", 0) End Sub

wav dosyası çalma 4

ID : 2446
ISLEM : wav dosyası çalma 4
MAKRO KODU : Sub PlayIt() ExecuteExcel4Macro ("SOUND.PLAY(, ""C:\Windows\Media\Tada.wav"")") End Sub

wav dosyası çalma 5

ID : 2447
ISLEM : wav dosyası çalma 5
MAKRO KODU : Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Sub Klang() Call sndPlaySound32("D:\Programme\ICQ\Connect.wav", 0) End Sub

web sayfası açma

ID : 2448
ISLEM : web sayfası açma
MAKRO KODU : Public Sub gotoTMWebSite() On Error Resume Next ShellExecute 0&, vbNullString, "www.pirsa.com", vbNullString, _ vbNullString, vbNormalFocus On Error GoTo 0 End Sub

windows arama penceresi

ID : 2449
ISLEM : windows arama penceresi
MAKRO KODU : Option Explicit Private Declare Function ShellExecute Lib "shell32.dll" _ Alias "ShellExecuteA" ( _ ByVal hwnd As Long, _ ByVal lpOperation As String, _ ByVal lpFile As String, _ ByVal lpParameters As String, _ ByVal lpDirectory As String, _ ByVal nShowCmd As Long) As Long Private Const SW_SHOWNORMAL = 1 Sub FindAllFiles() Dim strPathToSearch As String strPathToSearch = "C:\" ShellExecute _ 0, _ "find", _ strPathToSearch, _ vbNullString, _ vbNullString, _ SW_SHOWNORMAL End Sub

windows help açma

ID : 2450
ISLEM : windows help açma
MAKRO KODU : Sub ShowVBEHelp() Shell "c:\windows\winhelp.exe veenob3.hlp", vbNormalFocus End Sub

windows kapatma penceresini çağırma

ID : 2451
ISLEM : windows kapatma penceresini çağırma
MAKRO KODU : Sub WinExit() 'marche bien sous XP With CreateObject("Shell.Application") .ShutdownWindows End With End Sub Sub ExitWindows9598() ValRetour = Shell("C:\WINDOWS\rundll32.exe user.exe,exitwindows") End Sub Sub RedemarWindows98() ValRetour = Shell("C:\WINDOWS\Rundll32.exe shell32,SHExitWindowsEx") End Sub

windowsu kapatma

ID : 2452
ISLEM : windowsu kapatma
MAKRO KODU : Declare Function ExitWindowsEx& Lib "user32" (ByVal uFlags&, ByVal wReserved&) Global Const EWX_FORCE = 8 Global Const EWX_LOGOFF = 0 Global Const EWX_REBOOT = 2 Global Const EWX_SHUTDOWN = 1 Sub Tschuess() Dim LResult LResult = ExitWindowsEx(EWX_SHUTDOWN, 0&) End Sub

wmi anakart

ID : 2453
ISLEM : wmi anakart
MAKRO KODU : Sub MotherBoardInfo() Dim strComputerName As String Dim strNameSpace As String Dim strClassName As String Dim objWMIMboard As Object Dim objWMIService As Object Dim objWMI_Mboards As Object Dim strRet As String strComputerName = "." strNameSpace = "root\cimv2" strClassName = "Win32_BaseBoard" On Error Resume Next If Err.Number 0 Then MsgBox "WMI yüklenmemiş! Programdan çıkılacak...", vbExclamation, _ "Windows Management Instrumentation" Exit Sub On Error GoTo 0 End If Set objWMIService = GetObject("winmgmts:\\" & strComputerName & _ "\" & strNameSpace) Set objWMI_Mboards = objWMIService.ExecQuery _ ("Select * from " & strClassName) For Each objWMIMboard In objWMI_Mboards strRet = "Üretici Firma = " & objWMIMboard.Manufacturer & vbCrLf strRet = strRet & "Seri Numarası = " & objWMIMboard.SerialNumber MsgBox strRet, vbInformation, "Ana Kart Bilgileri (Raider ®)" Next End Sub -

wmi bilgi

ID : 2454
ISLEM : wmi bilgi
MAKRO KODU : Sub InstalledProgsByMSI() Dim MyOBJ As Object Dim MyProg As Variant Dim MyMsg As String On Error Resume Next If Err.Number 0 Then MsgBox "WMI yüklenmemiş! Programdan çıkılacak...", vbExclamation, _ "Windows Management Instrumentation" Exit Sub On Error GoTo 0 End If strComputer = "." Set MyOBJ = GetObject("winmgmts:" _ & "{impersonationLevel=impersonate}!\\" _ & strComputer & "\root\cimv2") Set MSISoftware = MyOBJ.ExecQuery _ ("Select * from Win32_Product") MyMsg = MyMsg & "MSI ile yüklenen programlar hakkında:" & vbCrLf For Each MyProg In MSISoftware MyMsg = MyMsg & String(50, "-") & vbCrLf MyMsg = MyMsg & "Program: " & MyProg.Name & vbCrLf MyMsg = MyMsg & "Versiyon: " & MyProg.Version & vbCrLf MyMsg = MyMsg & "Üretici: " & MyProg.Vendor & vbCrLf MyMsg = MyMsg & "Kurulum: " & Left(MyProg.InstallDate, 4) & "/" & _ Mid(MyProg.InstallDate, 5, 2) & "/" & _ Mid(MyProg.InstallDate, 7, 2) & vbCrLf Next MsgBox MyMsg, vbInformation, "Programlar hakkında...... (Raider ®)" End Sub -

wmi bios

ID : 2455
ISLEM : wmi bios
MAKRO KODU : Sub InfoBIOS() Dim MyOBJ As Object Dim MyBios As Variant Dim MyMsg As String On Error Resume Next Set MyOBJ = GetObject("WinMgmts:").instancesOf _ ("Win32_Bios") If Err.Number 0 Then MsgBox "WMI yüklenmemiş! Programdan çıkılacak...", vbExclamation, _ "Windows Management Instrumentation" Exit Sub On Error GoTo 0 End If For Each MyBios In MyOBJ MyMsg = String(50, "-") & vbCrLf MyMsg = MyMsg & "Üretici Firma : " & MyBios.Manufacturer & vbCrLf MyMsg = MyMsg & "BIOS Seri Numarası : " & MyBios.SerialNumber & vbCrLf Next MsgBox MyMsg, vbInformation, "BIOS Bilgileri (Raider ®)" End Sub -

wmi ekran kartı

ID : 2456
ISLEM : wmi ekran kartı
MAKRO KODU : Sub InfoVideoController() Dim MyOBJ As Object Dim MyVideoController As Variant Dim MyMsg As String On Error Resume Next Set MyOBJ = GetObject("WinMgmts:").instancesOf _ ("Win32_VideoController") If Err.Number 0 Then MsgBox "WMI yüklenmemiş! Programdan çıkılacak...", vbExclamation, _ "Windows Management Instrumentation" Exit Sub On Error GoTo 0 End If For Each MyVideoController In MyOBJ MyMsg = MyMsg & "Ekran Kartı bilgileri :" & vbCrLf MyMsg = MyMsg & String(50, "-") & vbCrLf MyMsg = MyMsg & "Üretici Firma : " & MyVideoController.AdapterCompatibility & _ " (" & MyVideoController.Caption & ")" & vbCrLf MyMsg = MyMsg & "Yatay çözünürlük : " & MyVideoController.CurrentHorizontalResolution & vbCrLf MyMsg = MyMsg & "Dikey çözünürlük : " & MyVideoController.CurrentVerticalResolution & vbCrLf MyMsg = MyMsg & "Renk kalitesi : " & MyVideoController.CurrentBitsPerPixel & " bps" & vbCrLf MyMsg = MyMsg & "Video Modu : " & MyVideoController.VideoModeDescription & vbCrLf MyMsg = MyMsg & "İşlemci : " & MyVideoController.VideoProcessor & vbCrLf Next MsgBox MyMsg, vbInformation, "Ekran Kartı Bilgileri (Raider ®)" End Sub -

wmi mouse

ID : 2457
ISLEM : wmi mouse
MAKRO KODU : Sub InfoPointingDevices() Dim MyOBJ As Object Dim MyPtgDev As Variant Dim MyMsg As String On Error Resume Next Set MyOBJ = GetObject("WinMgmts:").instancesOf _ ("win32_pointingdevice") If Err.Number 0 Then MsgBox "WMI yüklenmemiş! Programdan çıkılacak...", vbExclamation, _ "Windows Management Instrumentation" Exit Sub On Error GoTo 0 End If For Each MyPtgDev In MyOBJ MyMsg = MyMsg & "*****************************" & vbCrLf MyMsg = MyMsg & "İşlemci : " & Trim(MyCPU.Name) & vbCrLf MyMsg = MyMsg & "Ad : " & MyPtgDev.Name & vbCrLf MyMsg = MyMsg & "Üretici : " & MyPtgDev.Manufacturer & vbCrLf MyMsg = MyMsg & "Buton adedi : " & MyPtgDev.NumberOfButtons & vbCrLf Next MsgBox MyMsg, vbInformation, "Mouse Bilgileri (Raider ®)" End Sub -

wmi network adaptörleri

ID : 2458
ISLEM : wmi network adaptörleri
MAKRO KODU : Sub InfoNetworkAdapter() Dim MyOBJ As Object Dim MyNetworkAdapter As Variant Dim MyMsg As String On Error Resume Next Set MyOBJ = GetObject("WinMgmts:").instancesOf _ ("Win32_NetworkAdapter") If Err.Number 0 Then MsgBox "WMI yüklenmemiş! Programdan çıkılacak...", vbExclamation, _ "Windows Management Instrumentation" Exit Sub End If MyMsg = MyMsg & "Network Adaptörleri hakkında:" & vbCrLf For Each MyNetworkAdapter In MyOBJ MyMsg = MyMsg & vbCrLf MyMsg = MyMsg & "Üretici Firma : " & MyNetworkAdapter.Manufacturer & vbCrLf MyMsg = MyMsg & "Adı : " & MyNetworkAdapter.Name & vbCrLf MyMsg = MyMsg & "Tip : " & MyNetworkAdapter.AdapterType & vbCrLf Next MsgBox MyMsg, vbInformation, "Network -

wmi sistem

ID : 2459
ISLEM : wmi sistem
MAKRO KODU : Sub SysInfo() Dim MyMsg As String, oSystem As Object, Item As Object Set oSystem = GetObject("winmgmts:").instancesOf("Win32_ComputerSystem") For Each Item In oSystem MyMsg = "Bilgisayar hakkında " & vbCrLf MyMsg = MyMsg & "-------------------------------" & vbCrLf MyMsg = MyMsg & "Ad: " & item.Name & vbCrLf MyMsg = MyMsg & "Tip: " & item.SystemType & vbCrLf MyMsg = MyMsg & "Üretici: " & item.Manufacturer & vbCrLf MyMsg = MyMsg & "Model: " & item.Model & vbCrLf MyMsg = MyMsg & "RAM: " & item.TotalPhysicalMemory \ 1024000 & " Mb" & vbCrLf MyMsg = MyMsg & "Domain: " & item.Domain & vbCrLf MyMsg = MyMsg & "Kayıtlı kullanıcı: " & item.UserName & vbCrLf MsgBox MyMsg, vbInformation, "Sistem Bilgileri...... (Raider ®)" Next Set oSystem = Nothing End Sub

wmi windows

ID : 2460
ISLEM : wmi windows
MAKRO KODU : Sub OS_Info() Dim strComputerName As String Dim strNameSpace As String Dim strClassName As String Dim OS As Object Dim objWMIService As Object Dim Osinf As Object Dim strManufacturer As String, strRegisteredUser As String, strSerialNumber As String Dim strVersionId As String, strVersionName As String strComputerName = "." strNameSpace = "root\cimv2" strClassName = "Win32_OperatingSystem" ' On Error Resume Next If Err.Number 0 Then MsgBox "WMI yüklenmemis! Programdan çikilacak...", vbExclamation, _ "Windows Management Instrumentation" Exit Sub On Error GoTo 0 End If Set objWMIService = GetObject("winmgmts:\\" & strComputerName & "\" & strNameSpace) Set Osinf = objWMIService.ExecQuery("Select * from " & strClassName) For Each OS In Osinf strManufacturer = "Üretici Firma = " & OS.Manufacturer & vbCrLf strRegisteredUser = "Kayitli Kullanici = " & OS.RegisteredUser & vbCrLf strSerialNumber = "Windows Seri Numarasi = " & OS.SerialNumber & vbCrLf strVersionId = "Windows Versiyonu ID = " & OS.Version & vbCrLf strVersionName = "Windows Versiyonu = " & OS.Name strServicePack = "Güncelleme = " & OS.CSDVersion & vbCrLf strVersionName = Mid(strVersionName, 1, InStr(1, strVersionName, "|") - 1) & vbCrLf strInstallDate = "Windows kurulum tarihi = " & Left(OS.InstallDate, 4) & "/" & Mid(OS.InstallDate, 5, 2) & "/" & Mid(OS.InstallDate, 7, 2) & vbCrLf MsgBox strManufacturer & strRegisteredUser & _ strSerialNumber & strVersionId & strVersionName & strServicePack & strInstallDate, _ vbInformation, "Windows Bilgileri (Raider ®)" Next End Sub -

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