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


inputbox çift satırlı örnek

ID : 1201
ISLEM : inputbox çift satırlı örnek
MAKRO KODU : Sub DecideUserInput() Dim bText As String, bNumber As Integer ' here is the INPUTBOX-function : bText = InputBox("Insert in a text", "This accepts any input") ' here is the INPUTBOX-method : bNumber = Application.InputBox("Insert a number", "This accepts numbers only", , , , , , 1) MsgBox "You have inserted :" & Chr(13) & _ bText & Chr(13) & bNumber, , "Result from INPUT-boxes" End Sub

inputbox içine yazilan karakterler "*****" şeklinde çikabilir mi?

ID : 1202
ISLEM : inputbox içine yazilan karakterler "*****" şeklinde çikabilir mi?
MAKRO KODU : Public MyPass ' Bu satir Modulün General_Declarations kisminda olucak (en üstte). ' Sub MainProgram() ' 'Ana programin kodlari buralarda ' ' 'Asagidaki satirla "*" karakterli sifre girme kutusunu çagiriyoruz ' MyPasswBox ' 'Eger kullanici bir sifre girdiyse, 'asagidaki satirlarda, kullanicinin girdigi sifreyi '"çiplak" olarak görüntülüyoruz. ' 'Sizin yapmaniz gereken If - End If satirlari arasinda 'sifre kontrolunu yaptirip, kodlari çalismaniza göre yönlendirmek olucak If MyPass "" Then MsgBox "Girilen sifre : " & MyPass End If ' 'Ana programin kodlarinin devami buralarda ' End Sub ' Sub MyPasswBox() Dim PassWForm Set PassWForm = ThisWorkbook.VBProject.VBComponents.Add(3) PassWForm.properties("Width") = 200 PassWForm.properties("Height") = 90 Set NewTextBox = PassWForm.Designer.Controls.Add("forms.TextBox.1") PassWForm.properties("Caption") = "Sifre girisi !" With NewTextBox .Width = 120 .Height = 18 .Left = 8 .Top = 20 .PasswordChar = "*" .ForeColor = vbRed End With Set NewCommandButton1 = PassWForm.Designer.Controls.Add("forms.CommandButton.1") With NewCommandButton1 .Caption = "Vazgeç" .Height = 18 .Width = 50 .Left = 140 .Top = 18 End With Set NewCommandButton2 = PassWForm.Designer.Controls.Add("forms.CommandButton.1") With NewCommandButton2 .Caption = "Tamam" .Height = 18 .Width = 50 .Left = 140 .Top = 42 End With With PassWForm.CodeModule X = .CountOfLines .InsertLines X + 1, "Sub CommandButton1_Click()" .InsertLines X + 2, "Unload Me" .InsertLines X + 3, "End Sub" .InsertLines X + 4, "Sub CommandButton2_Click()" .InsertLines X + 5, "MyPass = TextBox1" .InsertLines X + 6, "Unload Me" .InsertLines X + 7, "End Sub" .InsertLines X + 8, "Sub UserForm_Activate()" .InsertLines X + 9, "Me.SpecialEffect=3" .InsertLines X + 10, "End Sub" End With VBA.UserForms.Add(PassWForm.Name).Show ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=PassWForm End Sub -

inputbox ile aktif hücreye açıklama ekleme

ID : 1203
ISLEM : inputbox ile aktif hücreye açıklama ekleme
MAKRO KODU : Sub input_comment() Dim pir Dim n As Variant Dim l As Long pir = InputBox("Yazı yazın açıklama olarak eklesin.", _ "input_açıklama") n = ActiveCell.NoteText l = Len(n) If l > 0 Then ActiveCell.NoteText Text:=" / " & pir, Start _ :=l + 1 Else ActiveCell.NoteText Text:=pir End If End Sub

inputbox ile filtreleme ve filtreleneni silme

