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


ayları sayfa olarak ekleme

ID : 361
ISLEM : ayları sayfa olarak ekleme
MAKRO KODU : Sub DoMonths() Dim J As Integer Dim K As Integer Dim sMo(12) As String sMo(1) = "January" sMo(2) = "February" sMo(3) = "March" sMo(4) = "April" sMo(5) = "May" sMo(6) = "June" sMo(7) = "July" sMo(8) = "August" sMo(9) = "September" sMo(10) = "October" sMo(11) = "November" sMo(12) = "December" For J = 1 To 12 If J sMo(J) Then For K = J + 1 To Sheets.Count If Sheets(K).Name = sMo(J) Then Sheets(K).Move Before:=Sheets(J) End If Next K End If Next J Sheets(1).Activate End Sub -

ayları sayfa olarak ekler ayın günlerini de yazar ve aktif ay ve güne gider

ID : 362
ISLEM : ayları sayfa olarak ekler ayın günlerini de yazar ve aktif ay ve güne gider
MAKRO KODU : Option Explicit Sub CreateMonths() Dim lDay As Long Dim iWks As Integer, iDay As Integer For iWks = 1 To 12 Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = Format(DateSerial(1, iWks, 1), "mmmm") For lDay = DateSerial(Year(Date), iWks, 1) To DateSerial(Year(Date), iWks + 1, 0) iDay = iDay + 1 Cells(iDay, 1).Value = DateSerial(Year(Date), iWks, iDay) Next lDay iDay = 0 Next iWks Worksheets(1).Select End Sub Sub GotoToDay() Dim iRow As Integer Worksheets(Month(Date) + 1).Select iRow = WorksheetFunction.Match(CDbl(Date), Columns(1), 0) Cells(iRow, 1).Select End Sub 'Kodun çalıştırılacağı aktif sayfaya Option Explicit

ayları sayfa olarak ekler günleri ayrıntılı olarak belirtir

