Tek Mail adresine e-posta gönderme:
Sub Mail_gonderme()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "muhammedyusufolgun@yenimail.com"
.cc = ""
.Subject = "Test1"
.send
End With
MsgBox "E-Mail gonderilmistir.", vbInformation, Application.UserName
End Sub
Buton eklenip, makro ataması yapıldı.
Excel listesine (Mail adres, Konu, Açıklama) tablo bilgisine göre, e-posta gönderme:
Sub Mail_Gonder()
Dim Outlook As Object, yeni As Object, i As Long
Set Outlook = CreateObject("Outlook.Application")
For i = 2 To Cells(Rows.Count, "B").End(3).Row
Set yeni = Outlook.CreateItem(0)
With yeni
.To = Range("C" & i).Value
.Subject = Range("D" & i).Value
.Body = Range("E" & i).Value
.Display
.Send
End With
Next i
Set Outlook = Nothing: Set yeni = Nothing: i = Empty
MsgBox "E-Mailleriniz gonderilmistir.", vbInformation, Application.UserName
End Sub
Buton eklenip, makro ataması yapıldı. "B" Sütunu, sadece bilgi amaçlıdır. (C, D, E) Sütunları üzerinde işlem gerçekleşmektedir. 2. Hücreler, başlangıç kabul ederek çalışmaktadır.
Kod yapısı:
Mail gönderimi sonrası, seri e-posta alımı gerçekleşti.
Excel listesine (Mail adres, Konu, Açıklama) tablo bilgisine göre, Ek dosya ile e-posta gönderme:
Sub Mail_Gonder_Ek()
Dim Outlook As Object, yeni As Object, i As Long
Set Outlook = CreateObject("Outlook.Application")
For i = 2 To Cells(Rows.Count, "B").End(3).Row
Set yeni = Outlook.CreateItem(0)
With yeni
.To = Range("C" & i).Value
.Subject = Range("D" & i).Value
.Attachments.Add ("C:\ek\icon.jpg")
.Body = Range("E" & i).Value
.Display
.Send
End With
Next i
Set Outlook = Nothing: Set yeni = Nothing: i = Empty
MsgBox "E-Mailleriniz gonderilmistir.", vbInformation, Application.UserName
End Sub
Buton eklenip, makro ataması yapıldı. "B" Sütunu, sadece bilgi amaçlıdır. (C, D, E) Sütunları üzerinde işlem gerçekleşmektedir. 2. Hücreler, başlangıç kabul ederek çalışmaktadır. Attachments.Add ("C:\ek\icon.jpg") satırı ile ilgili konumdaki dosyayı maile ek yapar.
Kod yapısı:
Excel dosyasındaki Sayfa adlarını görüntülemek için makro oluşturulması:
Sub SayfaSayisi()
Dim Item As Worksheet
For Each Item In ActiveWorkbook.Worksheets
MsgBox Item.Name
Next Item
End Sub
Kod yapısı:
Makroda "For" satırından başlayan döngü "Next" satırı ile tamamlanır. Her döngü sonunda Mesaj penceresi açılarak sayfa adını görüntüler. "Tamam" butonuna basıldığında, döngü ikinci defa çalışır, bir sonraki sayfa adını görüntüler. (Sayfa adeti kadar döngü çalışır) Sayfa adeti tamamlanınca, kod sonlanır.
Hücre içeriğini (Küçük) harfe dönüştür. (LCase):
Seçilen hücreler sonrası makro çalıştığında, seçili alandaki değerler küçük harfe dönüşür.
Dönüşüm gerçekleşerek, seçili hücreler küçük harf oldu.
Hücre içeriğini (BÜYÜK) harfe dönüştür. (UCase):
Seçilen hücreler sonrası makro çalıştığında, seçili alandaki değerler BÜYÜK harfe dönüşür.
Kodun çalıştığı sayfa hariç, Tüm Excel sayfalarını kapatır.
Sub Sayfa_Kapat()
Dim Book As Workbook
For Each Book In Workbooks
If Book.Name <> ActiveWorkbook.Name Then Book.Close
Next Book
End Sub
İçinde bulunduğumuz Ay'ın günlerini yaz.
Sub Tarih_Yaz()
Dim TheDate As Date
TheDate = DateSerial(Year(Date), Month(Date), 1)
Do While Month(TheDate) = Month(Date)
ActiveCell = TheDate
TheDate = TheDate + 1
ActiveCell.Offset(1, 0).Activate
Loop
End Sub
Do-While Döngüsü 1:
Belli bir koşul oluştuğunda işlemlerin başlamasını ve sonlanmasını sağlamak için kullanılır.
Örnek: İçinde bulunduğumuz ay'ın tarihlerini excelde aktif hücreden itibaren aşağıya doğru yazan makrodur.
"TheDate" değişkeni, "DateSerial" ile güncel tarihi hesaplar. "Do While" satırındaki koşul geçerli olduğu sürece, "DoWhile-Loop" arasındaki odlar çalışacaktır.
Döngü içindeki, "TheDate" sayacının (1) arttırılması sayesinde ilgili ay'ın son gününe ulaşıldığında, döngü sonlanacaktır.
"ActiveCell = TheDate" satırı her aşamada hesaplanan tarihi Excel hücresine yazar.
"Offset" satırı ise, bir alttaki hücrenin seçilmesini sağlar.
Kod yapısı:
Do-While Döngüsü 2:
Örnek2: Koşula bağlı olmaksızın Aktif hücreye Ay'ın ilk gününü yazdırmak için; koşulu "Do" satırında değil "Loop" satırında vermek gerekir. Böylelikle "Doo-Loop" arasındaki satırlar en az birkez koşula bağlı olmaksızın çalışacak ve daha sonra "Loop" satırındaki koşul kontrol edilecektir.
Aktif hücreyi Ay'ın birinci günü yazıldıktan sonra, "ThaDate" değişken değeri arttırılarak "Loop" satırındaki koşul kontrol edilecektir. Koşul halen geçerliyse, döngü bir tur daha çalışacaktır.
Text dosya formatında metin belgesini satır satır excele yazan makro:
Sub Metin_dosyasini_excele_aktar
Dim LineCt as Long
Dim LineOfText As String
'Verilen adresteki dosya açılır.
Open "c:\dosya\metin.txt" For Input As #1
'Dosyanın ilk satırı seçilir
LineCt = 0
'Do While döngüsü dosyanın her satırını tarar bittiğinde döngü sonlanır.
Do While Not EOF(1)
'Dosyanın sıradaki satırı LineOfText değişkenine aktarılır
Line Input #1, LineOfText
'LineOfText değeri A sütununda sıradaki hücreye yazılır.
Range ("A1").Offset(LineCt, 0) = Ucase(LineOfText)
'Sonraki Excel satırı
LineCt = LineCt + 1
'Dosyadan sonraki satır okunur
Loop
'Dosya kapatılır
Close #1
End Sub
Kod çalıştıktan sonra, (Kod dizini, txt dosyası olarak gösterildi) Excele aktarımı:
Günün saatine göre Gün=(0-1) Selamlama:
Sub Zamana_gore_selamlama()
If Time < 0.5 Then
MsgBox "Gunaydın"
ElseIf Time >= 0.5 And Time < 0.75 Then
MsgBox "iyi Oglenler"
Else
MsgBox "İyi Aksamlar!"
End If
End Sub
Kod yapısı:
Çıktı:
Belirtilen sayıda Sıralı rakam yazdırma (1-10):
Sub SayiYazdir()
'3 Adet değişken taımlanır.
Dim StarVal As Integer
Dim NumToFill As Integer
Dim Cnt As Integer
'Başlangıç değeri
StarVal = 1
'Bitiş değeri
NumToFill = 10
'Kaç defa çalışmasını belirten döngü
For Cnt = 0 To NumToFill - 1
ActiveCell.Offset(Cnt, 0).Value = StarVal + Cnt
Next Cnt
End Sub
Belirtilen sayıda Sıralı rakam yazdırma (1-100):
Sub SayiYazdir()
'3 Adet değişken taımlanır.
Dim StarVal As Integer
Dim NumToFill As Integer
Dim Cnt As Integer
'Başlangıç değeri
StarVal = 1
'Bitiş değeri
NumToFill = 100
'Kaç defa çalışmasını belirten döngü
For Cnt = 0 To NumToFill - 1
ActiveCell.Offset(Cnt, 0).Value = StarVal + Cnt
Next Cnt
End Sub
İşlem Sonucu:
Sayıyı Metne çevirme (Fonksiyon):
Kodu kopyala, Excel (.xlsm) makso dosyasında "Alt+F11" ile VB Aç. Menü (Inser/Module) Aç. kodu yapıştır kaydet. Fonksiyon olduğu için makrolarda görünmez, "View/Project Explorer" başlığında "Modules" Alt başlıklarında görünür. Kullanırken "=yaz(Hücre)" yeterli.
Kod:
Function yaz$(sayi)
Dim b$(9)
Dim y$(9)
Dim m$(4)
Dim v(15)
Dim c(3)
b$(0) = ""
b$(1) = "Bir"
b$(2) = "İki"
b$(3) = "Üç"
b$(4) = "Dört"
b$(5) = "Beş"
b$(6) = "Altı"
b$(7) = "Yedi"
b$(8) = "Sekiz"
b$(9) = "Dokuz"
y$(0) = ""
y$(1) = "On"
y$(2) = "Yirmi"
y$(3) = "Otuz"
y$(4) = "Kırk"
y$(5) = "Elli"
y$(6) = "Altmış"
y$(7) = "Yetmiş"
y$(8) = "Seksen"
y$(9) = "Doksan"
m$(0) = "Trilyon "
m$(1) = "Milyar "
m$(2) = "Milyon "
m$(3) = "Bin "
m$(4) = ""
'https://muhammedyusufolgun.blogspot.com
a$ = Str(sayi)
If Left$(a$, 1) = " " Then pozitif = 1 Else pozitif = 0
a$ = Right$(a$, Len(a$) - 1)
For x = 1 To Len(a$)
If (Asc(Mid$(a$, x, 1)) > Asc("9")) Or (Asc(Mid$(a$, x, 1)) < Asc("0")) Then GoTo hata
Next x
If Len(a$) > 15 Then GoTo hata
a$ = String(15 - Len(a$), "0") + a$
For x = 1 To 15
v(x) = Val(Mid$(a$, x, 1))
Next x
s$ = ""
For x = 0 To 4
c(1) = v((x * 3) + 1)
c(2) = v((x * 3) + 2)
c(3) = v((x * 3) + 3)
If c(1) = 0 Then
e$ = ""
ElseIf c(1) = 1 Then
e$ = "Yüz"
Else
e$ = b$(c(1)) + "Yüz"
End If
e$ = e$ + y$(c(2)) + b$(c(3))
If e$ <> "" Then e$ = e$ + m$(x)
If (x = 3) And (e$ = "BirBin ") Then e$ = "Bin"
s$ = s$ + e$
Next x
If s$ = "" Then s$ = "Boş hücre"
If pozitif = 0 Then s$ = "Eksi" + s$
yaz$ = s$
GoTo tamam
hata: yaz$ = "Hata"
tamam:
End Function
Kodu yapıştırma
Kodun Metin halini indirmek için Tıklayın.