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


a ile b'yi karşılaştır, aynı olanları c'ye, farklı olanları d'ye yaz

ID : 31
ISLEM : a ile b'yi karşılaştır, aynı olanları c'ye, farklı olanları d'ye yaz
MAKRO KODU : Sub bul() For a = 2 To Cells(65536, 1).End(xlUp).Row If WorksheetFunction.CountIf(Columns(1), Cells(a, 2).Value) = 0 Then e = WorksheetFunction.CountA([d2:d65536]) + 1 Cells(e + 1, 4) = Cells(a, 2).Value End If If WorksheetFunction.CountIf(Columns(2

a sütunu auto_copy

ID : 32
ISLEM : a sütunu auto_copy
MAKRO KODU : Sub AutoCopy() Dim LookupRange As Range, cell As Range, Found As Boolean Dim DestRange As Range Set LookupSheet = Sheet2 Set DestSheet = Sheet3 n = ActiveCell.Value Set LookupRange = Intersect(LookupSheet.Columns("A"), LookupSheet.UsedRange) Set DestRange = DestSheet.Range("A65536").End(xlUp).Offset(1, 0) Found = False If n "" Then For Each cell In LookupRange If cell.Value = n Then delrange = cell.Address cell.EntireRow.Cut DestRange Found = True Exit For End If Next cell End If If Not Found Then msg = "The code does not exist on " & LookupSheet.Name & "." MsgBox msg, vbOKOnly, "AutoCopy" Else LookupSheet.Range(delrange).EntireRow.Delete DestSheet.Select Range("A65536").End(xlUp).EntireRow.Select End If End Sub -

a sütununa pir yazınca makro çalışsın

ID : 33
ISLEM : a sütununa pir yazınca makro çalışsın
MAKRO KODU : 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 = "pir" Then Call Test End Sub Sub Test() MsgBox "Tebrikler..!", vbInformation End Sub

a sütununda aralarda boş satırları siler ve yukarı çeker

ID : 34
ISLEM : a sütununda aralarda boş satırları siler ve yukarı çeker
MAKRO KODU : Option Explicit Sub Leerzeilenlöschen() Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete End Sub

a sütununda aynı değerde olanları yazdırma alanı olarak ayırır

ID : 35
ISLEM : a sütununda aynı değerde olanları yazdırma alanı olarak ayırır
MAKRO KODU : Sub AutoBreak() Set Urange = ActiveSheet.UsedRange Set ColA = Range("A:A") Set Arange = Intersect(ColA, Urange) Set Brange = Arange.Offset(1, 0).Resize(Arange.Rows.Count - 1) Cells.PageBreak = xlNone For Each cell In Brange If cell.Value cell.Offset(1, 0).Value Then cell.Offset(1, 0).EntireRow.PageBreak = xlPageBreakManual End If Next End Sub -

a sütununda aynı olanlardan 1 tane bırakır ve sıraya dizer

ID : 36
ISLEM : a sütununda aynı olanlardan 1 tane bırakır ve sıraya dizer
MAKRO KODU : Sub Doppelte_löschen() Range("A:A").Select Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _ xlTopToBottom Range("A1").Select nr = ActiveCell zellende = Range("A" & Rows.Count).End(xlUp).Row Do ActiveCell.Offset(1, 0).Range("A1").Select If ActiveCell = nr Then Selection.EntireRow.Delete ActiveCell.Offset(-1, 0).Range("A1").Select End If nr = ActiveCell Loop Until ActiveCell = Range("A" & zellende + 1) End Sub

a sütununda aynı olanları sayfa alanı olarak ayırır

ID : 37
ISLEM : a sütununda aynı olanları sayfa alanı olarak ayırır
MAKRO KODU : Sub AutoBreak() Set Urange = ActiveSheet.UsedRange Set ColA = Range("A:A") Set Arange = Intersect(ColA, Urange) Set Brange = Arange.Offset(1, 0).Resize(Arange.Rows.Count - 1) Cells.PageBreak = xlNone For Each cell In Brange If cell.Value cell.Offset(1, 0).Value Then cell.Offset(1, 0).EntireRow.PageBreak = xlPageBreakManual End If Next End Sub -

a sütununda aynı olanları sayfa alanı olarak ayırır2

ID : 38
ISLEM : a sütununda aynı olanları sayfa alanı olarak ayırır2
MAKRO KODU : Sub SetzeSeiten() Dim rngBereich As Range Dim rngZelle As Range Application.ScreenUpdating = False On Error GoTo Ende Set rngBereich = Range("A1:A" & Range("A2").End(xlDown).Row) Cells.PageBreak = xlNone For Each rngZelle In rngBereich If rngZelle rngZelle.Offset(1, 0) Then rngZelle.Offset(1, 0).PageBreak = xlPageBreakManual Next rngZelle Ende: Application.ScreenUpdating = True End Sub -

a sütununda boş satırları siler

ID : 39
ISLEM : a sütununda boş satırları siler
MAKRO KODU : Sub bossatirsil() For a = 1 To Sheets.Count sat = Sheets(a).Cells.SpecialCells(xlCellTypeLastCell).Row sut = Sheets(a).Cells.SpecialCells(xlCellTypeLastCell).Column For b = sat To 1 Step -1 If WorksheetFunction.CountA(Sheets(a).Rows(b)) = 0 Then Sheets(a).Rows(b).Delete Next For c = sut To 1 Step -1 If WorksheetFunction.CountA(Sheets(a).Columns(c)) = 0 Then Sheets(a).Columns(c).Delete Next Next End Sub

a sütununda boşlukları aldırma doluları listeleme

ID : 40
ISLEM : a sütununda boşlukları aldırma doluları listeleme
MAKRO KODU : Sub Leerzeilenlöschen() Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete End Sub

a sütununda bugünü bulsun

ID : 41
ISLEM : a sütununda bugünü bulsun
MAKRO KODU : Sub bugunu_bul() Dim lr As Long Dim i As Integer lr = Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To lr If Cells(i, 1).Value = Date Then Cells(i, 1).Select End End If Next i End Sub

a sütununda en son sırada olan veriyi b1 e kopyalar

ID : 42
ISLEM : a sütununda en son sırada olan veriyi b1 e kopyalar
MAKRO KODU : Sub LetztenWertKopieren() Dim intCol As Integer intCol = 1 '1 steht für Spalte A Cells(Rows.Count, intCol).End(xlUp).Copy _ Range("B1") End Sub

a sütununda herhangi bir hücreye tıkla satır numarasını versin

ID : 43
ISLEM : a sütununda herhangi bir hücreye tıkla satır numarasını versin
MAKRO KODU : Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) rowoffset = 0 Intersect(ActiveCell.EntireRow, Columns("A")).Value = ActiveCell.Row + rowoffset End Sub

a sütununda verilere göre sayfa ekler ve d sütununa kadar olan verileri de yazar

ID : 44
ISLEM : a sütununda verilere göre sayfa ekler ve d sütununa kadar olan verileri de yazar
MAKRO KODU : Sub aktar() On Error Resume Next Application.DisplayAlerts = False ActiveSheet.Move before:=Sheets(1) Application.DisplayAlerts = True ActiveSheet.Copy after:=Sheets(Worksheets.Count) ActiveSheet.Shapes("Button 1").Select Selection.Cut ActiveSheet.Shapes("Button 2").Select Selection.Cut basla: If [A2] = "" Then Exit Sub Set sayfa = ActiveSheet Columns("A:D").EntireColumn.AutoFit sayfa.Name = [A2] Set sec = [A2].CurrentRegion.Columns(1).ColumnDifferences([A2]) Set sec = Intersect(sec.EntireRow, [A:D]) If sec.Address = "" Then Exit Sub Worksheets.Add after:=Sheets(Worksheets.Count) Set sonsayfa = Sheets(Worksheets.Count) sayfa.Select For Each alan In sec.Areas alan.Copy sat = sonsayfa.[a65536].End(3).Row + 1 sonsayfa.Cells(sat, 1).Insert shift:=xlDown alan.Delete shift:=xlUp Next Set sec = Nothing sonsayfa.Select GoTo basla End Sub

a sütunundaki aynı değerleri öbür sayfada süzüp b deki toplamlarını ilave eder

ID : 45
ISLEM : a sütunundaki aynı değerleri öbür sayfada süzüp b deki toplamlarını ilave eder
MAKRO KODU : Sub aktar() Dim isim, deger As Variant Dim rng As Range Dim i, z As Integer i = 2 z = 1 Do If Cells(i, 1).Value = "" Then GoTo bitti If Range([A1], [A10000]).Find(What:=Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows).Row -

a sütunundaki boş satırları gizler

ID : 46
ISLEM : a sütunundaki boş satırları gizler
MAKRO KODU : Private Sub CommandButton1_Click() Application.ScreenUpdating = False Dim i As Integer For i = 1 To 300 '1 satır ile 300. satır arası If IsEmpty(Cells(i, 1)) Then '1. Satır 1. Sütun yani A1 hücresi Rows(i).Hidden = True End If Next i Application.ScreenUpdating = True

a sütunundaki dolu hücreleri bulur ve yazdirma alani içine alir

ID : 47
ISLEM : a sütunundaki dolu hücreleri bulur ve yazdirma alani içine alir
MAKRO KODU : Açıklama:A sütunundaki dolu hücreleri bulur ve yazdırma alanı içine alır Kod: Sub setPrintArea() Dim rng As Range Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell) stcell = "A1": lcell = rng.Address ActiveSheet.PageSetup.PrintArea = stcell & ":" & lcell End Sub

