Excel versiyon öğrenme makro kodu

Function fGetExcelVer() As Integer
If Application.Version Like "*5*" Then
fGetExcelVer = 5
ElseIf Application.Version Like "*7*" Then
fGetExcelVer = 7
Else
fGetExcelVer = 8
End If
End Function

Sub PerVersion()
MsgBox Application.Version
Select Case Left(Application.Version, 1)
Case "5"
MsgBox "TEBRİKLER Excel 5"
Case "7"
MsgBox "TEBRİKLER Excel 7/95"
Case "8"
MsgBox "TEBRİKLER Excel 8/97"
Case Else
MsgBox "TEBRİKLER Excel- Version"
End Select
ThisWorkbook.Activate
End Sub

Rastgele sayı üretimi 2

 D1 hücresine üretmek istediğiniz rakamların naximum değerini yazınız. D2 hücresine ise kaç adet sayı üreteceğinizi yazınız.

Sub rastgele()
  Dim i As Integer
  Dim bul As Range

  Randomize

  If Range("D1").Value < Range("D2") Then
    MsgBox "D1 hücresinin değeri D2 hücresinden küçük olmamalı"
    Exit Sub
  ElseIf Range("D1").Value = "" Or Range("D2") = "" Then
    MsgBox " D1 VE D2 hücrelerine bir değer giriniz"
    Exit Sub
  End If

  Cells(1, 1).Value = Int((Range("D1") * Rnd) + 1)
  For i = 2 To Range("D2")
    Cells(i, 1).Value = Int((Range("D1") * Rnd) + 1)
    For Each bul In Range("A1:A" & Cells(i - 1, 1).Row)
      If Cells(i, 1).Value = bul.Value Then
        Cells(i, 1).Value = Int((Range("D1") * Rnd) + 1)
      End If
    Next bul
  Next i
End Sub

Bir sütundaki boşlukları silen macro

Bu excel makrosu "A" sütunundaki değer içermeyen satırları bulur ve siler.

Sub bosluksil()
For a = 1 To Sheets.Count
satir= Sheets(a).Cells.SpecialCells(xlCellTypeLastCell).Row
sutun = Sheets(a).Cells.SpecialCells(xlCellTypeLastCell).Column
For b = satir To 1 Step -1
If WorksheetFunction.CountA(Sheets(a).Rows(b)) = 0 Then Sheets(a).Rows(b).Delete
Next
For c = sutun To 1 Step -1
If WorksheetFunction.CountA(Sheets(a).Columns(c)) = 0 Then Sheets(a).Columns(c).Delete
Next
Next
End Sub

istenilen hücreye istenilen yazı yazılınca makroyu çalıştıran kod

Bu excel makrosunda A sütununa "hoop" yazınca Test fonksiyonu çağrılıyor.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    If Target = "hoop" Then Call Test
End Sub
Sub Test()
    MsgBox "Biri Benimi Çağırdı:)", vbInformation
End Sub

İstenilen sıklıkta kitabı kaydetme makrosu EXCEL-VBA

Bu örnekte kaydetme süresi 10 dakikada birdir.


Sub auto_open()
Application.OnTime Now + TimeValue("00:10:00"), "Kayıt"
End Sub

Sub Kayıt()
ActiveWorkbook.Save
MsgBox "Kitap Kaydedildi"
Call auto_open
End Sub

Bir Listbox'tan başka bir Listbox'a veri taşıma

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

Excel macro ile yeni bir çalışma sayfası açma ve isim verme

Sub SayfaEkle()
    ThisWorkbook.Sheets.Add
    Sheets(ActiveSheet.Name).Name =sheets("sayfa_adi"). [a1].value
End Sub

Bilgisayarda yüklü yazıcı olup olmadığını kontrol eden excel makrosu

Private Sub UserForm_Activate()
On Local Error GoTo hata
Show
Print "kağıt kaynağı"; Printer.PaperBin
Print "renk modu"; Printer.ColorMode
Print "kopya sayısı"; Printer.Copies
Print "Yazıcının ismi"; Printer.DeviceName
Print "sürücü"; Printer.DriverName
Print "çift yönlü yazma"; Printer.Duplex
Print "yataylık-dikeylik"; Printer.Orientation
Print "sayfa boyutu"; Printer.PaperSize
Print "kullanılan port"; Printer.Port
Print "basım kalitesi"; Printer.PrintQuality
Print "yazıcı varsayılan mı"; Printer.TrackDefault
Print "ölçekleme"; Printer.Zoom
hata:
MsgBox ("yüklü bir yazıcı yok veya yazınız açık değil")
End Sub