ID : 1204
ISLEM : inputbox ile filtreleme ve filtreleneni silme
MAKRO KODU : Sub Filtrele() sec = InputBox("Neyi Filtrelemek İstiyorsunuz", , "Pazartesi") Range("A1:" & [A65536].End(xlUp).Address).AutoFilter 1, sec End Sub Sub FiltrleneniSil() Range("A2:" & [A65536].End(xlUp).Address).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp End Sub

inputbox la doğru rakamı girmeye zorlama

ID : 1205
ISLEM : inputbox la doğru rakamı girmeye zorlama
MAKRO KODU : Sub hesaplama() zamoranı: z = InputBox("Zam oranını giriniz ! Ondalık kısmı varsa virgülle ayırınız !") If Not IsNumeric(z) Then GoTo zamoranı Cells(1, 23) = (z + 100) / 100 End Sub

inputbox la mesaj alma

ID : 1206
ISLEM : inputbox la mesaj alma
MAKRO KODU : Sub GetInput() Dim MyInput MyInput = InputBox("Enter your name") MsgBox ("Hello ") & MyInput End Sub

inputbox yılı yaz, ayları sayfa olarak eklesin

ID : 1207
ISLEM : inputbox yılı yaz, ayları sayfa olarak eklesin
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

inputboxa göre boş satırları seçmek

ID : 1208
ISLEM : inputboxa göre boş satırları seçmek
MAKRO KODU : Sub BoslariSec() On Error Resume Next Dim x, y As Integer x = InputBox("x değerini gir") y = InputBox("y değerini de gir") Range("A1").Clear For Each sec In Range("J" & x & ":J" & y) If sec.Value = "" Then k = k + sec.Address & "," End If Next sec k = Mid(k, 1, Len(k) - 1) Range(k).Select End Sub

inputboxa göre çıktı sayısı

ID : 1209
ISLEM : inputboxa göre çıktı sayısı
MAKRO KODU : Sub Makro1() On Error Resume Next kaç = InputBox("Bu sayfadan kaç adet yazdırmak istiyorsunuz?") ActiveWindow.SelectedSheets.PrintOut Copies:=kaç, Collate:=True End Sub

inputboxa göre çıktı sayısı2

ID : 1210
ISLEM : inputboxa göre çıktı sayısı2
MAKRO KODU : Sub yazdir() ilk=inputbox("Yazdırmaya başlanacak Sayfa Numarası") son=inputbox("sonlandırılacak Sayfa Numarası") Kopyasayisi=inputbox("Kopya Sayısını Giriniz") ActiveWindow.SelectedSheets.PrintOut From:=ilk, To:=son, Copies:=Kopyasayisi, Collate:=True End Sub

inputboxla a1 e veri girme

ID : 1211
ISLEM : inputboxla a1 e veri girme
MAKRO KODU : Sub Wert_aus_inputBox_in_A1() Cells(1, 1) = InputBox("Bitte geben Sie den Wert ein, der in Zelle A1 geschrieben werden soll:") End Sub

inputbox'la bulma

ID : 1212
ISLEM : inputbox'la bulma
MAKRO KODU : Sub FindExactMatch() Dim MyStr As String, InfoMsg As String Dim Rng1 As String, LookupValue As String Dim MyQ As VbMsgBoxResult Dim FoundRng As Variant MyStr = Trim(Application.InputBox("Aranacak metni girin !", _ "Find exact match ...")) If Not MyStr = "False" Then Set FoundRng = Cells.Find(MyStr, LookIn:=xlValues, LookAt:=xlPart) If Not FoundRng Is Nothing Then Rng1 = FoundRng.Address FoundRng.Activate ResumeSub2: If Right(FoundRng.Value, 1) " " Then LookupValue = FoundRng.Value & " " MyData = Split(LookupValue, " ", , vbTextCompare) For i = LBound(MyData) To UBound(MyData) If MyData(i) = MyStr Then InfoMsg = "Aranan metin " & FoundRng.Address(False, False) _ & " hücresinde bulundu." _ & vbCrLf & vbCrLf & "Bulunan hücrenin içeriği :" _ & vbCrLf & vbCrLf & FoundRng.Value & vbCrLf _ & vbCrLf & "Aramaya devam etmek istiyormusunuz ?" MyQ = MsgBox(InfoMsg, vbInformation + vbYesNo, _ "Arama sonucu...") If MyQ = vbYes Then GoTo ResumeSub1: Exit Sub End If Next Else MsgBox "Aranan değer bulunamadı !", vbInformation, "Arama sonucu..." Exit Sub End If ResumeSub1: Set FoundRng = Cells.FindNext(FoundRng) If Rng1 = FoundRng.Address Then MsgBox "Aranan değerden başka bulunamadı !", vbInformation, _ "Arama sonucu..." Exit Sub End If FoundRng.Activate GoTo ResumeSub2: End If Set FoundRng = Nothing End Sub -