ID : 363
ISLEM : ayları sayfa olarak ekler günleri ayrıntılı olarak belirtir
MAKRO KODU : Sub Jahreskalender() Dim strJahr As String Dim lngNumSheets As Long Dim intI As Integer, intJahr As Integer strJahr = InputBox("Kalender anlegen für Jahr:", , Year(Date)) If strJahr = "" Or Not IsNumeric(strJahr) Then Exit Sub intJahr = CInt(strJahr) lngNumSheets = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 12 Workbooks.Add Application.SheetsInNewWorkbook = lngNumSheets Application.DisplayAlerts = False Application.ScreenUpdating = False Windows(1).Caption = "Jahreskalender " & strJahr For intI = 1 To 12 Worksheets(intI).Activate Call MonatAnlegen(intJahr, intI) Next intI Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Private Sub MonatAnlegen(intJahr As Integer, intMonat As Integer) Dim intI As Integer Dim lngDate As Long lngDate = CLng(DateSerial(intJahr, intMonat, 1)) ActiveSheet.Name = Format(lngDate, "mmmm") 'zB "Januar" Range("A1") = "Datum" Range("C1") = "Eintragung" Range("D1") = "Geburtstage" With Range("A1:D1") With .Font .Bold = True .Size = 10 .ColorIndex = 6 End With .Interior.ColorIndex = 11 End With intI = DateSerial(intJahr, intMonat + 1, 1) - lngDate + 1 Range("A2") = lngDate Range("A3").Formula = "=A2+1" Range("A3:A" & intI).FillDown Range("A2:A" & intI).Copy Range("A2:A" & intI).PasteSpecial (xlValues) Range("A2:A" & intI).NumberFormat = "dd.mm.yy" Columns(1).Copy Columns(2) Range("B1") = "Tag" Range("B1").HorizontalAlignment = xlRight Range("B2:B" & intI).NumberFormat = "dddd" 'zB "Samstag" Range("C2").Select intI = 2 Do Until IsEmpty(Cells(intI, 1)) Select Case Weekday(Cells(intI, 1)) Case vbSaturday Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 40 'Orange Case vbSunday Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 3 'Rot End Select Cells(intI, 3).Value = Feiertag(Cells(intI, 1).Value) intI = intI + 1 Loop ActiveSheet.UsedRange.Columns.AutoFit End Sub 'http://home.t-online.de/home/t.igel/xlostern.htm Private Function Feiertag(datum As Long) As String Dim temp As Variant Feiertag = "" Select Case Month(datum) Case 1 Select Case Day(datum) Case 1 Feiertag = "Neujahr" Case 6 Feiertag = "Heiligen 3 Könige" End Select Case 2 To 6 osSo = OsterSo(Year(datum)) Select Case datum Case osSo - 48 Feiertag = "Rosenmontag" Case osSo - 47 Feiertag = "Fasching" Case osSo - 46 Feiertag = "Aschermittwoch" Case osSo - 2 Feiertag = "Karfreitag" Case osSo - 1 Feiertag = "Karsamstag" Case osSo Feiertag = "Ostersonntag" Case osSo + 1 Feiertag = "Ostermontag" Case DateSerial(Year(datum), 5, 1) Feiertag = "Tag der Arbeit" Case osSo + 39 Feiertag = "Christi Himmelfahrt" Case osSo + 48 Feiertag = "Pfingstsamstag" Case osSo + 49 Feiertag = "Pfingstsonntag" Case osSo + 50 Feiertag = "Pfingstmontag" Case osSo + 60 Feiertag = "Fronleichnam" End Select Case 8 Select Case Day(datum) Case 15 Feiertag = "Maria Himmelfahrt" End Select Case 10 Select Case Day(datum) Case 3 Feiertag = "Tag der Dt. Einheit" End Select Case 11 temp = DateSerial(Year(datum), 12, 25) Select Case datum Case DateSerial(Year(datum), 11, 1) Feiertag = "Allerheiligen" Case (temp - Weekday(temp, vbMonday) - 32) Feiertag = "Buß- und Bettag" End Select Case 12 Select Case Day(datum) Case 24 Feiertag = "Heilig Abend" Case 25 Feiertag = "1. Weihnachtsfeiertag" Case 26 Feiertag = "2. Weihnachtsfeiertag" Case 31 Feiertag = "Silvester" End Select End Select End Function Private Function OsterSo(jahr As Integer) As Variant Dim d As Variant d = (((255 - 11 * (jahr Mod 19)) - 21) Mod 30) + 21 OsterSo = DateSerial(jahr, 3, 1) + d + (d > 48) + _ 6 - ((jahr + jahr \ 4 + d + (d > 48) + 1) Mod 7) End Function --------------------------------------------------- Ayları sayfa olarak ekler günleri ayrıntılı olarak belirtir Option Explicit Sub Kalender_erstellen() Dim i As Integer, x As Integer, alt As Integer Dim WS As Worksheet Dim Jahr As Integer Jahr = InputBox("Bitte Das Jahr 4-stellig eingeben", "Jahresabfrage", _ IIf(Month(Date) > 9, Year(Date) + 1, Year(Date))) alt = Application.SheetsInNewWorkbook 'alt auslesen Application.SheetsInNewWorkbook = 13 'verändern Workbooks.Add Application.SheetsInNewWorkbook = alt 'zurücksetzen For i = 1 To 12 Set WS = Worksheets(i) With WS.[a1:E3] .HorizontalAlignment = xlCenter .MergeCells = True .Font.Name = "Arial" .Font.Size = 20 .Font.Bold = True .Font.Italic = True .NumberFormat = "mmmm yyyy" End With WS.[a1] = DateSerial(Jahr, i, 1) WS.Name = Format(WS.[a1], "MMMM") WS.[A5:A36].NumberFormat = "DDD DD.MM.YY" WS.Columns(5).HorizontalAlignment = xlRight 'Datum eintragen For x = 0 To 30 If Month(WS.[a1] + x) = Month(WS.Cells(x + 6, 1)) Or x = 0 Then WS.Cells(x + 7, 1) = WS.[a1] + x If Weekday(WS.Cells(x + 7, 1)) = 1 Then _ Range(WS.Cells(x + 7, 1), WS.Cells(x + 7, 5)).Interior.ColorIndex = 48 If Weekday(WS.Cells(x + 7, 1)) = 7 Then _ Range(WS.Cells(x + 7, 1), WS.Cells(x + 7, 5)).Interior.ColorIndex = 15 If Weekday(WS.Cells(x + 7, 1)) = 2 Then WS.Cells(x + 7, 5) = _ "KW " & DatePart("ww", WS.Cells(x + 7, 1), vbMonday, vbFirstFourDays) WS.Cells(x + 7, 1).Borders.Weight = xlThin With Range(WS.Cells(x + 7, 2), WS.Cells(x + 7, 5)) .Borders(xlEdgeLeft).Weight = xlThin .Borders(xlEdgeTop).Weight = xlThin .Borders(xlEdgeBottom).Weight = xlThin .Borders(xlEdgeRight).Weight = xlThin End With 'Feiertage eintragen und formatieren WS.Cells(x + 7, 2) = FeiertagCH(WS.Cells(x + 7, 1)) If WS.Cells(x + 7, 2) "" Then If Right(WS.Cells(x + 7, 2), 1) = "*" And _ WS.Cells(x + 7, 2).Interior.ColorIndex = xlNone Then Range(WS.Cells(x + 7, 1), WS.Cells(x + 7, 3)).Interior.ColorIndex = 15 Else Range(WS.Cells(x + 7, 1), WS.Cells(x + 7, 5)).Interior.ColorIndex = 48 End If End If End If Next x Next i With Worksheets(13) .Name = "Übersicht" .PageSetup.Orientation = xlLandscape With .Columns("A:F") .ColumnWidth = 19.5 ' weitere Formatierungen der Spalten End With For i = 1 To 6 .Cells(2, i) = Format(DateSerial(0, i, 1), "MMMM") .Cells(20, i) = Format(DateSerial(0, i + 6, 1), "MMMM") Range(.Cells(2, i), .Cells(19, i)).BorderAround ColorIndex:=0, Weight:=xlThin Range(.Cells(20, i), .Cells(38, i)).BorderAround ColorIndex:=0, Weight:=xlThin Next i End With End Sub Function FeiertagCH(datum As Date) Dim J As Integer Dim O As Date Dim D As Integer J = Year(datum) D = (((255 - 11 * (J Mod 19)) - 21) Mod 30) + 21 O = DateSerial(J, 3, 1) + D + (D > 48) + 6 - _ ((J + J \ 4 + D + (D > 48) + 1) Mod 7) Select Case datum Case Is = DateSerial(J, 1, 1) FeiertagCH = "Neujahr" Case Is = DateSerial(J, 1, 2) FeiertagCH = "Berchtoldstag*" Case Is = DateSerial(J, 3, 3) FeiertagCH = "Josefstag*" Case Is = DateAdd("D", -2, O) FeiertagCH = "Karfreitag" Case Is = O FeiertagCH = "Ostersonntag" Case Is = DateAdd("D", 1, O) FeiertagCH = "Ostermontag*" Case Is = DateSerial(J, 5, 1) FeiertagCH = "Maifeiertag*" Case Is = DateAdd("D", 39, O) FeiertagCH = "Auffahrt, Christi Himmelfahrt" Case Is = DateAdd("D", 49, O) FeiertagCH = "Pfingstsonntag" Case Is = DateAdd("D", 50, O) FeiertagCH = "Pfingstmontag" Case Is = DateAdd("D", 60, O) FeiertagCH = "Fronleichnam*" Case Is = DateSerial(J, 8, 1) FeiertagCH = "Bundesfeier" Case Is = DateSerial(J, 8, 15) FeiertagCH = "Mariae Himmelfahrt*" Case Is = DateSerial(J, 11, 1) FeiertagCH = "Allerheiligen*" Case Is = DateSerial(J, 12, 8) FeiertagCH = "Mariae Empfängnis*" Case Is = DateSerial(J, 12, 24) FeiertagCH = "Heilig Abend*" Case Is = DateSerial(J, 12, 25) FeiertagCH = "Weihnachtsfeiertag" Case Is = DateSerial(J, 12, 26) FeiertagCH = "Stefanstag" Case Is = DateSerial(J, 12, 31) FeiertagCH = "Silvester*" Case Else FeiertagCH = "" End Select End Function B1127B1141 -

