(97) Excel, G:G Sütun aralığında; Hücre rengi "#FF0000" Kırmızı (255, 0, 0) olanları say sonucu "J1" hücresine, Hücre rengi "#FFFF" Sarı (255, 255, 0) olanları say sonucu "K1" hücresine ve Hücre rengi "#92D050" Yeşil (146, 208, 80) olanları say sonucu "L1" hücresine yaz.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Adım 1: Sadece G sütunundaki bir hücre seçildiğinde devam et (G = 7)
' If Target.Column <> 7 Then Exit Sub
Dim sayfa As Worksheet
Set sayfa = ActiveSheet
' G sütunundaki son dolu satırı bul (Performans Optimizasyonu)
Dim sonSatir As Long
sonSatir = sayfa.Cells(sayfa.Rows.Count, "G").End(xlUp).Row
' Eğer G sütununda hiç veri yoksa, sayım yapmadan çık
If sonSatir < 1 Then
sayfa.Range("J1").Value = 0
sayfa.Range("K1").Value = 0
sayfa.Range("L1").Value = 0 ' Yeşil sayısını da sıfırla
Exit Sub
End If
' Renk kodları
Dim kirmiziRenkKodu As Long
Dim sariRenkKodu As Long
Dim yesilRenkKodu As Long ' Yeni Yeşil renk kodu
' Sayıcılar
Dim kirmiziSayac As Long
Dim sariSayac As Long
Dim yesilSayac As Long ' Yeni Yeşil sayacı
' RGB Tanımlamaları
kirmiziRenkKodu = RGB(255, 0, 0) ' Kırmızı
sariRenkKodu = RGB(255, 255, 0) ' Sarı
yesilRenkKodu = RGB(146, 208, 80) ' Yeşil (İstenen kod)
kirmiziSayac = 0
sariSayac = 0
yesilSayac = 0
Dim hucre As Range
' Adım 2: Döngüyü sadece kullanılan G1:G[sonSatir] aralığında çalıştır
For Each hucre In sayfa.Range("G1:G" & sonSatir)
' Hücrenin arka plan rengini kontrol et
' Kırmızı hücre kontrolü
If hucre.Interior.Color = kirmiziRenkKodu Then
kirmiziSayac = kirmiziSayac + 1
' Sarı hücre kontrolü
ElseIf hucre.Interior.Color = sariRenkKodu Then
sariSayac = sariSayac + 1
' Yeşil hücre kontrolü (Yeni)
ElseIf hucre.Interior.Color = yesilRenkKodu Then
yesilSayac = yesilSayac + 1
End If
Next hucre
' Adım 3: Sonuçları ilgili hücrelere yaz
sayfa.Range("J1").Value = kirmiziSayac ' Kırmızı sayısını J1'e yazar
sayfa.Range("K1").Value = sariSayac ' Sarı sayısını K1'e yazar
sayfa.Range("L1").Value = yesilSayac ' Yeşil sayısını L1'e yazar
End Sub
(96) Excel, G:G Sütun aralığında; Hücre rengi "#FF0000" Kırmızı (255, 0, 0) olanları say sonucu "J1" hücresine ve Hücre rengi "#FFFF" Sarı (255, 255, 0) olanları say sonucu "K1" hücresine yaz.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Adım 1: Sadece G sütunundaki bir hücre seçildiğinde devam et (G = 7)
' If Target.Column <> 7 Then Exit Sub
Dim sayfa As Worksheet
Set sayfa = ActiveSheet
' G sütunundaki son dolu satırı bul (Performans Optimizasyonu)
Dim sonSatir As Long
' xlUp: En alt satırdan yukarı doğru giderek ilk dolu satırı bulur.
sonSatir = sayfa.Cells(sayfa.Rows.Count, "G").End(xlUp).Row
' Eğer G sütununda hiç veri yoksa, sayım yapmadan çık
If sonSatir < 1 Then
sayfa.Range("J1").Value = 0
sayfa.Range("K1").Value = 0
Exit Sub
End If
' Renk kodları
Dim kirmiziRenkKodu As Long
Dim sariRenkKodu As Long
' Sayıcılar
Dim kirmiziSayac As Long
Dim sariSayac As Long
' RGB Tanımlamaları
kirmiziRenkKodu = RGB(255, 0, 0) ' Kırmızı
sariRenkKodu = RGB(255, 255, 0) ' Sarı
kirmiziSayac = 0
sariSayac = 0
Dim hucre As Range
' Adım 2: Döngüyü sadece kullanılan G1:G[sonSatir] aralığında çalıştır
For Each hucre In sayfa.Range("G1:G" & sonSatir)
' Hücrenin arka plan rengini kontrol et
' Kırmızı hücre kontrolü
If hucre.Interior.Color = kirmiziRenkKodu Then
kirmiziSayac = kirmiziSayac + 1
' Sarı hücre kontrolü
ElseIf hucre.Interior.Color = sariRenkKodu Then
sariSayac = sariSayac + 1
End If
Next hucre
' Adım 3: Sonuçları ilgili hücrelere yaz
sayfa.Range("J1").Value = kirmiziSayac ' Kırmızı sayısını J1'e yazar
sayfa.Range("K1").Value = sariSayac ' Sarı sayısını K1'e yazar
End Sub
(95) Excel, Hücre rengi "#FF0000" (255, 0, 0) Kırmızı olanları (G:G Sütun aralığında) say sonucu "J1" hücresine yaz.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Adım 1: Sadece G sütunundaki bir hücre seçildiğinde devam et (G = 7)
' If Target.Column <> 7 Then Exit Sub
Dim sayfa As Worksheet
Set sayfa = ActiveSheet
' G sütunundaki son dolu satırı bul (Performans Optimizasyonu)
Dim sonSatir As Long
sonSatir = sayfa.Cells(sayfa.Rows.Count, "G").End(xlUp).Row
' Eğer G sütununda hiç veri yoksa, sayım yapmadan çık
If sonSatir < 1 Then
sayfa.Range("J1").Value = 0
Exit Sub
End If
' Renk kodu
Dim kirmiziRenkKodu As Long
' Sayıcı
Dim kirmiziSayac As Long
' RGB Tanımlaması
kirmiziRenkKodu = RGB(255, 0, 0) ' Kırmızı
kirmiziSayac = 0
Dim hucre As Range
' Adım 2: Döngüyü sadece kullanılan G1:G[sonSatir] aralığında çalıştır
For Each hucre In sayfa.Range("G1:G" & sonSatir)
' Hücrenin arka plan rengi kırmızı ise say
If hucre.Interior.Color = kirmiziRenkKodu Then
kirmiziSayac = kirmiziSayac + 1
End If
Next hucre
' Adım 3: Sonucu J1 hücresine yaz
sayfa.Range("J1").Value = kirmiziSayac ' Kırmızı sayısını J1'e yazar
End Sub
(94) Excel, Hücre rengi "#FF0000" (255, 0, 0) Kırmızı olanları (sayfanın tamamında) say sonucu "J1" hücresine yaz.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sayfa As Worksheet
Dim hucre As Range
Dim renkKodu As Long
Dim sayac As Long
Set sayfa = ActiveSheet
renkKodu = RGB(255, 0, 0)
sayac = 0
For Each hucre In sayfa.UsedRange
If hucre.Interior.Color = renkKodu Then
sayac = sayac + 1
End If
Next hucre
sayfa.Range("J1").Value = sayac
End Sub
(93) Excel, (Resim bağlama)
'=İNDİS('Personel'!D:D;KAÇINCI(D56;'Personel'!A:A;0))
(92) Excel, belirlenen aralıklardaki saatleri topla.
Formül, (A1:A42) aralığındaki tüm saat değerlerini toplar ve bu toplam süreyi geleneksel saat: dakika metnine çevirir.
=TAMSAYI(TOPLA(A1:A42)*24) & ":" & METNEÇEVİR(MOD(TOPLA(A1:A42)*24; 1)*60;"00")
(91) Excel, belirlenen aralıklardaki saatleri topla.
24 saati aşan saat toplamada, sıfırlamadan, değer kaybı olmadan; (Her isim için ayrı ayrı yapmak gerekiyor) "A" sütununda, ismi "Muhammed Yusuf OLGUN" olan isimleri bul, "F" sütununda bulunan satırlarda yer alan saatleri topla, sonucu formülün girildiği hücreye yaz) (toplanan süreyi alıp, sonucu geleneksel saat ve dakika metni olarak biçimlendirir)
=TAMSAYI(ÇOKETOPLA(F:F;A:A;"Muhammed Yusuf OLGUN")*24) & ":" & METNEÇEVİR(MOD(ÇOKETOPLA(F:F;A:A;"Muhammed Yusuf OLGUN")*24; 1)*60;"00")
(90) Excel, ("B13:B54, a1") aralığındaki değerlerin hangisine tıklanırsa, sonucu (D56) hücresine yaz. (Resim bağlama)
'Sayfa bir de satırları kalın yap makrosu altına ekle.
' Sadece tek bir hücre seçildiğinde ve bu hücre B13:B54 aralığındaysa çalışır.
If Target.CountLarge = 1 And Not Intersect(Target, Range("B13:B54,a1")) Is Nothing Then
' D56 hücresine, seçilen hücrenin adresini (=A1 formatında) yaz.
' .Address(False, False) ile $ işaretleri olmadan adresi alırız.
Range("D56").Value = "=" & Target.Address(False, False)
Else
' İsteğe bağlı: Eğer B13:B42 aralığı dışında bir hücre seçilirse I55 hücresini temizle
Range("D56").ClearContents
End If
End Sub
(89) Excel, Filtrelenen ilk değeri, istenilen hücreye yaz. (Resim bağlama)
Private Sub Worksheet_Calculate()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim rngFiltreliHücreler As Range
Dim rngIlkGorunurHücre As Range
Dim vDeger As Variant
On Error GoTo HataYakala
' Filtrelenmiş aralık D24:D650 olarak belirlenir.
Set rngFiltreliHücreler = Me.Range("D24:D650")
Set rngIlkGorunurHücre = Nothing
Set rngIlkGorunurHücre = rngFiltreliHücreler.SpecialCells(xlCellTypeVisible)
If Not rngIlkGorunurHücre Is Nothing Then
' İlk görünür hücrenin değerini değişkene al
vDeger = rngIlkGorunurHücre.Cells(1, 1).Value
' **KONTROL NOKTASI:** Eğer değer **boş değilse** (hakkındaki isteğiniz buydu)
If vDeger <> "" Then
' F14 hücresine değeri ata
Me.Range("F14").Value = vDeger
' Eğer değer boşsa, burası atlanır ve F14'ün değeri korunur.
End If
End If
HataCikis:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
HataYakala:
Resume HataCikis
End Sub
(88) Excel, İsme resim bağlama işlemi
Resmin yerini bul
=KAÇINCI(F14;Resim!B:B;0)
'(F14 hücresindeki değer, Resim sayfasında isim eşleşmesi kaçıncı ve tam eşleşme)
' ilk formülde hücrenin bulunduğu sırano bilgisi alınır. Ör:4
'ikinci formülde, sıra numaraya karşılık gelen, eşleşme bilgisi alınır. Sonuç "0" olunca tamam.
=İNDİS(Resim!D:D;
'formülün başına ekle, (Resmin olduğu sütun) ve sonuna "0" ekleyerek parantezi kapat)
Son hali:
=İNDİS(Resim!D:D;KAÇINCI(F14;Resim!B:B;0);0)
=İNDİS(Resim!$D:$D;KAÇINCI($F$14;Resim!$B:$B;0);0)
'=İNDİS(Resim!$D:$D;KAÇINCI($F$14;Resim!$B:$B;0);0) formül sabitleme
' Formüller sekmesi /Ad yöneticisi/ Yeni
' "resim" ismini gir. formülü yapıştır.
'resmi olan bir isim gir
'resimli hücreyi kopyala, Özel yapıştır, bağlı resim
'bağlı resme tıkla formül kısmına "resim" gir enter tuşuna bas
(87) Excel, 'Texbox1 içinde Sayfa2'de "B2:B1000" kelime ara, Sonucu Sayfa1'de B6 dan başlayarak ver.
Me.TextBox1.Font.Size = 18
Application.EnableAutoComplete = False
Dim aramaKriteri As String
Dim aramaMetni As String
Dim kaynakSayfa As Worksheet
Dim kaynakAralik As Range
Dim hucre As Range
Dim sonSatirSonuc As Long
Dim eslesenSayisi As Long
Dim tekHarfModu As Boolean
Dim hedefSayfa As Worksheet
Set hedefSayfa = ThisWorkbook.Sheets("Sayfa1")
Set kaynakSayfa = ThisWorkbook.Sheets("Sayfa2")
Set kaynakAralik = kaynakSayfa.Range("B2:B1000")
sonSatirSonuc = hedefSayfa.Cells(hedefSayfa.Rows.Count, "B").End(xlUp).Row
If sonSatirSonuc < 6 Then sonSatirSonuc = 6 ' En az B6'yı koru
hedefSayfa.Range("B6:B" & sonSatirSonuc).ClearContents
eslesenSayisi = 0
aramaMetni = Trim(Me.TextBox1.Value)
If aramaMetni = "" Then
Exit Sub
End If
tekHarfModu = (Len(aramaMetni) = 1)
aramaKriteri = LCase(aramaMetni)
aramaKriteri = Replace(aramaKriteri, "İ", "i")
aramaKriteri = Replace(aramaKriteri, "I", "ı")
aramaKriteri = Replace(aramaKriteri, "Ş", "ş")
aramaKriteri = Replace(aramaKriteri, "Ç", "ç")
aramaKriteri = Replace(aramaKriteri, "Ğ", "ğ")
aramaKriteri = Replace(aramaKriteri, "Ö", "ö")
aramaKriteri = Replace(aramaKriteri, "Ü", "ü")
For Each hucre In kaynakAralik.Cells
If hucre.Value <> "" Then
Dim kaynakDeger As String
kaynakDeger = CStr(hucre.Value)
kaynakDeger = Replace(kaynakDeger, "İ", "i")
kaynakDeger = Replace(kaynakDeger, "I", "ı")
kaynakDeger = Replace(kaynakDeger, "Ş", "ş")
kaynakDeger = Replace(kaynakDeger, "Ç", "ç")
kaynakDeger = Replace(kaynakDeger, "Ğ", "ğ")
kaynakDeger = Replace(kaynakDeger, "Ö", "ö")
kaynakDeger = Replace(kaynakDeger, "Ü", "ü")
kaynakDeger = LCase(kaynakDeger)
Dim eslesmeVar As Boolean
eslesmeVar = False
If tekHarfModu Then
If Left(kaynakDeger, 1) = aramaKriteri Then
eslesmeVar = True
End If
Else
If Left(kaynakDeger, Len(aramaKriteri)) = aramaKriteri Then
eslesmeVar = True
ElseIf InStr(1, " " & kaynakDeger, " " & aramaKriteri) > 0 Then
eslesmeVar = True
End If
End If
If eslesmeVar Then
eslesenSayisi = eslesenSayisi + 1
hedefSayfa.Range("B" & 5 + eslesenSayisi).Value = hucre.Value
End If
End If
Next hucre
End Sub
(86) Excel, Pratik
'‘----------------------------------------
‘---Çalışma Kitabı’na yapıştır---
‘----------------------------------------
‘=====Sunum modu olarak tasarlanan ayarlar=====
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"", False)"
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
Application.DisplayFormulaBar = False
Range("A1").Select
‘-----Açılışta yüzde 100 olarak ayarlama-----
ActiveWindow.Zoom = 100
Range("A1").Select
End Sub
‘---------------------------------------------------
‘---Sayfa 1, Çalışma sayfasına yapıştır---
‘--------------------------------------------------
' --Satırları büyük ve kalın yapma--
'--------------------------------------------------------------------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
' Tıklanan Satır kalın ve büyük olsun
'
Const ANA_ARALIK As String = "B24:I1000" ' ARALIK GÜNCELLENDİ
Const BUYUK_BOYUT As Long = 11
Const KUCUK_BOYUT As Long = 11
On Error GoTo HataYakala
Application.EnableEvents = False
' A1'e tıklandığında tüm ANA_ARALIK'ı küçük boyuta ve normal (kalınsız) yap.
If Target.Address(False, False) = "A1" Then
With Me.Range(ANA_ARALIK).Font
.Size = KUCUK_BOYUT
.Bold = False ' Tüm aralığı kalın yapma özelliğini kaldır.
End With
GoTo HataYakala
End If
' Ana aralık dışında bir yere tıklandıysa çık.
If Intersect(Target, Me.Range(ANA_ARALIK)) Is Nothing Then GoTo HataYakala
' Tek bir hücre seç.
If Target.Cells.CountLarge > 1 Then Set Target = Target.Cells(1, 1)
' Önce tüm aralığı küçült ve kalınsız yap.
With Me.Range(ANA_ARALIK).Font
.Size = KUCUK_BOYUT
.Bold = False ' Önceki kalın ayarını kaldır.
End With
' Sonra seçili satırı (B sütunundan N sütununa kadar) büyüt VE kalın (Bold = True) yap.
With Me.Range("B" & Target.Row & ":I" & Target.Row).Font ' N SÜTUNU BURADA GÜNCELLENDİ
.Size = BUYUK_BOYUT
.Bold = True ' Tıklanan satırı kalın yap.
End With
HataYakala:
Application.EnableEvents = True
End Sub
‘=====Filtre Kaldır butonu=====
‘-----Filtre kaldır butonuna birden fazla görev yerine getirmesi için alt komutlar da bir arada-----
‘-----Filtre kaldır butonuna basılınca, dilimleme filtrelerini kaldırır-----
Sub FiltreKaldır()
Dim ws As Worksheet
Dim tbl As ListObject
Set ws = ActiveSheet
Set tbl = ws.ListObjects(1)
If tbl.AutoFilter.FilterMode Then
tbl.AutoFilter.ShowAllData
End If
Range("A1").Select
‘-----“CommandButton1” Activex butonu basma işlemi-----
‘-----Aşağıdaki kod ile gerçekleşir.-----
‘-----Bu buton. “Filtre kaldır” butonu altına gizlenir.-----
Call CommandButton1_Click
‘-----Yukarıdaki buton1 çalıştığında silinen renkli hücre sayısının güncel-----
‘-----“0” dönüşmüş değerini almak için, Renkli hücre sayısını bulma kodu-----
‘-----Bu sayfada iki defa kullanılır. Aşağıda, “Filtre kaldıre içine konulan ikincisi-----
'Sub RenkliHucreSayisiBul()
Dim sayfa As Worksheet
Dim hucre As Range
Dim renkKodu As Long
Dim sayac As Long
Set sayfa = ActiveSheet
' Aradığımız rengin RGB kodu
' RGB(144, 238, 144) = Açık yeşil tonu
renkKodu = RGB(144, 238, 144)
' Sayacı sıfırla
sayac = 0
' Sayfa üzerindeki kullanılan tüm hücreleri döngüye al
For Each hucre In sayfa.UsedRange
' Hücrenin dolgu rengi (Interior.Color) aradığımız renkle eşleşiyor mu kontrol et
If hucre.Interior.Color = renkKodu Then
' Eşleşiyorsa sayacı bir artır
sayac = sayac + 1
End If
Next hucre
' Sonucu X5 hücresine yaz
sayfa.Range("X5").Value = sayac
‘ -----Satırları filtre işleminde oluşacak düzensizlikleri gidermek için-----
‘-----Veri Sırala, Hücreleri istediğimiz öncelik sırasına göre A-Z dizip makro kaydı alınır-----
‘-----Ayrı bir makro kaydederek elde edeceğimiz kodu bu alana yapıştırırız-----
' sirala Makro
Range("Tablo2[[#Headers],[Klasör]]").Select
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add Key:=Range("Tablo2[Klasör]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add Key:=Range("Tablo2[Kamera Adı]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add Key:=Range("Tablo2[Model]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add Key:=Range("Tablo2[Seri No]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add Key:=Range("Tablo2[MAC Adres]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add Key:=Range("Tablo2[IP]"), SortOn:=xlSortOnValues, Order:=xlAscending _
, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add Key:=Range("Tablo2[Yazılım Sürümü]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add Key:=Range("Tablo2[Not 1]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add Key:=Range("Tablo2[Not 2]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
End Sub
' -----Arama Texbox kelime silme ve Renk Temizle Makrosu----
' -----Arama Texbox kelime temizleme (Buton1, ancak Activex olmalı)-----
‘-----(Aşağıdaki kod butona çift tıklayınca açılacak alana kopyalanmalı)-----
Private Sub CommandButton1_Click()
TextBox1.Value = ""
' -----Arama sonucu, Renk Temizle-----
' Tüm sütunlar ve aşağısı (Shift SağOk ve AşağıOk) seçilerek renk temizliği-----
Range("B24:J24").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'-----SatirYuksekligiAyarla (Shift SağOk ve AşağıOk) seçilerek-----
Rows("24:24").Select
Range(Selection, Selection.End(xlDown)).Select
Rows("24:655").EntireRow.AutoFit
Range("A1").Select
End Sub
' -----“RENK Filtre” Makrosu---- (Yeşil renk)
' RENK Filtre butonuna bağlanacak kod (Buton2, ancak Activex olmalı)
' -----Arama Texbox kelime temizleme-----
‘-----(Aşağıdaki kod butona çift tıklayınca açılacak alana kopyalanmalı)-----
‘----- RENK Filre butonuna bağlanacak kod (Buton1 de olabilir, ancak Activex olmalı)
‘-----Hucreler_Sirala Makro (Bu Alanı ayriyeten makro kaydı yaparak alıp eklemeli.
‘-----Tüm hücrelerde aranan değeri ortak yazıp arama ile renklendirdikten sonra,
‘-----makro kaydı açıp tüm hücreleri renge göre sırala seçmeli,
‘-----sonra makro durdurup oluşan kodu aşağıya yapıştırmalı.
Private Sub CommandButton2_Click()
Range("Tablo2[[#Headers],[Klasör]]").Select
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add(Range("Tablo2[Klasör]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(144, 238, 144)
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add(Range("Tablo2[Kamera Adı]"), xlSortOnCellColor, xlAscending, , xlSortNormal _
).SortOnValue.Color = RGB(144, 238, 144)
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add(Range("Tablo2[Model]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(144, 238, 144)
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add(Range("Tablo2[Seri No]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(144, 238, 144)
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add(Range("Tablo2[MAC Adres]"), xlSortOnCellColor, xlAscending, , xlSortNormal) _
SortOnValue.Color = RGB(144, 238, 144)
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add(Range("Tablo2[IP]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(144, 238, 144)
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add(Range("Tablo2[Yazılım Sürümü]"), xlSortOnCellColor, xlAscending, , _
xlSortNormal).SortOnValue.Color = RGB(144, 238, 144)
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add(Range("Tablo2[Not 1]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(144, 238, 144)
ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort.SortFields. _
Add(Range("Tablo2[Not 2]"), xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(144, 238, 144)
With ActiveWorkbook.Worksheets("Dashboard").ListObjects("Tablo2").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
‘-----Renkli hücre (Yeşil) sayısını bulma işlemi-----
‘-----Bu kodun birinci kullanım yeri de burası-----
'Sub RenkliHucreSayisiBul()
Dim sayfa As Worksheet
Dim hucre As Range
Dim renkKodu As Long
Dim sayac As Long
Set sayfa = ActiveSheet
' Aradığımız rengin RGB kodu, RGB(144, 238, 144) = Açık yeşil tonu
renkKodu = RGB(144, 238, 144)
sayac = 0
For Each hucre In sayfa.UsedRange
If hucre.Interior.Color = renkKodu Then
sayac = sayac + 1
End If
Next hucre
' Sonucu X5 hücresine yaz, =X5 ile istediğimiz hücreye kopyasını yazdırırız.
sayfa.Range("X5").Value = sayac
Range("A1").Select
End Sub
‘-----Texbox içinde, kelime yazdıktan sonra "Enter" basma sonrası arama yapma, Büyük küçük harf uyumlu-----
‘-----(Aşağıdaki kodu, Texbox çift tıklayınca açılan koda yapıştır-----
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
' Sadece ENTER tuşuna (KeyCode = 13) basıldığında arama işlemini yap.
If KeyCode = 13 Then
Dim aralik As Range
Dim hucre As Range
Dim normalizedSearch As String ' Normalize edilmiş arama metni
Dim normalizedCell As String ' Normalize edilmiş hücre metni
' Metin kutusundaki yazının boyutu
Me.TextBox1.Font.Italic = False
Me.TextBox1.Font.Size = 16
' 1. Arama metnini alın.
normalizedSearch = Me.TextBox1.Text
' KRİTİK ADIM 1: Arama metnini tüm Türkçe büyük harfler için normalize edin.
' Bu, LCase'den önce tüm Türkçe büyük harfleri doğru küçük harflere çevirerek eşleşme sağlar.
normalizedSearch = Replace(normalizedSearch, "İ", "i")
normalizedSearch = Replace(normalizedSearch, "I", "ı")
normalizedSearch = Replace(normalizedSearch, "Ş", "ş")
normalizedSearch = Replace(normalizedSearch, "Ç", "ç")
normalizedSearch = Replace(normalizedSearch, "Ğ", "ğ")
normalizedSearch = Replace(normalizedSearch, "Ö", "ö")
normalizedSearch = Replace(normalizedSearch, "Ü", "ü")
' Geri kalan normal harfleri (A, B, C...) küçük harfe çevirme
normalizedSearch = LCase(normalizedSearch)
' Aranacak aralığı belirleyin
Set aralik = ThisWorkbook.Sheets("Dashboard").Range("E24:J700")
' Önceki tüm vurguları temizleyin
aralik.Interior.Color = xlNone
' Eğer metin kutusu boş değilse, aramayı yapın
If normalizedSearch <> "" Then
' Aralıktaki her hücreyi döngüye alın
For Each hucre In aralik
' Hücre değerini alın ve string'e çevirin (hata almamak için)
normalizedCell = CStr(hucre.Value)
' KRİTİK ADIM 2: Hücre değerini de aynı şekilde tüm Türkçe büyük harfler için normalize edin.
normalizedCell = Replace(normalizedCell, "İ", "i")
normalizedCell = Replace(normalizedCell, "I", "ı")
normalizedCell = Replace(normalizedCell, "Ş", "ş")
normalizedCell = Replace(normalizedCell, "Ç", "ç")
normalizedCell = Replace(normalizedCell, "Ğ", "ğ")
normalizedCell = Replace(normalizedCell, "Ö", "ö")
normalizedCell = Replace(normalizedCell, "Ü", "ü")
' Geri kalan normal harfleri (A, B, C...) küçük harfe çevirme
normalizedCell = LCase(normalizedCell)
' Normalize edilmiş iki küçük harfli metni karşılaştırın.
If InStr(1, normalizedCell, normalizedSearch) > 0 Then
' Eşleşme bulundu, hücreyi açık yeşil yapın
hucre.Interior.Color = RGB(144, 238, 144) ' Açık yeşil tonu
' Hücrenin metin rengini siyah yapın
hucre.Font.Color = RGB(0, 0, 0)
End If
Next hucre
End If
' Enter'a basıldıktan sonra, isteğe bağlı olarak TextBox'ın odağını kaldırabilirsiniz (opsiyonel)
' SendKeys "{TAB}"
End If
End Sub
'---Sayfa Kapat-Gizle---(Ön izleme modu)
Sub Kapat()
Application.WindowState = xlMaximized
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"", False)"
Application.DisplayFormulaBar = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Activate
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
Next ws
ThisWorkbook.Sheets(1).Activate
ActiveSheet.Range("A1").Select
ActiveWorkbook.Save
End Sub
'---Sayfa Aç---
Sub Ac()
Application.WindowState = xlMaximized
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"", True)"
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Activate
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = True
Next ws
Application.DisplayFormulaBar = True
ThisWorkbook.Sheets(1).Activate
Range("A1").Select
ActiveWorkbook.Save
End Sub
‘***Adet, Yüzde Oranı, Filtre Adet***
‘===Adet===:
‘ Hücre: M3
‘ =ALTTOPLAM(103;Tablo2[Klasör])
‘ Hücre: N3
‘=O3-M3
‘ Hücre: O3
‘ “Toplam değer manuel girilir”
‘===Yüzde Oranı===:
‘ Hücre: M4
‘ =M3*100/631 “Sondaki toplam değer manuel girilir” “Kullanılan Oran”
‘ Hücre: N4
‘=N3*100/631 “Kalan oran”
‘ Hücre: O4
‘ “100” değeri manuel girilir Yüzde yüzün diğer parçası için”
‘===Filtre Adet===:
‘ “X5” kod ile gelen sonucun yazıldığı yer
‘ “X4” 100
‘ “Y4” 0
‘ “Z4” 100
‘ “AA” =X5 hücresi sayı virgülsüz noktalı biçimlendirilmiş, Adet bilgisi bu hücre gösterilecek.
(84) Excel, Metin arama (Büyük/Küçük harf) -- Satırları büyük ve kalın yapma
' --Satırları büyük ve kalın yapma--
'--------------------------------------------------------------------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
' Tıklanan Satır kalın ve büyük olsun
'
Const ANA_ARALIK As String = "B16:I1000" ' ARALIK GÜNCELLENDİ
Const BUYUK_BOYUT As Long = 12
Const KUCUK_BOYUT As Long = 11
On Error GoTo HataYakala
Application.EnableEvents = False
' A1'e tıklandığında tüm ANA_ARALIK'ı küçük boyuta ve normal (kalınsız) yap.
If Target.Address(False, False) = "A1" Then
With Me.Range(ANA_ARALIK).Font
.Size = KUCUK_BOYUT
.Bold = False ' Tüm aralığı kalın yapma özelliğini kaldır.
End With
GoTo HataYakala
End If
' Ana aralık dışında bir yere tıklandıysa çık.
If Intersect(Target, Me.Range(ANA_ARALIK)) Is Nothing Then GoTo HataYakala
' Tek bir hücre seç.
If Target.Cells.CountLarge > 1 Then Set Target = Target.Cells(1, 1)
' Önce tüm aralığı küçült ve kalınsız yap.
With Me.Range(ANA_ARALIK).Font
.Size = KUCUK_BOYUT
.Bold = False ' Önceki kalın ayarını kaldır.
End With
' Sonra seçili satırı (B sütunundan N sütununa kadar) büyüt VE kalın (Bold = True) yap.
With Me.Range("B" & Target.Row & ":I" & Target.Row).Font ' N SÜTUNU BURADA GÜNCELLENDİ
.Size = BUYUK_BOYUT
.Bold = True ' Tıklanan satırı kalın yap.
End With
HataYakala:
Application.EnableEvents = True
End Sub
(83) Excel, "X5" hücre içeriğini temizle ve "A1"hücresine tıkla/dön. (Makro) kodu:
Range("X5").Select
Selection.ClearContents
Range("A1").Select
(82) Excel "TextBox" Arama penceresinde İtalik yazmasın. Arama yapsın ve sonuç hücreleri renklendirsin. (Makro) kodu:
Private Sub TextBox1_Change()
' Bul Filtrele "Texbox kutusu"
Dim aralik As Range
Dim hucre As Range
Dim metin As String
' Metin kutusundaki yazının boyutunu 30 punta ayarlar
Me.TextBox1.Font.Italic = False
Me.TextBox1.Font.Size = 30
' Metin kutusundaki değeri alın ve küçük harfe çevirin
metin = LCase(Me.TextBox1.Text)
' Aranacak aralığı belirleyin
Set aralik = ThisWorkbook.Sheets("Tüm Daireler (BT) Envanter").Range("H26:I7931") ' "Sayfa1" yazan yere sayfanızın adını yazmalısınız
' Tüm hücrelerin arka plan rengini varsayılan (renksiz) olarak ayarlayın
aralik.Interior.Color = xlNone
' Eğer metin kutusu boş değilse
If metin <> "" Then
' Aralıktaki her hücreyi döngüye alın
For Each hucre In aralik
' Eğer hücrenin değeri metin kutusundaki değeri içeriyorsa (büyük/küçük harf duyarsız)
If InStr(1, LCase(hucre.Value), metin) > 0 Then
' Hücrenin arka plan rengini açık yeşil yapın
hucre.Interior.Color = RGB(144, 238, 144) ' Açık yeşil tonu
' Hücrenin metin rengini siyah yapın
hucre.Font.Color = RGB(0, 0, 0)
End If
Next hucre
End If
End Sub
(81) Excel'de belirli bir aralıkta (B26:H5000) bir satıra tıklandığında, o satırın Yazı tipi boyutunu 12 ve Kalın font yapacak. Aynı aralıktaki diğer tüm satırların yazı tipi boyutunu 10'e Kalın font olmayacak. A1 hücresine tıklanınca da (B3:H5000) aralıktaki tüm satırların yazı tipi boyutunu 10 ve Kalın fontsuz olacak. VBA (Makro) kodu:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const ANA_ARALIK As String = "B26:N5000" ' ARALIK GÜNCELLENDİ
Const BUYUK_BOYUT As Long = 12
Const KUCUK_BOYUT As Long = 10
On Error GoTo HataYakala
Application.EnableEvents = False
' A1'e tıklandığında tüm ANA_ARALIK'ı küçük boyuta ve normal (kalınsız) yap.
If Target.Address(False, False) = "A1" Then
With Me.Range(ANA_ARALIK).Font
.Size = KUCUK_BOYUT
.Bold = False ' Tüm aralığı kalın yapma özelliğini kaldır.
End With
GoTo HataYakala
End If
' Ana aralık dışında bir yere tıklandıysa çık.
If Intersect(Target, Me.Range(ANA_ARALIK)) Is Nothing Then GoTo HataYakala
' Tek bir hücre seç.
If Target.Cells.CountLarge > 1 Then Set Target = Target.Cells(1, 1)
' Önce tüm aralığı küçült ve kalınsız yap.
With Me.Range(ANA_ARALIK).Font
.Size = KUCUK_BOYUT
.Bold = False ' Önceki kalın ayarını kaldır.
End With
' Sonra seçili satırı (B sütunundan N sütununa kadar) büyüt VE kalın (Bold = True) yap.
With Me.Range("B" & Target.Row & ":N" & Target.Row).Font ' N SÜTUNU BURADA GÜNCELLENDİ
.Size = BUYUK_BOYUT
.Bold = True ' Tıklanan satırı kalın yap.
End With
HataYakala:
Application.EnableEvents = True
End Sub
(80) Excel'de belirli bir aralıkta (B3:H23) bir satıra tıklandığında, o satırın yazı tipi boyutunu 16 yapacak ve aynı aralıktaki diğer tüm satırların yazı tipi boyutunu 11'e geri döndürecek. A1 hücresine tıklanınca da (B3:H23) aralıktaki diğer tüm satırların yazı tipi boyutunu 11'e geri döndürecek VBA (Makro) kodu:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const ANA_ARALIK As String = "B3:H22"
Const BUYUK_BOYUT As Long = 16
Const KUCUK_BOYUT As Long = 11
On Error GoTo HataYakala
Application.EnableEvents = False
' A1'e tıklandığında tüm B3:H22 aralığını küçük boyuta ayarla.
If Target.Address(False, False) = "A1" Then
Me.Range(ANA_ARALIK).Font.Size = KUCUK_BOYUT
GoTo HataYakala
End If
' Ana aralık dışında bir yere tıklandıysa çık.
If Intersect(Target, Me.Range(ANA_ARALIK)) Is Nothing Then GoTo HataYakala
' Tek bir hücre seç.
If Target.Cells.CountLarge > 1 Then Set Target = Target.Cells(1, 1)
' Tüm aralığı küçült, sonra seçili satırı büyüt.
Me.Range(ANA_ARALIK).Font.Size = KUCUK_BOYUT
Me.Range("B" & Target.Row & ":H" & Target.Row).Font.Size = BUYUK_BOYUT
HataYakala:
Application.EnableEvents = True
End Sub
(79) "Saat/Dakika/Saniyeyi" Toplam Dakikaya Çevirme Formülü
Örnek saat: "01:46:30" (Saat A2 hücresinde)
Formül: =A1∗24∗60 (Hücre biçimi, Genel)
Sonuç:106,5 (Hücre biçimi, Sayı)