inputboxla sayfa bulma

ID : 1213
ISLEM : inputboxla sayfa bulma
MAKRO KODU : Private Sub CommandButton3_Click() On Error GoTo 10 Application.DisplayAlerts = False sor = InputBox("Silinecek sayfa adını yazınız.") If sor = "" Then Exit Sub mesaj = MsgBox("silmek istediğinizden eminmisiniz", vbYesNo) If mesaj = vbNo Then Exit Sub Sheets("" & sor).Delete Exit Sub 10 MsgBox "sayfa bulunamadı" End Sub

inputboxla sayfaya gitme

ID : 1214
ISLEM : inputboxla sayfaya gitme
MAKRO KODU : Private Sub CommandButton2_Click() On Error Resume Next Dim Sayfa As Variant Sayfa = InputBox("Sayfa Numarasını Giriniz", "UYARI", "1") Sheets(Sayfa).Select End Sub

inputboxlarda yazılanları çarpar

ID : 1215
ISLEM : inputboxlarda yazılanları çarpar
MAKRO KODU : Sub CalcPay() On Error GoTo HandleError Dim hours Dim hourlyPay Dim payPerWeek hours = InputBox("Please enter number of hours worked", "Hours Worked") hourlyPay = InputBox("Please enter hourly pay", "Pay Rate") payPerWeek = CCur(hours * hourlyPay) MsgBox "Pay is: " & Format(payPerWeek, "$##,##0.00"), , "Total Pay" HandleError: End Sub

inputboxta cancel'e değer aatmak

ID : 1216
ISLEM : inputboxta cancel'e değer aatmak
MAKRO KODU : Sub a() b = InputBox("aaaa") If b = "" Then [a1]=1 End If End Sub

inputboxta soru cevap

ID : 1217
ISLEM : inputboxta soru cevap
MAKRO KODU : Sub DecideUserInput() Dim bText As String, bNumber As Integer ' here is the INPUTBOX-function : bText = InputBox("Insert in a text", "This accepts any input") ' here is the INPUTBOX-method : bNumber = Application.InputBox("Insert a number", "This accepts numbers only", 1) MsgBox "You have inserted :" & Chr(13) & _ bText & Chr(13) & bNumber, , "Result from INPUT-boxes" End Sub ‘Accepted input: ‘0 A formula ‘1 A number ‘2 Text ‘4 A logical value (True or False) ‘8 A cell reference, e.g. a Range-object ‘16 An error value, e.g. #N/A ‘64 An array of values

inputboxta tarih formatı

ID : 1218
ISLEM : inputboxta tarih formatı
MAKRO KODU : Sub Tarihi_Kontrol_Et() vade = InputBox("Vade tarihini aa/gg/2004 Formatında Giriniz", "Lütfen Vade Kriter Tarihini Giriniz", "00.00.2004") If vbOKCancel = vbOK Then If vade = Range("A1").Text Then MsgBox "Tamam" End If End Sub

inputboxta yazılan hücreye gider