ayları sayfa olarak ekler ve o güne gider

ID : 364
ISLEM : ayları sayfa olarak ekler ve o güne gider
MAKRO KODU : Sub CreateMonths() Dim lDay As Long Dim iWks As Integer, iDay As Integer For iWks = 1 To 12 Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = Format(DateSerial(1, iWks, 1), "mmmm") For lDay = DateSerial(Year(Date), iWks, 1) To DateSerial(Year(Date), iWks + 1, 0) iDay = iDay + 1 Cells(iDay, 1).Value = DateSerial(Year(Date), iWks, iDay) Next lDay iDay = 0 Next iWks Worksheets(1).Select End Sub Sub GotoToDay() Dim iRow As Integer Worksheets(Month(Date) + 1).Select iRow = WorksheetFunction.Match(CDbl(Date), Columns(1), 0) Cells(iRow, 1).Select End Sub

aynı anda 2 tane form

ID : 365
ISLEM : aynı anda 2 tane form
MAKRO KODU : Private Sub UserForm_Initialize() UserForm1.StartUpPosition = 0 UserForm1.Top = 10 UserForm1.Left = 10 End Sub

aynı dizine txt dosyasına a,b,c sütunundakileri kopyalar, kapatır

ID : 366
ISLEM : aynı dizine txt dosyasına a,b,c sütunundakileri kopyalar, kapatır
MAKRO KODU : Sub als_text_speichern() Dim iRow As Long, strDatei As String, iLastRow As Integer iLastRow = Sheets(1).Cells(65536, 1).End(xlUp).Row strDatei = ThisWorkbook.Path & "\test1.txt" Open strDatei For Output As #1 For iRow = 1 To iLastRow Print #1, Format(Cells(iRow, 1), "#0.00"); Chr(9); Print #1, Format(Cells(iRow, 2), "YYYYMMDD"); Chr(9); Print #1, Cells(iRow, 3) Next iRow Close #1 End Sub

