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


yılı yaz sayfalara ayları ekler

ID : 2521
ISLEM : yılı yaz sayfalara ayları ekler
MAKRO KODU : 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 -

yukarıdan aşağıya satırları seç otomatik sıra numarası versin

ID : 2522
ISLEM : yukarıdan aşağıya satırları seç otomatik sıra numarası versin
MAKRO KODU : Sub NumberClients() Dim c As Range Dim j As Integer If Selection.Columns.Count > 1 Then MsgBox "Only select the cells you want numbered" Exit Sub End If j = 0 For Each c In Selection If Not c.Rows.Hidden Then j = j + 1 c.Value = j Else c.Clear End If Next c End Sub

yuvarla makroyla (r1c1 stili) nasil yapilir?

ID : 2523
ISLEM : yuvarla makroyla (r1c1 stili) nasil yapilir?
MAKRO KODU : Sub Doldur() Dim i As Integer [F1].FormulaR1C1 = "=ROUND(RC[-3],2)" For i = 2 To 1000 Cells(i, 6).Select Selection.FillDown Next i End Sub

yuvarlak userform istermisiniz

ID : 2524
ISLEM : yuvarlak userform istermisiniz
MAKRO KODU : Option Explicit Private Declare Function CreateRoundRectRgn Lib "gdi32" _ (ByVal X1 As Long, ByVal Y1 As Long, _ ByVal X2 As Long, ByVal Y2 As Long, _ ByVal X3 As Long, ByVal Y3 As Long) As Long Private Declare Function SetWindowRgn Lib "user32" _ (ByVal hWnd As Long, ByVal hRgn As Long, _ ByVal bRedraw As Boolean) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 'CommandButton auf der Form plazieren, da das 'x' zum schließen 'nicht mehr angezeigt wird. Private Sub cmdEnde_Click() Unload Me End Sub Private Sub UserForm_Initialize() 'Größe der Userform Me.Width = 350: Me.Height = 350 'Position des CommandButton zum Abbrechen cmdEnde.Left = (Me.Width - cmdEnde.Width) / 3 cmdEnde.Top = Me.Height * 0.6 End Sub Private Sub UserForm_Activate() Dim x As Long, y As Long, n As Long, mWnd As Long x = Me.Width y = Me.Height n = 4000 'bei kleinem Wert nur abgerundete Ecken mWnd = FindWindow(vbNullString, Me.Name) SetWindowRgn mWnd, CreateRoundRectRgn(0, 0, x, y, n, n), True End Sub

yuvarlak userform istermisiniz

ID : 2525
ISLEM : yuvarlak userform istermisiniz
MAKRO KODU : Option Explicit Private Declare Function CreateRoundRectRgn Lib "gdi32" _ (ByVal X1 As Long, ByVal Y1 As Long, _ ByVal X2 As Long, ByVal Y2 As Long, _ ByVal X3 As Long, ByVal Y3 As Long) As Long Private Declare Function SetWindowRgn Lib "user32" _ (ByVal hWnd As Long, ByVal hRgn As Long, _ ByVal bRedraw As Boolean) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 'CommandButton auf der Form plazieren, da das 'x' zum schließen 'nicht mehr angezeigt wird. Private Sub cmdEnde_Click() Unload Me End Sub Private Sub UserForm_Initialize() 'Größe der Userform Me.Width = 350: Me.Height = 350 'Position des CommandButton zum Abbrechen cmdEnde.Left = (Me.Width - cmdEnde.Width) / 3 cmdEnde.Top = Me.Height * 0.6 End Sub Private Sub UserForm_Activate() Dim x As Long, y As Long, n As Long, mWnd As Long x = Me.Width y = Me.Height n = 4000 'bei kleinem Wert nur abgerundete Ecken mWnd = FindWindow(vbNullString, Me.Name) SetWindowRgn mWnd, CreateRoundRectRgn(0, 0, x, y, n, n), True End Sub

yüklü yazıcı var mı yok mu

ID : 2526
ISLEM : yüklü yazıcı var mı yok mu
MAKRO KODU : Private Sub UserForm_Activate() On Local Error GoTo hata Show Print "kağıt kaynağı"; Printer.PaperBin Print "renk modu"; Printer.ColorMode Print "kopya sayısı"; Printer.Copies Print "Yazıcının ismi"; Printer.DeviceName Print "sürücü"; Printer.DriverName Print "çift yönlü yazma"; Printer.Duplex Print "yataylık-dikeylik"; Printer.Orientation Print "sayfa boyutu"; Printer.PaperSize Print "kullanılan port"; Printer.Port Print "basım kalitesi"; Printer.PrintQuality Print "yazıcı varsayılan mı"; Printer.TrackDefault Print "ölçekleme"; Printer.Zoom hata: MsgBox ("yüklü bir yazıcı yok veya yazınız açık değil") End Sub

yüklü yazıcı var mı yok mu 2

ID : 2527
ISLEM : yüklü yazıcı var mı yok mu 2
MAKRO KODU : Sub Test() Dim Impr Impr = Printer If IsEmpty(Impr) Then MsgBox "No Printer", vbCritical Else Application.ScreenUpdating = False Application.ThisWorkbook.Activate With Range("A1").Resize(UBound(Impr)) .Value = WorksheetFunction.Transpose(Impr) .Sort [A1] End With Columns(1).AutoFit End If End Sub

yüzde hesaplama

ID : 2528
ISLEM : yüzde hesaplama
MAKRO KODU : Sub Zam5() Dim i As Range For Each i In Range("D1:D1000") i = "=(RC[-1]*0.05)+RC[-1]" Next i End Sub Sub Zam10() Dim i As Range For Each i In Range("E1:E1000") i = "=(RC[-2]*0.1)+RC[-2]" Next i End Sub

zaman kaydırma silerek

ID : 2529
ISLEM : zaman kaydırma silerek
MAKRO KODU : Sub donen_tarih() Dim C As Range Dim i% Set C = ActiveCell For i = 1 To 2000 C = Right(C, Len(C.Value) - 1) + Left(C, 1) Application.Wait Now + TimeSerial(0, 0, 1) Next i End Sub

zaman sayaci

ID : 2530
ISLEM : zaman sayaci
MAKRO KODU : Eğer yüksek performanslı bir sayaç gerekli değilse; 1) A1 hücresinde 0-60 saniye saydıktan sonra durması için: Kod: Sub Test1() Start = Timer Do DoEvents Finnish = Timer [a1] = Format(Finnish - Start, "00") Loop While Finnish - Start -

zamanlamalı userform

ID : 2531
ISLEM : zamanlamalı userform
MAKRO KODU : Private Sub UserForm_Activate() Application.OnTime Now + TimeValue("00:00:05"), "KillTheForm" End Sub

zamanlamalı userform 2

ID : 2532
ISLEM : zamanlamalı userform 2
MAKRO KODU : ThisWorkbook a yazılacak Private Sub Workbook_Open() UserForm1.Show End Sub 'Module e yazılacak Sub KapatForm1() ' zaman 10 saniye olarak ayarlandı Application.OnTime Now + TimeValue("00:00:10"), "KF1" End Sub Sub KF1() UserForm1.Hide UserForm2.Show End Sub 'UserForm1 kod sayfasına yazılacak Private Sub UserForm_Activate() KapatForm1 End Sub

zamanlanmis makro ontime ?

ID : 2533
ISLEM : zamanlanmis makro ontime ?
MAKRO KODU : Sub tarih() Application.OnTime Now + [a1], procedure:="zaman" End Sub Sub zaman() Application.OnTime TimeValue("12:00:00"), "makro"' End Sub

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