ID : 1219
ISLEM : inputboxta yazılan hücreye gider
MAKRO KODU : Sub GetRange() Dim Rng As Range On Error Resume Next Set Rng = Application.InputBox(prompt:="Enter range",Type:=8) If Rng Is Nothing Then MsgBox "Operation Cancelled" Else Rng.Select End If End Sub

internet bağlantısı olduğunda veya olmadığında raporunu word'e yazar

ID : 1220
ISLEM : internet bağlantısı olduğunda veya olmadığında raporunu word'e yazar
MAKRO KODU : Option Explicit Sub MessageAbrufen() Dim appWord As Object Dim docWord As Object Dim txt As String txt = LoadURL(Range("A1").Value) Set appWord = CreateObject("Word.Application") Set docWord = appWord.documents.Add With docWord.Range With .Font .Name = "Courier New" .Size = 8 End With .Text = txt End With appWord.Visible = True Set appWord = Nothing Set docWord = Nothing End Sub Function LoadURL(URL As String) As String Dim IEApp As Object Dim IEDocument As Object Set IEApp = CreateObject("InternetExplorer.Application") IEApp.Visible = False IEApp.Navigate URL Do: Loop Until IEApp.Busy = False Do: Loop Until IEApp.Busy = False Set IEDocument = IEApp.Document LoadURL = IEDocument.Body.innerText IEApp.Quit Set IEDocument = Nothing Set IEApp = Nothing End Function

internet sayfası açma istenilen adres

ID : 1221
ISLEM : internet sayfası açma istenilen adres
MAKRO KODU : Sub LanceIE() Dim IE As Object Set IE = CreateObject("InternetExplorer.Application") IE.Navigate "http://dj.joss.free.fr" IE.AddressBar = True IE.MenuBar = True IE.Toolbar = True IE.Width = 800 IE.Height = 600 IE.Resizable = True IE.Visible = True Set IE = Nothing End Sub

internete dial up la bağlanmak için

ID : 1222
ISLEM : internete dial up la bağlanmak için
MAKRO KODU : Private Declare Function IsNetworkAlive Lib "SENSAPI.DLL" (ByRef lpdwFlags As Long) As Long Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Boolean Private Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Boolean Const NETWORK_ALIVE_LAN = &H1 Const NETWORK_ALIVE_WAN = &H2 Sub baglan() If IsNetworkAlive(lRet) = 0 Then InternetAutodial 1, 0 End If End Sub Sub kes() If IsNetworkAlive(lRet) 0 Then InternetAutodialHangup 0 End If End Sub ‘otomatik bağlanması için de Sub baglan() If IsNetworkAlive(lRet) = 0 Then InternetAutodial 2, 0 End If End Sub ‘şifre için Call Shell("c:\windows\system32\rasdial.exe " & Chr$(34) & "ttnet" & Chr$(34) & " " & "sirenko" & " " & "sifre") -

internetten dosya indirmek