aynı hücrede rakam değiştikçe b1'e yaz

ID : 367
ISLEM : aynı hücrede rakam değiştikçe b1'e yaz
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Cells.Address "$A$2" Then Exit Sub If [b1] = Empty Then [b1] = "=" If IsNumeric([a1]) And [a1] 0 Then [b1].Formula = [b1].Formula & "+" & [a1] End Sub -

aynı olanın üzerine kayıt etme

ID : 368
ISLEM : aynı olanın üzerine kayıt etme
MAKRO KODU : Private Sub cmbkaydet_Click() Dim i As Integer Sheets("Sayfa1").Select '*** önce textoxları kontrol edelim If txtadet.Value = "" Or txtkilo.Value = "" Or txtfiyat.Value = "" Then MsgBox "Eksik taımlama yapmışsınız!" Exit Sub End If '**** Şimdi de aynı fiyattan varmı diye bakalım '**** varsa üzerine toplayalım '**** yoksa alttaki boş satıra gidelim For i = 1 To 18 If txtfiyat.Value * 1 = Cells(i, 3) Then Cells(i, 1) = Cells(i, 1) + txtadet.Value Cells(i, 2) = Cells(i, 2) + txtkilo.Value Cells(i, 3) = Cells(i, 3) GoTo AtlaSona Else If Cells(i, 3).Value = "" Then Cells(i, 1) = txtadet.Value Cells(i, 2) = txtkilo.Value Cells(i, 3) = txtfiyat.Value GoTo AtlaSona End If End If Next i MsgBox "18 satırınız da dolmuş" Exit Sub AtlaSona: txtadet.Value = "" txtkilo.Value = "" txtfiyat.Value = "" MsgBox "Kaydedildi" txtadet.SetFocus End Sub