a sütunundaki en büyük sayı için

ID : 48
ISLEM : a sütunundaki en büyük sayı için
MAKRO KODU : Private Sub UserForm_Initialize() TextBox1.Value = WorksheetFunction.Max(Range("A:A")) End Sub

a sütunundaki en son veriyi b1 e yaz

ID : 49
ISLEM : a sütunundaki en son veriyi b1 e yaz
MAKRO KODU : Sub enbuyuk() Dim intCol As Integer intCol = 1 '1 steht für Spalte A Cells(Rows.Count, intCol).End(xlUp).Copy _ Range("B1") End Sub

a sütunundaki sayılara 1 ekler c sütununa yazar

ID : 50
ISLEM : a sütunundaki sayılara 1 ekler c sütununa yazar
MAKRO KODU : Sub ekle1yazC() Dim MaValeur, compteur For compteur = 1 To 15 Range("A" & compteur).Select MaValeur = ActiveCell.Value Range("C" & compteur).Select ActiveCell.Value = MaValeur + 1 Next End Sub

a sütunundakiler combboxta, combobox seçilince b,c,d dekiler textboxta

ID : 51
ISLEM : a sütunundakiler combboxta, combobox seçilince b,c,d dekiler textboxta
MAKRO KODU : Private Sub ComboBox1_Change() Dim I As Long For I = 1 To 3 Me.Controls("TextBox" & I) = Range("A" & ComboBox1.ListIndex + 1).Offset(, I) Next I End Sub