ID : 1223
ISLEM : internetten dosya indirmek
MAKRO KODU : Option Explicit Private Declare Function InternetGetConnectedState _ Lib "wininet" ( _ ByRef lpdwFlags As Long, _ ByVal dwReserved As Long) _ As Long Private Declare Function InternetAutodial _ Lib "wininet.dll" ( _ ByVal dwFlags As Long, _ ByVal dwReserved As Long) _ As Long Private Declare Function InternetAutodialHangup _ Lib "wininet.dll" ( _ ByVal dwReserved As Long) _ As Long Private Declare Function URLDownloadToFile Lib "urlmon" _ Alias "URLDownloadToFileA" ( _ ByVal pCaller As Long, _ ByVal szURL As String, _ ByVal szFileName As String, _ ByVal dwReserved As Long, _ ByVal lpfnCB As Long) _ As Long Private Const INTERNET_CONNECTION_CONFIGURED = &H40 Private Const INTERNET_CONNECTION_LAN = &H2 Private Const INTERNET_CONNECTION_MODEM = &H1 Private Const INTERNET_CONNECTION_OFFLINE = &H20 Private Const INTERNET_CONNECTION_PROXY = &H4 Private Const INTERNET_RAS_INSTALLED = &H10 Private Const INTERNET_AUTODIAL_FORCE_ONLINE = 1 Private Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2 Private Const S_OK = &H0 Private Const E_ABORT = &H80004004 Private Const E_ACCESSDENIED = &H80070005 Private Const E_OUTOFMEMORY = &H8007000E Const strDownLoad As String = "http://www.salipazari-meb.gov.tr/programlar/kayit.zip" Const strDest As String = "C:\kayit.zip" Sub GetFile() Dim DwnLoadOK As Boolean DwnLoadOK = DownloadFile(strDownLoad, strDest) If Not DwnLoadOK Then MsgBox "Error downloading " & strDownLoad & vbCr & IeState Else MsgBox "Succesfully downloaded:= " & strDest End If End Sub Public Function DownloadFile( _ URL As String, _ SaveAsFileName As String) As Boolean Dim lngRetVal As Long DownloadFile = False End Function Private Function IeState() As String Dim Ret As Long Dim Msg As String InternetGetConnectedState Ret, 0& If (Ret And INTERNET_CONNECTION_CONFIGURED) = _ INTERNET_CONNECTION_CONFIGURED Then _ Msg = "Local system has a valid connection to the Internet," & _ vbCr & "but it may or may not be currently connected." If (Ret And INTERNET_CONNECTION_LAN) = _ INTERNET_CONNECTION_LAN Then _ Msg = Msg & vbCr & "Uses a local area network" & _ "to connect to the Internet." If (Ret And INTERNET_CONNECTION_MODEM) = _ INTERNET_CONNECTION_MODEM Then _ Msg = Msg & vbCr & "A modem is used to connect to the Internet." If (Ret And INTERNET_CONNECTION_OFFLINE) = _ INTERNET_CONNECTION_OFFLINE Then _ Msg = Msg & vbCr & "Local system is in offline mode." If (Ret And INTERNET_CONNECTION_PROXY) = _ INTERNET_CONNECTION_PROXY Then _ Msg = Msg & vbCr & "Uses a proxy server to connect to the Internet." If (Ret And INTERNET_RAS_INSTALLED) = INTERNET_RAS_INSTALLED Then _ Msg = Msg & vbCr & "System has RAS installed." If Msg "" Then IeState = Msg End Function -

ip numarasi gösterecek makro

ID : 1224
ISLEM : ip numarasi gösterecek makro
MAKRO KODU : Aşağıdakileri söz konusu dosyada yeni bir module yerleştirip, kaydedin. Dosyayı kapattığınız anda 1nci sayfada A1, B1 ve C1 hücrelerinde gerekli bilgiler yazılacaktır. Kod: Private Declare Function apiGetUserName Lib _ "advapi32.dll" Alias "GetUserNameA" _ (ByVal lpBuffer As String, _ nSize As Long) _ As Long ' Sub Auto_Close() Sheets(1).Range("A1") = "Son Kullanıcı :" Sheets(1).Range("B1") = fGetUserName Sheets(1).Range("C1") = Now End Sub ' Function fGetUserName() As String Dim lngLen As Long, lngRet As Long Dim strUserName As String strUserName = String$(254, 0) lngLen = 255 lngRet = apiGetUserName(strUserName, lngLen) If lngRet Then fGetUserName = Left$(strUserName, lngLen - 1) End If End Function

ismi belirle aktif sayfayı kitap halinde kaydedip kapatsın

ID : 1225
ISLEM : ismi belirle aktif sayfayı kitap halinde kaydedip kapatsın
MAKRO KODU : Sub Blatt_als_Datei() datname = InputBox("Dateiname:") ActiveSheet.Copy ActiveWorkbook.SaveAs datname ActiveWorkbook.Close End Sub

istediğim mükerrer olanlari silmesi(satir silme olabilir)