aynı olanlardan tekini comboboxta listeleme

ID : 369
ISLEM : aynı olanlardan tekini comboboxta listeleme
MAKRO KODU : For x = 2 To Cells(65536, 3).End(xlUp).Row If WorksheetFunction.CountIf(Range("c2:c" & x), Cells(x, 3)) = 1 Then ComboBox1.AddItem Cells(x, 3).Value End If Next

aynı olanların üzerlerine kayıt etme

ID : 370
ISLEM : aynı olanların üzerlerine kayıt etme
MAKRO KODU : Private Sub cmbkaydet_Click() Dim i As Integer Sheets("Sayfa1").Select '*** önce textoxları kontrol edelim If txtadet.Value = "" Or txtkilo.Value = "" Or txtfiyat.Value = "" Then MsgBox "Eksik taımlama yapmışsınız!" Exit Sub End If Dim j As Integer, k As Integer j = 1 k = 3 BASADONELIM: '**** Şimdi de aynı fiyattan varmı diye bakalım '**** varsa üzerine toplayalım '**** yoksa alttaki boş satıra gidelim For i = k To k + 15 If txtfiyat.Value * 1 = Cells(i, j + 2) Then Cells(i, j) = Cells(i, j) + txtadet.Value Cells(i, j + 1) = Cells(i, j + 1) + txtkilo.Value Cells(i, j + 2) = Cells(i, j + 2) GoTo AtlaSona Else If Cells(i, j + 2).Value = "" Then Cells(i, j) = txtadet.Value Cells(i, j + 1) = txtkilo.Value Cells(i, j + 2) = txtfiyat.Value GoTo AtlaSona End If End If Next i If i = k + 16 And j -

aynı sayfa ile açılma

ID : 371
ISLEM : aynı sayfa ile açılma
MAKRO KODU : Sub Auto_Open() Sheets("Sayfa2").Select End Sub

aynı sayfa var uyarısı

ID : 372
ISLEM : aynı sayfa var uyarısı
MAKRO KODU : isimgir = TextBox3.Text satırından sonra For i = 1 To Sheets.Count If Sheets(i).Name = isimgir Then MsgBox "Aynı isimde sayfa var" Exit Sub End If Next i

aynı sayfa var uyarısı 2

ID : 373
ISLEM : aynı sayfa var uyarısı 2
MAKRO KODU : Private Sub CommandButton1_Click() If Not TextBox3.Text = Empty Then For i = 1 To Worksheets.Count If Sheets(i).Name = TextBox3.Text Then MsgBox "Bu isimli bir sayfa mevcut..... !" Exit Sub End If Next Set NewSh = Worksheets.Add(After:=Sheets(Sheets.Count)) NewSh.Name = TextBox3.Text End If Set NewSh = Nothing End Sub

ayni makroyla birden çok sayfaya kayit yapmak