a sütunundakileri 100 ile toplar b sütununa yazar

ID : 52
ISLEM : a sütunundakileri 100 ile toplar b sütununa yazar
MAKRO KODU : Sub topla100yazB() Dim MaValeur, nbcell For nbcell = 1 To 10 Range("A" & nbcell).Select MaValeur = ActiveCell.Value Range("B" & nbcell).Select ActiveCell.Value = MaValeur + 100 Next End Sub

a sütunundakileri benzersiz olacak şekilde ayıklar

ID : 53
ISLEM : a sütunundakileri benzersiz olacak şekilde ayıklar
MAKRO KODU : Sub benzersiz() Columns("A:A").Select Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns("C:C"), Unique:=True Range("C11").Select End Sub

a sütunundakileri benzersiz olacak şekilde ayıklar2

ID : 54
ISLEM : a sütunundakileri benzersiz olacak şekilde ayıklar2
MAKRO KODU : Sub süz() On Error Resume Next Sayfa1.Range("a1:a1500").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sayfa1.Range( _ "h1"), Unique:=True End Sub

a sütunundakileri saydırın

ID : 55
ISLEM : a sütunundakileri saydırın
MAKRO KODU : WorksheetFunction.CountA(Columns("A"))

a sütunundan g sütununa (g hariç) kadar olan hesaplamalar açık , diğer sütunlar butona basınca hesaplasın

ID : 56
ISLEM : a sütunundan g sütununa (g hariç) kadar olan hesaplamalar açık , diğer sütunlar butona basınca hesaplasın
MAKRO KODU : Sub Auto_Open() Application.Calculation = xlCalculationManual 'hesaplamayı el ile yapar Application.OnKey "{F9}", "sec_hesapla" 'F9 tuşuna basınca sec_hesapla makrosunu çalıştırır End Sub Sub Auto_Close() Application.Calculation = xlCalculationAutomatic 'çıkışta otomatik hesaplama yapar. End Sub Sub sec_hesapla() Dim sec 'sec sabiti sec = Range("A1:A9").Select 'sec sabitinin aralığı tanımlanır ve seçilir (A1:A9 arasında formüllerin olduğunu varsayıorum) Selection.Calculate 'seçili olan aralık F9 tuşuna basılınca hesaplanır End Sub

a sütununu hücrelerini çerçeve içerisine alır

ID : 57
ISLEM : a sütununu hücrelerini çerçeve içerisine alır
MAKRO KODU : Sub ZeilenFärben() Dim Zeile As Range, ZeilenNr As Integer For Each Zeile In Selection.Columns ZeilenNr = ZeilenNr + 1 If ZeilenNr Mod 2 = 0 Then Zeile.Interior.ColorIndex = 6 Else Zeile.Interior.ColorIndex = xlAutomatic End If Zeile.Borders.Weight = xlThin Next End Sub

a sütünündaki sayıları sıralar (aradan biri silinice bile sıralar)

ID : 58
ISLEM : a sütünündaki sayıları sıralar (aradan biri silinice bile sıralar)
MAKRO KODU : Dim say As Integer Dim i As Integer say = WorksheetFunction.CountA(Range("A2:A65000")) For i = 1 To say Cells(i + 1, 1) = i Next i

a sütünündaki sayıları sıralar (aradan biri silinice bile sıralar) 2

ID : 59
ISLEM : a sütünündaki sayıları sıralar (aradan biri silinice bile sıralar) 2
MAKRO KODU : Sub sirala() For x = 2 To [b65536].End(3).Row Cells(x, 1).Value = x - 1 Next End Sub

a ve c sütunundaki veriler aynıysa o satırı silsin

ID : 60
ISLEM : a ve c sütunundaki veriler aynıysa o satırı silsin
MAKRO KODU : For C = [c65536].End(3).Row To 1 Step -1 If Cells(C, "c")=cells(C,"a") Then Rows(C).Delete Next

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