ID : 1226
ISLEM : istediğim mükerrer olanlari silmesi(satir silme olabilir)
MAKRO KODU : denedim de, bir mantık hatası var son 2 kodda (silinen satırın yerine geçen alt satır gibi) düzeltilmiş ve biraz daha hızlandırılmışı. 1. veriler sıralı değilse Kod: z = Cells(65536, 1).End(xlUp).Row Application.ScreenUpdating = False For i = 1 To z For j = z To i + 1 Step -1 If Cells(i, 1) = Cells(j, 1) Then Range(j & ":" & j).EntireRow.Delete End If Next j Next i 2. veriler sıralı ise Kod: z = Cells(65536, 1).End(xlUp).Row Application.ScreenUpdating = False For i = 1 To z For j = z To i + 1 Step -1 If Cells(i, 1) = Cells(j, 1) Then Range(j & ":" & j).EntireRow.Delete Else Exit For End If Next j Next i

istediğiniz sayfa hariç sayfadaki verileri temizler

ID : 1227
ISLEM : istediğiniz sayfa hariç sayfadaki verileri temizler
MAKRO KODU : Sub Sayfalarısıfırla() '/_ 'İstediğiniz sayfa hariç diğer sayfadaki verileri temizler 'a.küçükkaya / pir Dim i As Integer For i = 1 To Sheets.Count If Worksheets(i).Name "Rapor" Then Worksheets(i).Cells.Delete Selection.Style = "Normal" 'hücreyi reset eder yani ilk açılıştaki haline çevirir End If Next i End Sub Resimleri de silmek için ilave edin For j = 1 To Shapes.Count Shapes(j).Delete Next j -

istediğiniz sayfaya gider

ID : 1228
ISLEM : istediğiniz sayfaya gider
MAKRO KODU : İstediğiniz sayfaya gider Sub Ali_sayfasına_git() Sheets("ALİ").Select End Sub Sonraki Sayfaya geçmek için kodlar Sub SayfaSeçSonraki() On Error Resume Next If ActiveSheet.Index = Worksheets.Count Then Worksheets(1).Select Else On Error Resume Next Worksheets(ActiveSheet.Index + 1).Select End If End Sub Önceki Sayfaya geçmek için kodlar Sub SayfaSeçÖnceki() On Error Resume Next If ActiveSheet.Index = Worksheets.Count Then Worksheets(-1).Select Else Worksheets(ActiveSheet.Index - 1).Select End If End Sub

istediğiniz sayfaya gider

ID : 1229
ISLEM : istediğiniz sayfaya gider
MAKRO KODU : İSTEDİĞİNİZ SAYFAYA GİDER Sub Ali_sayfasına_git() Sheets("ALİ").Select End Sub Sonraki Sayfaya geçmek için kodlar Sub SayfaSeçSonraki() On Error Resume Next If ActiveSheet.Index = Worksheets.Count Then Worksheets(1).Select Else On Error Resume Next Worksheets(ActiveSheet.Index + 1).Select End If End Sub Önceki Sayfaya geçmek için kodlar Sub SayfaSeçÖnceki() On Error Resume Next If ActiveSheet.Index = Worksheets.Count Then Worksheets(-1).Select Else Worksheets(ActiveSheet.Index - 1).Select End If End Sub

istediğiniz yerde istediğiniz uyarıyı verdirin

ID : 1230
ISLEM : istediğiniz yerde istediğiniz uyarıyı verdirin
MAKRO KODU : Sub assist() Application.Assistant.Visible = True Assistant.Animation = msoAnimationIdle Set SB = Assistant.NewBalloon SB.Animation = msoAnimationCheckingSomething SB.BalloonType = msoBalloonTypeButtons SB.Heading = "istediğiniz uyarı!!" SB.Text = _ "Ich bin Dein persönlicher Assistent" If SB.Show = msoBalloonButtonOK Then Assistant.Visible = False End If end sub

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