ID : 374
ISLEM : ayni makroyla birden çok sayfaya kayit yapmak
MAKRO KODU : Bu kodları denermisin..Yalnız kaydetmek istediğin hücrelerde veri doğrulama ile yapılmış kısımlar var.Onları halletmen gerek.. Kod: Private Sub CommandButton5_Click() If TextBox14.Value "" Then Sheets("Cari Kart").Activate Cells(8, 1).Select Do While ActiveCell.Value "" If Trim(ActiveCell.Value) = Trim(Me.TextBox15.Value) Then If MsgBox(Me.TextBox15 & " Dosya Numaralı Ürün Kaydı Var" & " Yeniden Kayıt Yapılsın mı?", vbYesNo, "Mükerrer Kayıt") = vbNo Then Exit Sub End If ActiveCell.Offset(1, 0).Activate Loop ActiveCell.Value = TextBox14.Value ActiveCell.Offset(0, 1).Value = TextBox15.Value ActiveCell.Offset(0, 2).Value = TextBox16.Value ActiveCell.Offset(0, 3).Value = TextBox19.Value 'diyelimki Bundan sonrakileri Sayfa2'ye kaydedeceksiniz. 'Sheets("Sayfa2").Select ile verileri kaydetmek istediğiniz sayfaya geçiyor 'Range ("A1).Select Aktif hücreyi seçerek kaydı tamamlıyor. Sheets("Kasa").Select Range("B8").Select ActiveCell.Offset(1, 0).Activate ActiveCell.Value = TextBox14.Value ActiveCell.Offset(0, 1).Value = TextBox15.Value ActiveCell.Offset(0, 2).Value = TextBox16.Value ActiveCell.Offset(0, 3).Value = TextBox19.Value 'Kasa sayfasına kayıtlar B8 hücresinden başlaması gerekiyor 'TextBox14 deki bilgiler B sütununa atılıyor ActiveCell.Offset(0, 2).Value = TextBox14.Value 'TextBox17 deki bilgiler C sütununa atılıyor ActiveCell.Offset(0, 3).Value = TextBox17.Value 'TextBox20 deki bilgiler E sütununa atılıyor ActiveCell.Offset(0, 5).Value = TextBox20.Value End If End Sub -

ayni makroyu başka sheetlerde de çaliştirmak

ID : 375
ISLEM : ayni makroyu başka sheetlerde de çaliştirmak
MAKRO KODU : Sub listele() [a2:p65536].ClearContents For a = 2 To Sheets.Count Set s1 = Sheets(a) For b = 2 To s1.[w65536].End(3).Row c = c + 1 Cells(c + 1, "a") = s1.[b1] Cells(c + 1, "b") = s1.[b8] For sut = 1 To 14 Cells(c + 1, sut + 2) = s1.Cells(b, sut + 22) Next Next Next End Sub

ayni olan sayilar

ID : 376
ISLEM : ayni olan sayilar
MAKRO KODU : Sub AKTAR() Set s1 = [Sayfa1] Set s2 = [Sayfa2] s1.Select s1_son = s1.[A65536].End(3).Row S2_SON = s2.[A65536].End(3).Row For x = 2 To S2_SON For y = 2 To s1_son If s1.Cells(y, 1) = s2.Cells(x, 1) Then For z = 2 To 11 s2.Cells(x, z + 8) = s1.Cells(y, z) Next z Exit For End If Next y Next s2.Select End Sub

ayrıntılı adres sütun no, sütun adı, satır no, satır adı

ID : 377
ISLEM : ayrıntılı adres sütun no, sütun adı, satır no, satır adı
MAKRO KODU : Sub Spalte() Dim s As Integer Dim z As Integer Dim t As String Dim u As String s = ActiveCell.Column z = ActiveCell.Row t = Columns(s).Address(0, 0) u = Rows(z).Address(0, 0) MsgBox "Spaltennummer: " & s & Chr$(13) & Chr$(13) & "Spaltenbuchstabe(n): " & Left(t, InStr(t, ":") - 1) & Chr$(13) & Chr$(13) & "Zeilennummer: " & Left(u, InStr(u, ":") - 1) & Chr$(13) & Chr$(13) & "Adresse: " & Left(t, InStr(t, ":") - 1) & Left(u, InStr(u, ":") - 1), _ vbOKOnly, "Adresse der aktiven Zelle ..." End Sub

ayrıntılı aktif hücre adresi

ID : 378
ISLEM : ayrıntılı aktif hücre adresi
MAKRO KODU : Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim s As Integer Dim z As Integer Dim t As String Dim u As String s = ActiveCell.Column z = ActiveCell.Row t = Columns(s).Address(0, 0) u = Rows(z).Address(0, 0) MsgBox "Sütun numarası: " & s & Chr$(13) & Chr$(13) & "Sütun Adı: " & Left(t, InStr(t, ":") - 1) & Chr$(13) & Chr$(13) & "Satır Numarası: " & Left(u, InStr(u, ":") - 1) & Chr$(13) & Chr$(13) & "Hücre Adresi: " & Left(t, InStr(t, ":") - 1) & Left(u, InStr(u, ":") - 1), _ vbOKOnly, "Ayrıntılı aktif hücre adresleri" End Sub

ayrıntılı hücre adresi

ID : 379
ISLEM : ayrıntılı hücre adresi
MAKRO KODU : Sub Zelladresse() Worksheets(1).Select With ActiveCell MsgBox .Address MsgBox .Address(False) MsgBox .Address(, False) MsgBox .Address(False, False) MsgBox .Row MsgBox .Column MsgBox "Zeile: " & .Row & _ " - Spalte:" & .Column End With End Sub

ayri sayfalardaki belli hücreleri toplatmak

ID : 380
ISLEM : ayri sayfalardaki belli hücreleri toplatmak
MAKRO KODU : Bir alternatif, Sub test(yol As String, dosyaadi As String, sayfaadi, range As String) With ActiveSheet.Range(range) .FormulaArray = "='" & yol & "\[" & dosyaadi & "]" & sayfaadi & "'!" & range .Value = .Value End With End Sub çağırma örneği test ("C:\klasoradi", "kitap.xls","sayfa1", "A1") kapalı c:\klasoradi\kitap.xls dosyasının sayfa1 sayfasındaki a1 hücresini alır. Bir diğer alternatif Applicaiton.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False Set kitap = Workbooks.Open ("c:\klasor\kitapadi.xls") cells(1,1) = kitap.Worksheets("sayfa1").cells(1,1) Applicaiton.ScreenUpdating = True Application.EnableEvents = True Application.DisplayAlerts = True kapalı c:\klasor\kitapadi.xls sayfa1 sayfasındaki a1 hücresini alır.

b kolonunda 2.satır ve 21.satırlar arasına tıklayınca form aç

ID : 381
ISLEM : b kolonunda 2.satır ve 21.satırlar arasına tıklayınca form aç
MAKRO KODU : Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveCell.Column = 2 And ActiveCell.Row > 1 And ActiveCell.Row -

b sütununda aynı olanları siler 1 tane bırakır

ID : 382
ISLEM : b sütununda aynı olanları siler 1 tane bırakır
MAKRO KODU : Sub mukerrersil() Dim i, y, a As Integer a = WorksheetFunction.CountA(Range("b1:b65000")) For i = 1 To a For y = i + 1 To a If Cells(i, 1).Value = Cells(y, 1) Then Cells(i, 1).Value = Cells(i, 1).Value Cells(y, 1).Value = Cells(y, 1).Value Cells(y, 1).EntireRow.Delete End If Next y Next i End Sub

b sütununda herhangi bir hücreye çift tıkla 1 artırsın

ID : 383
ISLEM : b sütununda herhangi bir hücreye çift tıkla 1 artırsın
MAKRO KODU : Private Sub Worksheet_BeforeDoubleClick(ByVal Target _ As Range, Cancel As Boolean) Cancel = True If Target.Row = 1 Then Exit Sub If Target.Column 2 Then Exit Sub On Error Resume Next Application.EnableEvents = False Target.Value = Target.Value + 1 Application.EnableEvents = True If Err.Number 0 Then MsgBox "Unable to add 1 to value in cell " _ & Target.Address(0, 0) End If End Sub -

b sütununda herhangi bir hücreye çift tıkla kaç satır ekleneceğini belirt

ID : 384
ISLEM : b sütununda herhangi bir hücreye çift tıkla kaç satır ekleneceğini belirt
MAKRO KODU : Private Sub Worksheet_BeforeDoubleClick(ByVal _ Target As Range, Cancel As Boolean) If Target.Column 2 Then Exit Sub If Not IsNumeric(Target) Then Exit Sub Cancel = True Dim i As Long, curv As Long, tov As Long curv = Target.Value tov = InputBox("supply new total rows", _ "Rows input", curv + 1) If tov -

b sütununda tıkladığın satırın numarasını a sütununa yazar

ID : 385
ISLEM : b sütununda tıkladığın satırın numarasını a sütununa yazar
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

b sütunundaki isimleri a sütunu ile karşılaştırır aynı olanları a sütunundan siler

ID : 386
ISLEM : b sütunundaki isimleri a sütunu ile karşılaştırır aynı olanları a sütunundan siler
MAKRO KODU : Sub test() Dim ra As Range, rb As Range For Each rb In [B1:B100] For Each ra In [A1:A100] If InStr(1, ra, rb) > 0 And rb "" Then ra.ClearContents Next ra Next rb End Sub -

b sütunundaki mükerrerleri siler

ID : 387
ISLEM : b sütunundaki mükerrerleri siler
MAKRO KODU : Sub mukerrersil() Dim i, y, a As Integer a = WorksheetFunction.CountA(Range("b1:b65000")) For i = 1 To a For y = i + 1 To a If Cells(i, 1).Value = Cells(y, 1) Then Cells(i, 1).Value = Cells(i, 1).Value Cells(y, 1).Value = Cells(y, 1).Value Cells(y, 1).EntireRow.Delete End If Next y Next i End Sub

b sütunundaki sayfalara göre kaydeder

ID : 388
ISLEM : b sütunundaki sayfalara göre kaydeder
MAKRO KODU : Sub aktar() Application.ScreenUpdating = False Dim s(2) Set s(1) = Sheets("ATÖLYE RAPORU") Set s(2) = Sheets("BAKIM RAPORU") For a = 1 To 2 For b = 3 To s(a).[a65536].End(3).Row Set s3 = Sheets("" & s(a).Cells(b, "b")) sonsat = s3.[a65536].End(3).Row + 1 If s(a).Cells(b, "d") = "x" Then GoTo 10 s3.Cells(sonsat, "a") = s(a).Cells(b, "a") s3.Cells(sonsat, "b") = s(a).Cells(b, "c") s(a).Cells(b, "d") = "x" s3.[a3:b65536].Sort Key1:=s3.[a3] 10 Next: Next s(1).Select MsgBox "VERİLER AKTARILDI" End Sub

b sütunundan a sütunana boş hücreleri aktarmak

ID : 389
ISLEM : b sütunundan a sütunana boş hücreleri aktarmak
MAKRO KODU : Sub Test() Dim MyRng As Range Dim NoB As Long NoB = Cells(65536, 2).End(xlUp).Row For Each MyRng In Range("B2:B" & NoB) If MyRng.Offset(0, -1) = "" Then MyRng.Offset(0, -1) = MyRng Next End Sub

b1 den itibaren yaz a1 e sıra numarası versin

ID : 390
ISLEM : b1 den itibaren yaz a1 e sıra numarası versin
MAKRO KODU : Option Explicit Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Column 2 Then Exit Sub If Target.Row = 1 Then Exit Sub If Left(Target.Offset(0, -1), 1) = "~" Then Exit Sub If Left(Target.Offset(0, -1), 1) = "~" Then Exit Sub If Left(Target.Offset(0, -1), 1) = "=Row()-1" Then Exit Sub Target.Offset(0, -1).Formula = "=Row()-1" End Sub -

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