|
EXCEL Size Yeter |
|
İletişim |
|
Ulaşım bilgilerimiz aşağıda yer almaktadır. Ulaşım konusunda mail yöntemini tercih etmeniz daha uygun olacaktır. Dilediğiniz şekilde bize soru sorabilirsiniz. |
|
= msg & vbCrLf & ""Total: "" & Selection.Count MsgBox (msg) End Sub Function SUMIFCOLOUR(TheRange As Range, TheColourCell As Range) As Variant Dim TempRange As Range Dim Result Dim Colour Application.Volatile On Error GoTo BailOut Colour = TheColourCell.Interior.Color For Each TempRange In TheRange If Colour = TempRange.Interior.Color Then Result = Result + TempRange.Value Next BailOut: SUMIFCOLOUR = Result End Function Function COUNTIFCOLOUR(TheRange As Range, TheColourCell As Range) As Varian Dim TempRange As Range Dim Result Dim Colour Application.Volatile On Error GoTo BailOut Colour = TheColourCell.Interior.Color For Each TempRange In TheRange If Colour = TempRange.Interior.Color Then Result = Result + 1 Next BailOut: COUNTIFCOLOUR = Result End Function" Renk seçenekleri penceresi "Sub Dialog_12() Application.Dialogs(xlDialogColorPalette).Show End Sub" Renklendirilmiş hücreler harici satırları gizleme "Option Explicit Sub macro1() Dim i As Long Dim j As Long Dim sVal Dim bHide As Boolean j = 65000 For i = 1 To j If j < 0 Then Exit For bHide = False 'sVal = Trim(Range(""I"" & i).Value) sVal = Range(""I"" & i).Select If Selection.Interior.ColorIndex <> 36 Then bHide = True End If If bHide Then Rows(i & "":"" & i).Select Range(""A"" & i).Activate Selection.EntireRow.Hidden = True j = j - 1 End If Next i End Sub" Renkleri listeleme "Sub RenkleriListele() For i = 1 To 56 With Cells(i, 1) .Interior.ColorIndex = i ' Dolgu Rengi .Font.ColorIndex = 3 'Yazıtipi rengini 3 yazdık kırmızı yani ama istersen VbRed şeklinde de yazabilirdik .HorizontalAlignment = xlCenter ' Yazıyı ortala .Value = i 'Hücrenin içine renk kodunu yaz End With Next i End Sub" Renkli hücreleri saysın "Sub CountColor() Dim irow, icol As Integer Cells(1, 1) = 0 For irow = 1 To 20 For icol = 1 To 10 If Cells(irow, icol).Interior.ColorIndex _ <> xlColorIndexNone Then Cells(1, 1) = Cells(1, 1) + 1 End If Next icol Next irow End Sub" Renkli hücreleri toplama "Function SumIfColours(cellTextColour As Integer, _ Range1, ParamArray Range2()) As Double Dim objCell As Range ' Best to use this even if it does ' slow Excel down somewhat. Application.Volatile ' Initialise. SumIfColours = 0 ' Process first argument. ' Restrict the range to stop the loop looking ' at huge swathes of empty cells. For Each objCell In Intersect(Range1, _ Range1.Parent.UsedRange) If Application.IsNumber(objCell.Value) And _ objCell.Interior.ColorIndex = cellTextColour Then _ SumIfColours = SumIfColours + objCell.Value Next objCell ' Process additional arguments (if any) If UBound(Range2) <> 0 Then For intArgument = 1 To UBound(Range2) For Each objCell In Intersect(Range2(intArgument), _ Range2(intArgument).Parent.UsedRange) If Application.IsNumber(objCell.Value) And _ objCell.Interior.ColorIndex = cellTextColour Then _ SumIfColours = SumIfColours + objCell.Value Next objCell Next intArgument End If End Function" Renkli hücreleri toplama 2 "D21 veya A1:D20 hücreleri dışında bir hücreye aşağıdaki fürmülü yazın. =SumIfColours(3;$A$1:$D$20)" Renkli hücreye sadece rakam girme: msgbox "Aşağıdaki kodu aktif sayfaya yapıştırınız Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim myRange As Range Dim intLowerlimit As Integer Dim intUpperlimit As Integer Set myRange = Range(""A2:B5,D6:E8"") ' Sınırları yazın intLowerlimit = 1 ' istediğiniz alt limit intUpperlimit = 8 ' istediğiniz ust limit If Not Intersect(Target, myRange) Is Nothing Then If Not IsNumeric(Target.Value) Then MsgBox (""Sadece rakam girebilirsiniz!"") Cells(Target.Row, 6).Value = ""Rakam değil!"" Cells(Target.Row, 6).Font.Color = RGB(255, 0, 0) ElseIf Not (Target.Value / 1 = Target.Value \ 1) Then MsgBox (""Geçerli değil"") Cells(Target.Row, 6).Value = ""Dogru degil"" Cells(Target.Row, 6).Font.Color = RGB(255, 0, 0) ElseIf Target.Value < intLowerlimit Then MsgBox (""Sayı limit altında!1-8 arası olması gerekiyor "" _ & intLowerlimit & "" ve "" & intUpperlimit) Cells(Target.Row, 6).Value = ""Limit altında"" Cells(Target.Row, 6).Font.Color = RGB(255, 0, 0) ElseIf Target.Value > intUpperlimit Then MsgBox (""Sayı ust limitten fazla! "" _ & intLowerlimit & "" and "" & intUpperlimit) Cells(Target.Row, 6).Value = ""Sayı limit değeri ustunde!"" Cells(Target.Row, 6).Font.Color = RGB(255, 0, 0) Else Cells(Target.Row, 6).Value = ""Dogru"" Cells(Target.Row, 6).Font.Color = RGB(0, 255, 0) End If End If End Sub " Renkli hücreye şifreli giriş (sarı) "Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Dim pw As String If Target.Column = 3 And Target.Row = 2 Or Target.Row = 5 Then ' C2 ve C5 i sarı yap pw = InputBox(""Bitte Passwort eingeben !"") If pw <> ""pir"" Then Range(""a1"").Select Exit Sub Else End If End If End Sub" Resim çekmek (printscreen) "Option Explicit Declare Sub keybd_event Lib ""user32"" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Sub Command1_Click() Call keybd_event(vbKeySnapshot, 0, 0, 0) ' Hali hazırda bulunan ekranın fotoğrafını yakaladı DoEvents ' Clipboarda Çekilen Resmin Kopyalanması için Bilgisayarı beklet End Sub" Resim ekleme penceresi "Sub Dialog_42() Application.Dialogs(xlDialogInsertPicture).Show End Sub" Resim ekletme mecburi dizin "Sub insertImg() Dim fichImg fichImg = Application.GetOpenFilename(""Fichier image(*.gif;*.jpg;*.bmp),*.gif;*.jpg;*.bmp"" _ , , ""Choix de l'image"", , False) 'false selection simple If fichImg = False Then Exit Sub ActiveSheet.Pictures.Insert(fichImg).Select End Sub" Resmi kopyala penceresi "Sub Dialog_16() Application.Dialogs(xlDialogCopyPicture).Show End Sub" Resmin yarısını gizleme ve gösterme "Sub Grafikteil_ausblenden() ActiveSheet.Shapes(""Picture 1"").Select Selection.ShapeRange.PictureFormat.Brightness = 0.5 Selection.ShapeRange.PictureFormat.Contrast = 0.5 Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic Selection.ShapeRange.PictureFormat.CropLeft = 0# Selection.ShapeRange.PictureFormat.CropRight = 0# Selection.ShapeRange.PictureFormat.CropTop = 0# Selection.ShapeRange.PictureFormat.CropBottom = 0# Range(""A1"").Select End Sub Sub Grafikteil_einblenden() ActiveSheet.Shapes(""Picture 1"").Select Selection.ShapeRange.PictureFormat.Brightness = 0.5 Selection.ShapeRange.PictureFormat.Contrast = 0.5 Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic Selection.ShapeRange.PictureFormat.CropLeft = 0# Selection.ShapeRange.PictureFormat.CropRight = 0# Selection.ShapeRange.PictureFormat.CropTop = 0# Selection.ShapeRange.PictureFormat.CropBottom = 34.02 Range(""A1"").Select End Sub" Rgb kodları ile hücreyi renklendirme "Sub CouleurRGB() Range(""a1"").Interior.Color = RGB(0, 0, 0) Range(""a2"").Interior.Color = RGB(255, 0, 0) End Sub" Saat farkı hesaplatma "Sub MASA1() Cells(3, 3) = ""=NOW()"" Cells(3, 3).Select Selection.NumberFormat = ""h:mm"" Cells(3, 4) = Cells(3, 3).Value - Cells(3, 2).Value Range(""E1"").Select End Sub" Saat formatı "sub saat () Do Range(""a1"") = Format(Now(), ""dd mm yyyy"") Range(""a2"") = Format(Now(), ""hh:mm:ss"") DoEvents Loop End Sub" Saat tarih fonksiyonları "LABEL KUTULARINA SAAT&TARİH EKLER Private Sub tarih_Click() Label1.Caption = time Label2.Caption = Date End Sub 'TARİH&SAAT'İ AYNI ANDA GÖSTERİR. Private Sub Label3_Click() Label1.Caption = Now() End Sub " Saat tarİh fonksİyonlari "LABEL KUTULARINA SAAT&TARİH EKLER Private Sub tarih_Click() Label1.Caption = time Label2.Caption = Date End Sub 'TARİH&SAAT'İ AYNI ANDA GÖSTERİR. Private Sub Label3_Click() Label1.Caption = Now() End Sub " Saati menü olarak ekleme "Option Explicit Private Declare Function FindWindow _ Lib ""user32"" _ Alias ""FindWindowA"" _ ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String _ ) _ As Long Private Declare Function SetTimer _ Lib ""user32"" _ ( _ ByVal hWnd As Long, _ ByVal nIDEvent As Long, _ ByVal uElapse As Long, _ ByVal lpTimerFunc As Long _ ) _ As Long Private Declare Function KillTimer _ Lib ""user32"" _ ( _ ByVal hWnd As Long, _ ByVal nIDEvent As Long _ ) _ As Long Private Declare Function GetCurrentVbaProject _ Lib ""vba332.dll"" _ Alias ""EbGetExecutingProj"" _ ( _ hProject As Long _ ) _ As Long Private Declare Function GetFuncID _ Lib ""vba332.dll"" _ Alias ""TipGetFunctionId"" _ ( _ ByVal hProject As Long, _ ByVal strFunctionName As String, _ ByRef strFunctionID As String _ ) _ As Long Private Declare Function GetAddr _ Lib ""vba332.dll"" _ Alias ""TipGetLpfnOfFunctionId"" _ ( _ ByVal hProject As Long, _ ByVal strFunctionID As String, _ ByRef lpfnAddressOf As Long _ ) _ As Long Private WindowsTimer As Long Private ClockCBControl As CommandBarButton Sub StartClockinMenu() Set ClockCBControl = _ Application.CommandBars(1).Controls.Add( _ Type:=msoControlButton, Temporary:=True) ClockCBControl.Style = msoButtonCaption ClockCBControl.Caption = Format(Now, ""Long Time"") fncWindowsTimer 1000 End Sub Sub StopClockinMenu() fncStopWindowsTimer ClockCBControl.Delete End Sub Private Function fncWindowsTimer( _ TimeInterval As Long _ ) As Boolean Dim WindowsTimer As Long WindowsTimer = 0 If Val(Application.Version) > 8 Then WindowsTimer = SetTimer _ ( _ hWnd:=FindWindow(""XLMAIN"", Application.Caption), _ nIDEvent:=0, _ uElapse:=TimeInterval, _ lpTimerFunc:=AddrOf_cbkCustomTimer _ ) Else WindowsTimer = SetTimer _ ( _ hWnd:=FindWindow(""XLMAIN"", Application.Caption), _ nIDEvent:=0, _ uElapse:=TimeInterval, _ lpTimerFunc:=AddrOf(""cbkCustomTimer"") _ ) End If fncWindowsTimer = CBool(WindowsTimer) End Function Private Function fncStopWindowsTimer() KillTimer _ hWnd:=FindWindow(""XLMAIN"", Application.Caption), _ nIDEvent:=WindowsTimer End Function Private Function cbkCustomTimer _ ( _ ByVal Window_hWnd As Long, _ ByVal WindowsMessage As Long, _ ByVal EventID As Long, _ ByVal SystemTime As Long _ ) _ As Long Dim CurrentTime As String On Error Resume Next ClockCBControl.Caption = Format(Now, ""Long Time"") End Function Private Function AddrOf _ ( _ CallbackFunctionName As String _ ) _ As Long Dim aResult As Long Dim CurrentVBProject As Long Dim strFunctionID As String Dim AddressOfFunction As Long Dim UnicodeFunctionName As String UnicodeFunctionName = StrConv(CallbackFunctionName, vbUnicode) If Not GetCurrentVbaProject(CurrentVBProject) = 0 Then aResult = GetFuncID _ ( _ hProject:=CurrentVBProject, _ strFunctionName:=UnicodeFunctionName, _ strFunctionID:=strFunctionID _ ) If aResult = 0 Then aResult = GetAddr _ ( _ hProject:=CurrentVBProject, _ strFunctionID:=strFunctionID, _ lpfnAddressOf:=AddressOfFunction _ ) If aResult = 0 Then AddrOf = AddressOfFunction End If End If End If End Function Private Function AddrOf_cbkCustomTimer() As Long AddrOf_cbkCustomTimer = vbaPass(AddressOf cbkCustomTimer) End Function Private Function vbaPass(AddressOfFunction As Long) As Long vbaPass = AddressOfFunction End Function Sub StartClock() StartClockinMenu End Sub Sub StopClock() StopClockinMenu End Sub" Saati saniyeye çevirme "Private Sub CommandButton1_Click() TextBox3 = Hour(TextBox2) * 3600 + Minute(TextBox2) * 60 + Second(TextBox2) End Sub" Saati ve tarihi öğrenme "Sub Datum() Dim tag Dim uhr tag = Date uhr = Time MsgBox ""Heute ist der "" & Date & "","" & Chr$(13) & Chr$(13) & "" es ist "" & Time & "" Uhr."", vbOKOnly, ""www.excel-lex.de.vu"" End Sub" Sadece a1 hücresinin yazdırılması "Sub Druck_Bestimmte_Seite() ActiveWindow.View = xlPageBreakPreview Dim seitenzahl As String seitenzahl = InputBox("" Geben Sie die Nr. der"" & Chr(13) & Chr(13) & ""auszudruckenden Seite ein:"", ""Seitenzahl eingeben"") If seitenzahl = """" Then MsgBox ""Keine Seite ausgewählt"" Exit Sub Else ActiveWindow.SelectedSheets.PrintOut From:=seitenzahl, To:=seitenzahl, Copies:=1, Collate _ :=True ActiveWindow.View = xlNormalView End If End Sub" Sadece harf veya rakam girme "Private Sub TextBox1_Change() If Not (IsNumeric(TextBox1)) Then SendKeys ""{bs}"" End Sub Private Sub TextBox2_Change() If Right(TextBox2, 1) Like ""[0-9]"" Then SendKeys ""{bs}"" End Sub " Sadece hücredeki değerleri silme "Sub Makro1() x = WorksheetFunction.CountA(Range(""A1:A65000"")) For a = 1 To x b = Cells(a, 1).Value For c = a + 1 To x d = Cells(c, 1).Value If b = d Then Cells(c, 1).ClearContents End If Next c Next a End Sub " Sadece rakam girme "Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If KeyAscii <> 8 Then 'Allow BACKSPACE through 'Only digits are valid characters. If Chr(KeyAscii) < ""0"" Or Chr(KeyAscii) > ""9"" Then KeyAscii = 0 'Set character to null if out of range Beep End If End If End Sub" Sadece yazılı alandan aşağı doğru yazdırma alanı seçilir, tek hücre bile olsa "Sub print_area() Range(ActiveCell, ActiveCell.End(xlDown)).Select ActiveSheet.PageSetup.PrintArea = ActiveCell.CurrentRegion.Address End Sub" Sağ fare yasak belli hücrelerde "Sayfanın kod bölümüne Option Explicit Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) ' * '* pir * '* 07.10.2005 * ' ** ****** Dim Bereich As Range Dim Z Set Bereich = Range(""B3:C20"") If Intersect(Target, Bereich) Is Nothing Then Exit Sub ' Abbruch, wenn Aktion nicht im Zielbereich If Target.Interior.ColorIndex = 3 Then Target.Interior.ColorIndex = xlNone Else Target.Interior.ColorIndex = 3 End If Cancel = True End Sub" Sağ fareye kolay menü "Sub Kontextmenü_Tabellenreiter_ergaenzen() With CommandBars(""Ply"").Controls.Add .FaceId = 14 .Caption = ""Russis neuer Eintrag"" .OnAction = ""MeinMakro"" End With End Sub Veya Sub Kontextmenü_ergänzen() Dim Mb As CommandBarControl Set Mb = Application.CommandBars(""Cell"").Controls.Add With Mb .Caption = ""Mein Menüeintrag"" .FaceId = 49 .OnAction = ""Mein_Makro"" .BeginGroup = True End With End Sub Sub Mein_Makro() MsgBox (""asdasd"") End Sub Her 2 Menüyü de silme Sub Kontextmenü_Tabellenreiter_zuruecksetzen() CommandBars(""Ply"").Reset End Sub Sub Kontextmenü_zurücksetzen() Application.CommandBars(""Cell"").Reset End Sub" Sağ fareye menü "Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean) Set pir = Application.ShortcutMenus(xlWorksheetCell).MenuItems(""ToolBar"") With pir .OnAction = ""makro"" End With End Sub Sub makro() Selection.PasteSpecial Paste:=xlValues End Sub" Sağ fareye menüsüne ekleme "Sub CreationMenuContext() With Application.CommandBars(""Cell"").Controls.Add(msoControlButton) .Caption = ""Avez-vous un chat?"" .BeginGroup = True .OnAction = ""Question"" End With End Sub Sub Question() MsgBox (""Oui !"") End Sub Sub delMenuContext() Application.CommandBars(""Cell"").Reset End Sub" Sağ klik yapinca 3 tane ok çikiyor bunu silemiyorum "Sub PanZehir() CommandBars(""Cell"").Reset End Sub " Sağ ok yön tuşu ile textbox atlama "Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 39 Then Me.TextBox2.SetFocus End Sub" Sağ üstbilgiye tarih ekleme "Sub HeaderDate() ActiveSheet.PageSetup.RightHeader = Format(Date, ""m/d/yy"") End Sub" SaĞdan kelİme alma "Ayırdığınız Kelimeyi Silmek istiyorsanız..Yani ""Ahmet Eve Geldi Yemek değil""Kelimesinden ""değil""kelimesini çıkarıp silmek istorsanız. Kod: Sub ayır() For i = 1 To Cells(65536, 1).End(xlUp).Row a = Split(Cells(i, 1), "" "") For j = 0 To UBound(a) - 1 Cells(i, 4) = Cells(i, 4) Next j Cells(i, 3) = a(UBound(a)) Range(""c1"").Select Selection.ClearContents Next i End Sub Kodları iyi incelerseniz C1'yazılan yer Kod: Cells(i, 3) = a(UBound(a)) " Sağdan ve soldan ilk boşluklu harf ve harf gruplarını bulma "‘thisworkbook a yazın ve A1 hücresinde “=pir(A1) veya =pir2(A1) yazın Function pir(Mahmut) For I = 0 To Len(Mahmut) - 1 Verkehrt = Verkehrt & Mid(Mahmut, _ Len(Mahmut) - I, 1) Next I pir = Right(Mahmut, InStr(1, _ Verkehrt, "" "", 0)) End Function Function pir2(Bayram) For I = 0 To Len(Bayram) - 1 Verkehrt = Verkehrt & Mid(Bayram, _ Len(Bayram) - I, 1) Next I pir2 = Left(Bayram, InStr(1, _ Verkehrt, "" "", 0)) End Function" Satır ekleme 32 adet "Sub strekle() Set s1 = Sheets(""Sayfa2"") For i = 1 To 12100 s1.Cells(i, 1).Activate s1.Rows(i + 1 & "":"" & i + 32).Select Selection.Insert Shift:=xlDown i = i + 32 Next i End Sub" Satır gizleme 6 şar satır atlayarak "Sub gizle() Dim pir As Integer For pir = 11 To 306 Step 6 Rows(pir).EntireRow.Hidden = Not Rows(pir).EntireRow.Hidden Next pir End Sub" Satır gizleme ikinci tıklamada çözülür "Sub blenden() Dim Loi As Integer For Loi = 11 To 306 Step 6 Rows(Loi).EntireRow.Hidden = Not Rows(Loi).EntireRow.Hidden Next Loi End Sub" Satır seçme "Sub MehrereZeilenMarkieren() Range(""1:1,3:3,5:5,9:9,11:11"").Select End Sub" Satır sıralama son satıra kadar "Sub sonsatırakadarsırala() sonsatir = Range(""a1"").End(xlDown).Row Range(Cells(1, 1), Cells(sonsatir, 2)).Select Selection.Sort _ Key1:=Worksheets(""Sheet1"").Columns(""A""), _ Header:=xlGuess End Sub" Satır sıralama tüm sütuna kadar "Sub Tumsutuna_Kadar_Sırala() Columns(""A:b"").Select Selection.Sort Key1:=Range(""A1""), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal End Sub" Satır sıralama yandaki satırla birlikte "Sub Makro1() Columns(""A:A"").Select Range(""A1:B4"").Sort Key1:=Range(""A1""), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Range(""B1"").Select End Sub" Satır sıralama yandaki satırla birlikte 2 "Sub Makro1() Columns(""A:A"").Select Range(""A1:B4"").Sort Key1:=Range(""A1"") End Sub" Satır sütun başlaıklarını gizle-göster "Sub MsqEntetLigCol() 'masque les en-têtes de ligne et colonne ActiveWindow.DisplayHeadings = False End Sub Sub EntetLigCol() 'affiche les en-têtes de ligne et colonne ActiveWindow.DisplayHeadings = True End Sub" Satır sütun gizleme 1 "Boş olan Satırları Gizle Sub satirgizle() Dim i As Integer For i = 1 To 15 If Sheets(""Sayfa1"").Cells(i, 1).Value <> """" Then Rows(i).Hidden = False Else Sheets(""Sayfa1"").Rows(i).Hidden = True End If Next i End Sub A Sütunundaki Boş Satırları Gizler 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 End Sub C Sütunundaki Boş Satırları Gizler Sub bidahabossatgizle() For i = 6 To 160 If Range(""c"" & i) = """" Then _ Range(""c"" & i).EntireRow.Hidden = True Next Boş olan Sütunlar Gizle Sub satirgizle() Dim i As Integer For i = 1 To 15 If Sheets(""Sayfa1"").Cells(i, 1).Value <> """" Then Rows(i).Hidden = False Else Sheets(""Sayfa1"").Rows(i).Hidden = True End If Next i End Sub Toplamları Sıfıra eşit olan satırları gizler Sub sıfırgizle() For Each rngRow In ActiveSheet.UsedRange.Rows If Application.Sum(rngRow) = 0 Then rngRow.EntireRow.Hidden = True End If Next rngRow End Sub " Satır sütun gizleme 2 "Sub HideRowsandColumns() Dim LastRow As Object Dim LastColumn As Object Set LastRow = Range(Range(""A65536""), Range(""A65536"").End(xlUp).Offset(1, 0)) Set LastColumn = Range(Range(""IV1""), Range(""IV1"").End(xlToLeft).Offset(0, 1)) LastRow.EntireRow.Hidden = True LastColumn.EntireColumn.Hidden = True End Sub" Satır ve sütun genişliği "Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range Set rng = Columns(""C:C"") If Not (Intersect(Target, rng) Is Nothing) Then rng.ColumnWidth = 30 Else rng.ColumnWidth = 10.71 End If End Sub" Satır ve sütun genişliğini siz belirleyin "Sub zeilenhoehe() Dim hoehe As Single, aktuell As Single, text As String, antwort As String aktuell = Selection.RowHeight / 29.5 text = ""Aktuelle Zeilenhöhe: "" & Format(aktuell, ""###0.00 cm"") & Chr(13) & ""Geben Sie die gewünschte Zeilenhöhe für die aktuelle Zeile oder Markierung in cm ein:"" antwort = InputBox(text, ""Neue Zeilenhöhe festlegen"", Format(aktuell, ""###0.00"")) If antwort <> """" Then hoehe = CSng(antwort) Selection.RowHeight = hoehe * 29.5 End If End Sub Sub spaltenbreite() Dim breite As Single, aktuell As Single, text As String, antwort As String aktuell = (Selection.ColumnWidth + 0.71) / 5.1425 text = ""Aktuelle Spaltenbreite: "" & Format(aktuell, ""###0.00 cm"") & Chr(13) & ""Geben Sie die gewünschte Spaltenbreite für die aktuelle Spalte oder Markierung in cm ein:"" antwort = InputBox(text, ""Neue Spaltenbreite festlegen"", Format(aktuell, ""###0.00"")) If antwort <> """" Then breite = CSng(antwort) Selection.ColumnWidth = -0.71 + 5.1425 * breite End If End Sub" Satır ve sütunla ilgili bir makro "Sub Test() MsgBox FilteredRowsCount(ActiveSheet) & "" data was found."" MsgBox FilteredRowsCount2(ActiveSheet) & "" data was found."" End Sub Function FilteredRowsCount(ByVal Sh As Worksheet) Dim Target As Range Dim c As Range Dim i As Long 'If the Filter is not used If Sh.FilterMode = False Then FilteredRowsCount = 0 Exit Function End If Set Target = Sh.AutoFilter.Range For Each c In Target.SpecialCells(xlCellTypeVisible).Areas i = i + c.Rows.Count Next FilteredRowsCount = i - 1 '-1 stands for remove header row End Function Function FilteredRowsCount2(ByVal Sh As Worksheet) Dim Target As Range 'If the Filter is not used If Sh.FilterMode = False Then FilteredRowsCount2 = 0 Exit Function End If Set Target = Sh.AutoFilter.Range FilteredRowsCount2 = _ Target.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 End Function" Satır ve sütunlar cm olarak ayarlayın "Sub satir() Dim yukseklik As Single, mevcut As Single, text As String, cevap As String 'mevcut satır yüksekliğini bul mevcut = Selection.RowHeight / 29.5 'mesaj içriğini hazırla text = ""Mevcut satır yüksekliği: "" & Format(mevcut, ""###0.00 cm"") & Chr(13) & ""Yeni satır yüksekliğini girin (cm):"" 'InputBox göster cevap = InputBox(text, ""Yeni satır yüksekliği belirle"", Format(mevcut, ""###0.00"")) 'cevaba göre yeni satır yüksekliği değiştir If cevap <> """" Then yukseklik = CSng(cevap) Selection.RowHeight = yukseklik * 29.5 End If End Sub Sub sutun() Dim genislik As Single, mevcut As Single, text As String, cevap As String 'mevcut sütun genişliğini bul mevcut = (Selection.ColumnWidth + 0.71) / 5.1425 'mesaj içriğini hazırla text = ""Mevcut satır genişliği: "" & Format(mevcut, ""###0.00 cm"") & Chr(13) & ""Yeni sütun genişliğini girin:"" 'InputBox göster cevap = InputBox(text, ""Yeni satır genişliğini girin (cm)"", Format(mevcut, ""###0.00"")) 'cevaba göre yeni sütun genişliğini değiştir If cevap <> """" Then genislik = CSng(cevap) Selection.ColumnWidth = -0.71 + 5.1425 * genislik End If End Sub" Satır ve sütunları renklendirme "Option Explicit ' // '// Amended 14th Feb 2003 - suggestion by Juan Pablo G. '// International versons may NOT recognise TRUE '// Suggestion use =1 which evaluates to TRUE, '// in fact any number that <> 0 ' / Const iInternational As Integer = Not (0) Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim iColor As Integer '// Amended routine found on this Web site '// Note: Don't use IF you have Conditional '// formating that you want to keep! '// On error resume in case '// user selects a range of cells On Error Resume Next iColor = Target.Interior.ColorIndex '// Leave On Error ON for Row offset errors If iColor < 0 Then iColor = 28 Else iColor = iColor + 1 End If '// Need this test incase Font color is the same If iColor = Target.Font.ColorIndex Then iColor = iColor + 1 Cells.FormatConditions.Delete '// Horizontal color banding With Range(""A"" & Target.Row, Target.Address) 'Rows(Target.Row) .FormatConditions.Add Type:=2, Formula1:=iInternational 'Or just 1 '""TRUE"" .FormatConditions(1).Interior.ColorIndex = iColor End With '// Vertical color banding With Range(Target.Offset(1 - Target.Row, 0).Address & "":"" & Target.Offset(-1, 0).Address) .FormatConditions.Add Type:=2, Formula1:=iInternational 'Or just 1 '""TRUE"" .FormatConditions(1).Interior.ColorIndex = iColor End With End Sub" Satır veya sütundan aritmetik sıralama "Sub CommandButton1_Click() Dim hucre As Range Dim i As Integer BASADON: Set hucre = Application.InputBox(""hücre girin"", Type:=8) If (hucre.Row = 1 And hucre.Column = 1) Or (hucre.Row = 1 And hucre.Column = 2) Then cevap = MsgBox(""Adres Kaynak ile aynı olmamalı"" & vbCrLf & ""Değiştirmek İstiyormusunuz?"", vbYesNo) If cevap = 6 Then GoTo BASADON Else Exit Sub End If End If If MsgBox(""Kolona yazacaksanız EVET"" & vbCrLf & ""Satıra yazacaksanız HAYIR"", vbYesNo) = 6 Then For i = 0 To [B1] - [A1] Cells(hucre.Row + i, hucre.Column) = [A1] + i Next i Else For i = 0 To [B1] - [A1] Cells(hucre.Row, hucre.Column + i) = [A1] + i Next i End If hucre.Select End Sub" Satır yüksekliğini ayarlatma "Sub ZeilenHoehe() Dim rCM rCM = InputBox(""Bitte die gewünschte Zeilenhöhe in cm angeben:"") If rCM = """" Then Exit Sub Selection.RowHeight = rCM / 0.035 End Sub" Satır, sütun isimleri hücreler dahil herşeyi seçer "Sub SelectEntireSheet() Cells.Select End Sub" Satırda ilk boş olan hücreye gider "Sub Finde() Selection.SpecialCells(xlBlanks).Areas(1).Cells(1).Select End Sub" Satırı diğer sayfaya kopyalama "Sub CopyRow() Worksheets(""Sheet1"").Rows(1).Copy Worksheets(""Sheet2"").Select Worksheets(""Sheet2"").Rows(1).Select Worksheets(""Sheet2"").Paste End Sub" Satir ekle, kopyala,sirala,alt toplamlarini al. "Sub aralama() Range(""A2:C10"").Select Selection.Sort Key1:=Range(""A2""), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Dim deger As Variant Dim deger1 As Variant baş: deg = 0 deger = ActiveCell.Value döngü: ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate deger1 = ActiveCell.Value satirno = ActiveCell.Row deg = Cells(satirno - 1, 3).Value + deg If deger <> deger1 Then ActiveCell.EntireRow.Insert Range(""A1:C1"").Copy ActiveCell.PasteSpecial Cells(satirno - 1, 4) = ""TOPLAM:"" Cells(satirno - 1, 5) = deg ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate GoTo baş End If değer = değer1 If deger1 = """" Then Range(Cells(satirno - 2, 1), Cells(satirno - 2, 3)).Delete GoTo 10 End If GoTo döngü 10 End Sub" Satir eklendiğinde m-n ve o sütünundaki hücre değişmesin "Sub Kopyala() Range(""N2:P2"").Select Selection.Copy Range(""N3:P19"").Select ActiveSheet.Paste Application.CutCopyMode = False End Sub " Satir silme "Sub SATIRSİL() Dim x, i For i = 1 To 5 '* For x = 2 To [D65526].End(3).Row Step 1 If Cells(x, 4) Like ""*de*"" Then Rows(x).Delete End If Next x Next i End Sub" Satir sütun başliklarini etkisiz yapar "Private Sub Workbook_Open() Sheets(""veri"").ScrollArea = ""a1:a10"" End Sub" Satir sütun gizleme "Boş olan Satırları Gizle Sub satirgizle() Dim i As Integer For i = 1 To 15 If Sheets(""Sayfa1"").Cells(i, 1).Value <> """" Then Rows(i).Hidden = False Else Sheets(""Sayfa1"").Rows(i).Hidden = True End If Next i End Sub 'A Sütunundaki Boş Satırları Gizler 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 End Sub 'C Sütunundaki Boş Satırları Gizler Sub bidahabossatgizle() For i = 6 To 160 If Range(""c"" & i) = """" Then _ Range(""c"" & i).EntireRow.Hidden = True Next 'Boş olan Sütunlar Gizle Sub satirgizle() Dim i As Integer For i = 1 To 15 If Sheets(""Sayfa1"").Cells(i, 1).Value <> """" Then Rows(i).Hidden = False Else Sheets(""Sayfa1"").Rows(i).Hidden = True End If Next i End Sub 'Toplamları Sıfıra eşit olan satırları gizler Sub sıfırgizle() For Each rngRow In ActiveSheet.UsedRange.Rows If Application.Sum(rngRow) = 0 Then rngRow.EntireRow.Hidden = True End If Next rngRow End Sub" Satirdan sütuna dönüştürme "Sub Test() Range(""A1:A10"") = Application.Transpose(Range(""B1:K1"")) End Sub " Satiri temizleme "Sub TEMİZLE() ARALIK = ""A"" & ActiveCell.Row & "":D"" & ActiveCell.Row Range(ARALIK).ClearContents End Sub" Satirlari artan siralamaya almak "Sub Macro1() Range(""A1:E32"").Select Selection.Sort Key1:=Range(""A1"") End Sub" Satirlari seçmek " Sheets(""deneme"").Activate For sss = 2 To Cells(65536, ""a"").End(3).Row If Cells(sss, 1) = """" Then Rows(Cells(sss, ""a"").Row).Group Next sss" Satirlari sütunlara listelemek "Sub listele() sut = Sheets(""Sayfa1"").Range(""A1"").End(xlToRight).Column sat = Sheets(""Sayfa1"").Range(""A1"").End(xlDown).Row yazsat = 1: yazsut = 1 For i = 2 To sat For y = 1 To sut Sheets(""Sayfa2"").Cells(yazsat, yazsut) = Sheets(""Sayfa1"").Cells(i, y) yazsat = yazsat + 1 Next y yazsut = yazsut + 2 If yazsut > 5 Then yazsut = 1 yazsat = yazsat + 1 Else: yazsat = yazsat - 4 End If Next i End Sub" Save as "Sub saveas() dosya = ""IS "" & Range(""A1"") & "" "" & Range(""B1"") dosya = WorksheetFunction.Substitute(dosya, ""/"", ""."") ' / ları nokta yapsın. ChDrive ""D"" ChDir ""D:\STOK"" ActiveWorkbook.saveas Filename:=dosya End Sub" Save as makrosu sadece belİrtİlen sayfayi kaydetsİn "Sub yenisayfayedekle() Dim i As String If ActiveSheet.Range(""a1"").Value <> """" Then i = ActiveSheet.Range(""a1"").Value ActiveSheet.Select ActiveSheet.Copy Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:= _ ""C:\yedek1\"" & i & "".xls"", FileFormat:= _ xlNormal, Password:="""", WriteResPassword:="""", ReadOnlyRecommended:=False _ , CreateBackup:=False Workbooks(i & "".xls"").Activate ActiveWorkbook.Close ThisWorkbook.Close Application.DisplayAlerts = True Else: Exit Sub End If End Sub" Save as(farkli kaydet) "Yeni dosyayı kapatmamız lazım Sub Makro1() Application.DisplayAlerts = False 'dosyanın üzerine yazayımmı diye sormamasını direk üstüne kaydetmesini sağlar ad = [a1] Sheets(""Sayfa1"").Copy ' sayfanın yeni bir workbook''a kopyasını alır ActiveWorkbook.SaveAs Filename:=""C:\Documents And Settings\ersin\Belgelerim\"" & ad Workbooks(ad).Close 'yeni oluşturulan dosyayı kapatır End Sub " Sayfa 1 a1 den itibaren sayfaların listesi "Sub sahife_list() Dim pir As Worksheet Dim i As Integer For Each pir In Worksheets Range(""A1"").Offset(i) = pir.Name i = i + 1 Next End Sub" Sayfa 1 hariç tüm sayfaları gizle "1.Sayfa hariç tüm sayfaları gizle Sub xlVeryHidden_All_Sheets() On Error Resume Next Dim sh As Worksheet For Each sh In Worksheets sh.Visible = xlVeryHidden Next End Sub" Sayfa 1'den 2'ye kaydetme, boşlukları doldurarak "Private Sub Kaydet() Dim Sh1 As Worksheet, Sh2 As Worksheet Dim Dolusay1, Dolusay2 Set Sh1 = Worksheets(""Sayfa1"") Set Sh2 = Worksheets(""Sayfa2"") Dolusay1 = WorksheetFunction.CountA(Sh1.Range(""A:A"")) Dolusay2 = WorksheetFunction.CountA(Sh2.Range(""A:A"")) Sh1.Range(""A1:A"" & Dolusay1).EntireRow.Copy Sh2.Range(""A"" & Dolusay2 + 1) End Sub" Sayfa 2 deki isimlerin karşisina değeri yazma "Sub çizelge() Dim Tarih Dim isim As String Dim Son As Integer Dim satir, sutun, i Dim tarihalani As Range, isimalani As Range, tarih1 As Range, isim1 As Range On Error Resume Next Son = Sheets(""sayfa2"").Range(""a65536"").End(xlUp).Row Set tarihalani = Sheets(""sayfa2"").Range(""c1:ag1"") Set isimalani = Sheets(""sayfa2"").Range(""a3:a"" & Son + 15) Tarih = Sheets(""sayfa1"").Range(""A1"").Value For i = 13 To Sheets(""sayfa1"").Range(""b65536"").End(xlUp).Row isim = Sheets(""sayfa1"").Range(""B"" & i).Value Set tarih1 = tarihalani.Find(Tarih, lookat:=xlWhole) Set isim1 = isimalani.Find(isim) If tarih1 Is Nothing Then MsgBox ""Aradığınız isim ve ya tarih bulunamadı."", vbCritical, ""Arama Sonucu."" Exit Sub Else sutun = tarih1.Column satir = isim1.Row Sheets(""sayfa2"").Cells(satir, sutun) = Sheets(""sayfa1"").Cells(i, 4) End If Next i End Sub " Sayfa adini değiştirme "Sayfa Adını verir Sub SayfaAdı() ActiveSheet.name=Range(""a1"").value End Sub 'A1 Hücresine Sayfa ismini verir Sub Hücreadı() Range(""a1"").value=ActiveSheet.name End Sub " Sayfa adini yazdirma "Sub Test2() If Not Sheets(""Sayfa1"").Range(""A1"") = Empty Then For i = 1 To Worksheets.Count If Sheets(i).Name = Sheets(""Sayfa1"").Range(""A1"") Then MsgBox ""Bu isimli bir sayfa mevcut .. !"" Exit Sub End If Next Set NewSh = Worksheets.Add(After:=Sheets(Sheets.Count)) NewSh.Name = Sheets(""Sayfa1"").Range(""A1"") End If Set NewSh = Nothing End Sub " Sayfa adlarını listeleme "Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then CommandButton1.Enabled = False Else CommandButton1.Enabled = True End If Label1.Caption = UCase(ListBox1.Value) End Sub ' Private Sub UserForm_Initialize() Dim i As Integer Dim j As Integer Label1.Caption = """" If Worksheets.Count = 1 Then Exit Sub For i = 1 To Worksheets.Count Sheets(i).Name = LCase(Sheets(i).Name) For j = i + 1 To Worksheets.Count If LCase(Worksheets(j).Name) < LCase(Worksheets(i).Name) Then Worksheets(j).Move Before:=Worksheets(i) End If Next j Next i For i = 1 To Sheets.Count ListBox1.AddItem Sheets(i).Name Next Sheets(""ana sayfa"").Move Before:=Sheets(1) End Sub " Sayfa adlarını listeleme 2 "Sub ListelemeYap() 'Sheetlere göre listeleme yapar' Sheets.Add With Sheets(1) For i = 1 To Sheets.Count Cells(i, 1) = Sheets(i).Name .Hyperlinks.Add Anchor:=Cells(i, 1), _ Address:="""", SubAddress:=Sheets(i).Name & ""!A1"" Sheets(i).Range(""A1"") = Sheets(1).Name Sheets(i).Hyperlinks.Add Anchor:=Sheets(i).Range(""A1""), _ Address:="""", SubAddress:=Sheets(1).Name & ""!A1"" Next End With End Sub " Sayfa adlarını renklendirme "Sub Makro1() Sheets(""Sayfa2"").Tab.ColorIndex = 33 End Sub" Sayfa adlarinin (sekme adi) lİstelenmesİ "Private Sub OptionButton1_Click() Dim i As Integer Dim j As Integer Label1.Caption = """" If Worksheets.Count = 1 Then Exit Sub For i = 1 To Worksheets.Count Sheets(i).Name = LCase(Sheets(i).Name) For j = i + 1 To Worksheets.Count If LCase(Worksheets(j).Name) < LCase(Worksheets(i).Name) Then Worksheets(j).Move Before:=Worksheets(i) End If Next j Next i For i = 1 To Sheets.Count ListBox1.AddItem Sheets(i).Name Next Sheets(""ana sayfa"").Move Before:=Sheets(1) End Sub " Sayfa aktif olunca mesaj verme "Private Sub Worksheet_Activate() MsgBox ""Abarini kimi görirem"", vbInformation, ""Hoş gelmişen la kıro"" End Sub" Sayfa aktif olunca sol üstbilgi olarak tarihi ekleme "Private Sub Worksheet_Activate() datum = Format(Date, ""yyyy-mm-dd"") Worksheets(""Tabelle1"").PageSetup.LeftHeader = datum End Sub" Sayfa aktifleşince makro çalıştırma "Private Sub Worksheet_Activate() Makroname 'Makroname write End Sub" Sayfa alfabetik sıralama gizli sayfaları da sıralar Türkçe karakter sorunu olmaz "Sub sayfasirala() Application.ScreenUpdating = False Sheets.Add ActiveSheet.Move After:=Sheets(Sheets.Count) Set s1 = Sheets(Sheets.Count) For a = 1 To Sheets.Count - 1 s1.Cells(a, ""a"") = Sheets(a).Name s1.[a:a].Sort Key1:=s1.[a1] deg = Sheets(a).Name If IsNumeric(deg) = True Then deg = Val(Sheets(a).Name) say = WorksheetFunction.Match(deg, s1.[a:a], 0) Sheets(a).Move Before:=Sheets(say) Next Application.DisplayAlerts = False s1.Delete End Sub" Sayfa alfabetik sıralama gizli sayfaları da sıralar Türkçe karakter sorunu olmaz 2 "Sub alfabetik_sirala() Application.ScreenUpdating = False Sheets(1).Select Say = Sheets.Count If Say < 2 Then Exit Sub Sheets.Add ActiveSheet.Name = ""Liste"" For X = 2 To Sheets.Count Sheets(""Liste"").Cells(X - 1, 1) = Sheets(X).Name If Sheets(X).Visible = False Then Sheets(X).Visible = True Sheets(""Liste"").Cells(X - 1, 2) = ""Gizli"" End If Next Columns(""A:B"").Sort Key1:=Range(""A1""), Order1:=xlAscending [A1].Select For Y = 2 To Sheets.Count Sheets("""" & Cells(Y - 1, 1)).Move Before:=Sheets(Y) Sheets(""Liste"").Select If Sheets(""Liste"").Cells(Y - 1, 2) = ""Gizli"" Then Sheets("""" & Cells(Y - 1, 1)).Visible = False End If Next Application.DisplayAlerts = False Sheets(""Liste"").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub" Sayfa çoğaltma "Sub cogalt() For a = 1 To 10 Sheets(""Sayfa1"").Copy After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = a Next End Sub" Sayfa dolu ise doluları sırayla önizleme yapar boş ise göstermez "Sub sheets_preview() Dim Sh As Worksheet For Each Sh In Worksheets If Sh.Visible = True Then Sh.PrintPreview End If Next Sh End Sub" Sayfa ekle a1 hücresine otomatik olarak sayfanin adinin yazilmasi "Sub SAYFA_EKLE() Application.ScreenUpdating = False Say = Worksheets.Count For X = Say To Say + 14 Sheets(""ANASAYFA"").Select Sheets(""ANASAYFA"").Copy After:=Sheets(Worksheets.Count) ActiveSheet.Shapes(""Button 1"").Delete ActiveSheet.Name = Format(X, ""0000"") ActiveSheet.[AA1].Select Selection.NumberFormat = ""@"" With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With ActiveSheet.[AA1] = ActiveSheet.Name Next Sheets(""ANASAYFA"").Select Application.ScreenUpdating = True End Sub" Sayfa ekleme "Sub ekle() Dim x As Object Dim neu$, mldg$, title$ Dim ergebnis%, stil% neu = InputBox(""Bitte Namen des neuen Arbeitsblattes eingeben:"") For Each x In ActiveWorkbook.Sheets If x.Name = neu Then mldg = ""Blattname existiert bereits!"" stil = vbCritical + vbOKOnly title = ""Achtung"" ergebnis = MsgBox(mldg, stil, title) Exit Sub End If Next x Sheets.Add ActiveSheet.Name = neu Sheets(neu).Select With ActiveSheet.PageSetup .LeftMargin = Application.CentimetersToPoints(1) .RightMargin = Application.CentimetersToPoints(1) End With End Sub" Sayfa ekleme inputboxa ismini yaz "Sub NeuesTabBlatt() Dim NewName As String ActiveSheet.Copy Before:=Sheets(1) 'ganz links anordnen 'ActiveSheet.Copy Before:=ActiveSheet 'links neben Original anordnen NewName = InputBox(""Geben Sie einen Tabellenblattnamen ein"") On Error Resume Next ActiveSheet.Name = NewName End Sub" Sayfa ekleme sıra numarası vererek "Sub Combine() Dim J As Integer On Error Resume Next Sheets(1).Select Worksheets.Add ' add a sheet in first place Sheets(1).Name = ""Combined"" ' copy headings Sheets(2).Activate Range(""A1"").EntireRow.Select Selection.Copy Destination:=Sheets(1).Range(""A1"") ' work through sheets For J = 2 To Sheets.Count ' from sheet 2 to last sheet Sheets(J).Activate ' make the sheet active Range(""A1"").Select Selection.CurrentRegion.Select ' select all cells in this sheets ' select all lines except title Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select ' copy cells selected in the new sheet on last line Selection.Copy Destination:=Sheets(1).Range(""A65536"").End(xlUp)(2) Next End Sub" Sayfa eklemek İÇİn aŞaĞidakİ kodu deneyİn. 1.Sayfayi kopyalar "Sayfa eklemek için aşağıdaki kodu deneyin. 1.sayfayı kopyalar. visual basic kodu: Private Sub CommandButton2_Click() Sheets(1).Copy After:=Sheets(Sheets.Count) End Sub" Sayfa gİzleme hİÇ gÖstermeme "ÖZELLİKLER MENÜSÜNDEN SAYFA GİZLEME İŞLEMLERİ VİSİBLE: 0-XLSHEETHİDDE 2-XLSHEETVERY 1-XLSHEETVİSİBLE " Sayfa gizleme işlemleri "Private Sub Workbook_BeforeClose(Cancel As Boolean) ' Sayfa1 sayfasını görünür yapıyoruz Sheets(""Sayfa1"").Visible = True ' Sayfa1 haricinde hepsini gizliyoruz For Each Worksheet In ActiveWorkbook.Worksheets If Worksheet.Name <> ""Sayfa1"" Then Worksheet.Visible = False End If Next ' Çalışma Kitabını koruyoruz ActiveWorkbook.Protect Password:=""sifre"", Structure:=True, Windows:=True End Sub Private Sub Workbook_Open() ' Çalışma Kitabı korumasını kaldırıyoruz ActiveWorkbook.Unprotect Password:=""sifre"" ActiveWorkbook.Unprotect ' Bütün sayfaları görünür Yapıyoruz For Each Worksheet In ActiveWorkbook.Worksheets Worksheet.Visible = True Next ' Sayfa1 sayfasını gizliyoruz Sheets(""Sayfa1"").Visible = False End Sub" Sayfa index numarasına göre bulma "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" Sayfa isimleri mesaj kutusunda sıralı "Sub sayfa_isim() Dim Count%, Sayfa$ Sayfa = ""Toplam Sayfa Adedi: "" & Sheets.Count & Chr$(13) For Count = 1 To Sheets.Count Sayfa = Sayfa & Chr$(13) & ""Adı"" & Count & "": "" & _ Sheets(Count).Name Next MsgBox Sayfa, vbOKOnly + vbInformation, ""Sayfa İsimleri"" End Sub" Sayfa isimleri x ve y olan haricinde olanların silinmesi "ThisWorkbook'a Private Sub Workbook_Open() Application.DisplayAlerts = False Tekrar: For i = 1 To Worksheets.Count If Worksheets(i).Name = ""x"" Or Worksheets(i).Name = ""y"" Then GoTo ATLA Worksheets(i).Delete GoTo Tekrar: ATLA: Next i Application.DisplayAlerts = True End Sub" Sayfa isimlerini a1 den itibaren listele "Sub SheetNamesDownRows() Dim iSheet As Long For iSheet = 1 To ActiveWorkbook.Worksheets.Count ActiveCell.Offset(iSheet - 1, 0) = ""'"" & Worksheets(iSheet).Name Next iSheet End Sub" Sayfa isimlerini açılışta alfabetik sıralama "Sub Auto_Open() Dim i As Integer Dim j As Integer If Worksheets.Count = 1 Then Exit Sub For i = 1 To Worksheets.Count - 1 For j = i + 1 To Worksheets.Count If Worksheets(j).Name < Worksheets(i).Name Then Worksheets(j).Move before:=Worksheets(i) End If Next j Next i End Sub" Sayfa isimlerini alfabetik sıralama "Sub TrieFeuilles() Dim I As Integer Dim J As Integer Dim Min As Integer Dim ModeCalcul As Integer ModeCalcul = Application.Calculation Application.Calculation = xlCalculationManual Application.ScreenUpdating = False With ActiveWorkbook.Worksheets For I = 1 To .Count - 1 Min = I For J = I + 1 To .Count If .Item(J).Name < .Item(Min).Name Then Min = J Next J If Min <> I Then .Item(Min).Move before:=Worksheets(I) Next I End With Application.Calculation = ModeCalcul Application.ScreenUpdating = True End Sub" Sayfa isimlerini alfabetik sıralama 2 "Sub TriChaqueFeuilles() Dim X As Variant Dim I As Variant For Each X In ActiveWorkbook.Sheets For I = 2 To ActiveWorkbook.Sheets.Count If Sheets(I - 1).Name > Sheets(I).Name Then Sheets(I - 1).Move After:=Sheets(I) End If Next Next End Sub" Sayfa isimlerini büyük harfe çevirme "Sub Maj_Onglets() Dim i As Integer For i = 1 To Sheets.Count Sheets(i).Name = UCase(Sheets(i).Name) Next i End Sub" Sayfa isimlerini comboboxa aktarma "For Each sayfa In Worksheets ad.AddItem sayfa.Name Next sayfa" Sayfa isimlerini listelemek 1 "Sub Menu() Application.CommandBars(""Workbook tabs"").ShowPopup 930, 30 End Sub" Sayfa isimlerini listelemek 2 "Private Sub sayfa_say() Dim i As Integer For i = 1 To Worksheets.Count Cells(i, 1).Value = Sheets(i).Name Next i End Sub" Sayfa isimlerini mesajla saydırma "Sub Schutzabfrage() Dim wks As Worksheet Dim i As Integer For i = 1 To Worksheets.Count If Sheets(i).ProtectContents = False Then MsgBox (i & "". Blatt"" & Chr(13) & Chr(13) & ""("" & Sheets(i).Name & "") "" & Chr(13) & Chr(13) & "" ist ungeschützt!"") End If Next i End Sub" Sayfa isimlerini olduğu gibi sıralar "Sub GetSheets() Dim j As Integer Dim NumSheets As Integer NumSheets = Sheets.Count For j = 1 To NumSheets Cells(j, 1) = Sheets(j).Name Next j End Sub" Sayfa isimlerini sayfanın a sütununa yazdırma "Sub Tabellennamen_auslesen() For i = 1 To Worksheets.Count Sheets(""Hier Namen auslesen"").Cells(i, 1).Value = Sheets(i).Name Next End Sub" Sayfa isimlerini sıralama "Sub Sayfa_sirala() Dim x As Integer Dim y As Boolean Do y = True For x = 1 To Sheets.Count - 1 If Val(Sheets(x).Name) > Val(Sheets(x + 1).Name) Then Sheets(x + 1).Move Before:=Sheets(x) y = False End If Next x Loop Until y = True ActiveSheet.Next.Select End Sub " Sayfa isimlerini sırayla mesaj vererek sayar "Sub FeuilleMSG() Dim Lst() As String Dim I As Integer ReDim Lst(Sheets.Count - 1) For I = 0 To Sheets.Count - 1 Lst(I) = Sheets(I + 1).Name MsgBox Lst(I) Next I End Sub" Sayfa isimlerini toptan değiştirme "Sub Umbenennen() Dim Tabelle As Worksheet i = 1 For Each Tabelle In ActiveWorkbook.Worksheets Tabelle.Name = ""NeuerName"" & i i = i + 1 Next Tabelle End Sub" Sayfa isimlerini z den a ya sıralama "Sub SortSheets() Dim i As Integer, j As Integer For i = 1 To Sheets.Count For j = 1 To Sheets.Count - 1 If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then Sheets(j).Move after:=Sheets(j + 1) End If Next j Next i End Sub" Sayfa ismi a1 in ismi olsun "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Target, Range(""a1"")) Is Nothing Then Range(""a2"").Select End If If Target = Range(""A1"") Then ActiveSheet.Name = Target End Sub" Sayfa ismini değiştirme "Sub say() For i = 1 To Sheets.Count With Sheets(i) .Select .Name = [A2] End With Next i End Sub" Sayfa kaydırma scroll çubuğunu çalıştırma "Sub scroll_down() Count = 1 Do Until Count = 200 ActiveWindow.SmallScroll Down:=1 Application.Wait Now + (TimeValue(""00:00:03"") * 0.2) Count = Count + 1 Loop Cells(1, 1).Select End Sub" Sayfa kopyalama "Aktif Sayfayı Kopyala ve Yeni Bir Çalışma Kitabı aç ve İsmini ""YeniSayfa"" Ver ve kopyalananı yapıştır. Sub YeniKitap() Dim Sh As Worksheet Set Sh = ActiveSheet ActiveSheet.Copy ActiveSheet.Name = ""YeniSayfa"" Sh.Range(""A1:Z10"").Copy Range(""A2"") End Sub " Sayfa kopyalama "Sub YENİÜYE() On Error Resume Next Application.ScreenUpdating = False Dim sadi, ssayi sadi = [C2] ssayi = Worksheets.Count For i = 1 To ssayi If Sheets(i).Name = sadi Then Exit Sub Next i Worksheets.Add After:=Worksheets(ssayi) Worksheets(ssayi + 1).Name = sadi Sheets(""KOPYA"").Select Cells.Select Selection.Copy Sheets(ssayi + 1).Select Cells.Select ActiveSheet.Paste Range(""H2"").Select Range(""H2"").Value = sadi Sheets(""KOPYA"").Select Application.CutCopyMode = False Range(""H2"").Select Sheets(i).Select Application.ScreenUpdating = True End Sub" Sayfa kopyalama (indexi 2 olan sayfanın c6 adıyla kopyalar butonları silerek) "Sub Düğme8_Tıklat() Dim NewName As String ActiveSheet.Copy Before:=Sheets(2) 'ActiveSheet.Copy Before:=ActiveSheet NewName = Sheets(2).Range(""c6"").Value On Error Resume Next ActiveSheet.Name = NewName ActiveSheet.DrawingObjects.Delete End Sub" Sayfa kopyalama (macro ile) "Sub Kopyala() Sheets(""Sayfa1"").Visible = True Sheets(""Sayfa1"").Copy After:=Worksheets(Worksheets.Count) 10 NewPageName = InputBox(""Kopyalamak Üzere Olduğunuz Sayfanın Adını Belirleyiniz !!!"") For a = 1 To Sheets.Count If UCase(Sheets(a).Name) = UCase(NewPageName) Then MsgBox ""Seçtiğiniz sayfa adı mevcuttur yeniden deneyin."" GoTo 10 End If Next ActiveWindow.ActiveSheet.Name = NewPageName End Sub" Sayfa kopyasını siz belirleyin "Private Sub impression() Dim NumLigne As Long Sheets(""Base"").Select NumLigne = Range(""H2"").Value + 16 Dim ZoneImpression As String ZoneImpression = ""$B$7:$K$"" & NumLigne ActiveSheet.PageSetup.PrintArea = ZoneImpression Dim NbCopy As Integer On Error GoTo fin NbCopy = InputBox(""Nombre de fiches à imprimer (Maxi 5)"", ""Nombre"", 1, 1000, 1000) If NbCopy > 5 Then NbCopy = 5 Application.ScreenUpdating = False ActiveWindow.SelectedSheets.PrintOut Copies:=NbCopy, Collate:=True fin: End Sub" Sayfa koruma koyduysanız sıra ile koruma kaldırma menüsü "Sub UnProtectFeuil() Dim sht As Worksheet For Each sht In ActiveWorkbook.Worksheets sht.Unprotect Next sht End Sub" Sayfa koruma menülerini çağırır "SAYFA KORUMA MENÜSÜ ÇAĞIR Sub BlattSchutzEin() Application.Dialogs(xlDialogProtectDocument).Show End Sub SAYFA KORUMASINI KALDIR MENÜSÜ Sub BlattSchutzAus() ActiveSheet.Unprotect End Sub " Sayfa koruma menÜlerİnİ ÇaĞirir "SAYFA KORUMA MENÜSÜ ÇAĞIR Sub BlattSchutzEin() Application.Dialogs(xlDialogProtectDocument).Show End Sub SAYFA KORUMASINI KALDIR MENÜSÜ Sub BlattSchutzAus() ActiveSheet.Unprotect End Sub " Sayfa koruma şifresini kaldırma "Sub SifreAc() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66 For j = 65 To 66 For k = 65 To 66 For l = 65 To 66 For m = 65 To 66 For i1 = 65 To 66 For i2 = 65 To 66 For i3 = 65 To 66 For i4 = 65 To 66 For i5 = 65 To 66 For i6 = 65 To 66 For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) _ & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox ""One usable password is "" & Chr(i) & Chr(j) _ & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) _ & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next Next Next Next Next Next Next Next Next Next Next Next End Sub" Sayfa koruma, otomatik filtre açık "Sub FilternAuchBeiBlattschutz() ActiveSheet.Protect userinterfaceonly:=True ActiveSheet.EnableAutoFilter = True End Sub" Sayfa korumalarını kaldırır (şifresiz olanları) "Sub sayfakorumakaldir() Dim Wb As Workbook, Sh As Worksheet For Each Wb In Workbooks For Each Sh In Wb.Worksheets Sh.Unprotect Next Sh Next Wb End Sub" Sayfa korumalarını kaldırma "Public Sub AllInternalPasswords() Const DBLSPACE As String = vbNewLine & vbNewLine Const AUTHORS As String = DBLSPACE & vbNewLine & _ ""Adapted from Bob McCormick base code by"" & _ ""Norman Harker and JE McGimpsey"" Const HEADER As String = ""AllInternalPasswords User Message"" Const VERSION As String = DBLSPACE & ""Version 1.1.1 2003-Apr-04"" Const REPBACK As String = DBLSPACE & ""Please report failure "" & _ ""to the microsoft.public.excel.programming newsgroup."" Const ALLCLEAR As String = DBLSPACE & ""The workbook should "" & _ ""now be free of all password protection, so make sure you:"" & _ DBLSPACE & ""SAVE IT NOW!"" & DBLSPACE & ""and also"" & _ DBLSPACE & ""BACKUP!, BACKUP!!, BACKUP!!!"" & _ DBLSPACE & ""Also, remember that the password was "" & _ ""put there for a reason. Don't stuff up crucial formulas "" & _ ""or data."" & DBLSPACE & ""Access and use of some data "" & _ ""may be an offense. If in doubt, don't."" Const MSGNOPWORDS1 As String = ""There were no passwords on "" & _ ""sheets, or workbook structure or windows."" & AUTHORS & VERSION Const MSGNOPWORDS2 As String = ""There was no protection to "" & _ ""workbook structure or windows."" & DBLSPACE & _ ""Proceeding to unprotect sheets."" & AUTHORS & VERSION Const MSGTAKETIME As String = ""After pressing OK button this "" & _ ""will take some time."" & DBLSPACE & ""Amount of time "" & _ ""depends on how many different passwords, the "" & _ ""passwords, and your computer's specification."" & DBLSPACE & _ ""Just be patient! Make me a coffee!"" & AUTHORS & VERSION Const MSGPWORDFOUND1 As String = ""You had a Worksheet "" & _ ""Structure or Windows Password set."" & DBLSPACE & _ ""The password found was: "" & DBLSPACE & ""$$"" & DBLSPACE & _ ""Note it down for potential future use in other workbooks by "" & _ ""the same person who set this password."" & DBLSPACE & _ ""Now to check and clear other passwords."" & AUTHORS & VERSION Const MSGPWORDFOUND2 As String = ""You had a Worksheet "" & _ ""password set."" & DBLSPACE & ""The password found was: "" & _ DBLSPACE & ""$$"" & DBLSPACE & ""Note it down for potential "" & _ ""future use in other workbooks by same person who "" & _ ""set this password."" & DBLSPACE & ""Now to check and clear "" & _ ""other passwords."" & AUTHORS & VERSION Const MSGONLYONE As String = ""Only structure / windows "" & _ ""protected with the password that was just found."" & _ ALLCLEAR & AUTHORS & VERSION & REPBACK Dim w1 As Worksheet, w2 As Worksheet Dim i As Integer, j As Integer, k As Integer, l As Integer Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer Dim PWord1 As String Dim ShTag As Boolean, WinTag As Boolean Application.ScreenUpdating = False With ActiveWorkbook WinTag = .ProtectStructure Or .ProtectWindows End With ShTag = False For Each w1 In Worksheets ShTag = ShTag Or w1.ProtectContents Next w1 If Not ShTag And Not WinTag Then MsgBox MSGNOPWORDS1, vbInformation, HEADER Exit Sub End If MsgBox MSGTAKETIME, vbInformation, HEADER If Not WinTag Then MsgBox MSGNOPWORDS2, vbInformation, HEADER Else On Error Resume Next Do For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 With ActiveWorkbook .Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If .ProtectStructure = False And _ .ProtectWindows = False Then PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) MsgBox Application.Substitute(MSGPWORDFOUND1, _ ""$$"", PWord1), vbInformation, HEADER Exit Do End If End With Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next Loop Until True On Error GoTo 0 End If If WinTag And Not ShTag Then MsgBox MSGONLYONE, vbInformation, HEADER Exit Sub End If On Error Resume Next For Each w1 In Worksheets w1.Unprotect PWord1 Next w1 On Error GoTo 0 ShTag = False For Each w1 In Worksheets ShTag = ShTag Or w1.ProtectContents Next w1 If ShTag Then For Each w1 In Worksheets With w1 If .ProtectContents Then On Error Resume Next Do For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 .Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If Not .ProtectContents Then PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) MsgBox Application.Substitute(MSGPWORDFOUND2, _ ""$$"", PWord1), vbInformation, HEADER For Each w2 In Worksheets w2.Unprotect PWord1 Next w2 Exit Do End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next Loop Until True On Error GoTo 0 End If End With Next w1 End If MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER End Sub" Sayfa koruması kırma "Sub SifreAc() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66 For j = 65 To 66 For k = 65 To 66 For l = 65 To 66 For m = 65 To 66 For i1 = 65 To 66 For i2 = 65 To 66 For i3 = 65 To 66 For i4 = 65 To 66 For i5 = 65 To 66 For i6 = 65 To 66 For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) _ & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox ""One usable password is "" & Chr(i) & Chr(j) _ & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) _ & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next Next Next Next Next Next Next Next Next Next Next Next End Sub" Sayfa koruması nasıl kaldırılır "Önce Sayfa koruması olan Excel dosyası açılır, sonra makrolar bölümünden VBA düzenleyicisinin içine girilir,bir modül oluşturulur, oluşturulan modülün içine aşağıdaki kod yazılır ve çalıştırılır, ' ** KOD ****** Sub pcwBreaker() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 sifre = Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) ActiveSheet.Unprotect sifre If ActiveSheet.ProtectContents = False Then MsgBox ""Bitti."" & vbCr & ""Sifre:"" & vbCr & sifre Exit Sub End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next End Sub" Sayfa korumasını kaldırma "Sub DesactiverProtection() ActiveSheet.Unprotect End Sub" Sayfa korumasını kırma "Sub koruma_kir() On Error Resume Next For i = 65 To 66 For j = 65 To 66 For k = 65 To 66 For l = 65 To 66 For M = 65 To 66 For N = 65 To 66 For o = 65 To 66 For p = 65 To 66 For q = 65 To 66 For r = 65 To 66 For s = 65 To 66 For t = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(M) & _ Chr(N) & Chr(o) & Chr(p) & Chr(q) & Chr(r) & Chr(s) & Chr(t) If ActiveSheet.ProtectContents = False Then MsgBox ""Ein mögliches Passwort ist "" & Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ Chr(M) & Chr(N) & Chr(o) & Chr(p) & Chr(q) & Chr(r) & Chr(s) & Chr(t) Exit Sub End If Next t Next s Next r Next q Next p Next o Next N Next M Next l Next k Next j Next i End Sub" Sayfa korumasını kırmak için "Sub pcwBreaker() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 sifre = Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) ActiveSheet.Unprotect sifre If ActiveSheet.ProtectContents = False Then MsgBox ""Bitti."" & vbCr & ""Sifre:"" & vbCr & sifre Exit Sub End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next End Sub" Sayfa korumasını kırmak için (unuttuysanız kullanın) "Sub breakit() Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, n As Integer On Error Resume Next For i = 65 To 66 For j = 65 To 66 For k = 65 To 66 For l = 65 To 66 For m = 65 To 66 For i1 = 65 To 66 For i2 = 65 To 66 For i3 = 65 To 66 For i4 = 65 To 66 For i5 = 65 To 66 For i6 = 65 To 66 For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox ""One useble password is "" & Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next Next Next Next Next Next Next Next Next Next Next Next End Sub" Sayfa link güncelleştirme "Sub upddate_link() ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources End Sub" Sayfa numarası ekleme makrosu " Kopf_und_Fusszeilen() ' &S = Seiten-Nr. ' &A = Seitenanzahl ' &N = Mappen-Name ' &B = Register-Name ' &D = Datum ' &U = Uhrzeit Sub vb_Pfad_in_Fusszeile() Application.ScreenUpdating = False With ActiveSheet.PageSetup .RightFooter = ActiveWorkbook.Path & ""\&N [&B]"" End With Application.ScreenUpdating = True End Sub" Sayfa protect unprotect " Public Sub ProtectGroupedSheets() Const csPASSWD As String = ""drowssap"" Dim mySheets As Sheets Dim actSheet As Worksheet Dim wkSht As Worksheet Set actSheet = ActiveSheet Set mySheets = ActiveWindow.SelectedSheets actSheet.Select For Each wkSht In mySheets wkSht.Protect Password:=csPASSWD Next wkSht actSheet.Select mySheets.Select False End Sub" Sayfa saydırma "Public Sub SortWorksheets1() Dim Cnt%, N%, M%, i%, ZahlM%, ZahlN% Dim WS As Worksheet Set WS = ActiveSheet Cnt = ActiveWorkbook.Worksheets.Count For M = 1 To Cnt For N = M To Cnt On Error Resume Next For i = 1 To Len(Worksheets(N).Name) If IsNumeric(Right(Worksheets(N).Name, i)) = False Then i = i - 1 If i = 0 Then GoTo Text ZahlN = Right(Worksheets(N).Name, i) Exit For End If Next i For i = 1 To Len(Worksheets(M).Name) If IsNumeric(Right(Worksheets(M).Name, i)) = False Then i = i - 1 If i = 0 Then GoTo Text ZahlM = Right(Worksheets(M).Name, i) Exit For End If Next i If CInt(ZahlN) < CInt(ZahlM) Then Worksheets(N).Move _ Before:=Worksheets(M) GoTo Nächste Text: If Worksheets(N).Name < Worksheets(M).Name Then _ Worksheets(N).Move Before:=Worksheets(M) Nächste: Next N Next M Sheets(""Tab3"").Select MsgBox ""Anzahl der Tabellen: "" & Cnt End Sub" Sayfa sayısını bulan kod 1 Sheets("Sheet1").Range("A1")=ListBox2.ListCount Sayfa sayısını bulan kod 2 "Private Sub CommandButton1_Click() Dim i As Integer For i = 1 To Worksheets.Count ListBox1.AddItem Worksheets(i).Name Next i End Sub" Sayfa sekmelerine koruma atamak "Bu işlemi aşağıdaki kodlarla; Sayfa2 sekmesini tıkladığınızda şifre uyarı penceresi açtırarak şifreyi bilirse sayfa ismini değiştirebilir (sayfa2 ye geçebilir) Şifreyi bilemezse sayfa2 ye geçilemez ve sayfa ismide değiştirilemez. Private Sub Worksheet_Activate() 'ActiveWindow.DisplayWorkbookTabs = False 'sayfa tablarını gizler Application.EnableCancelKey = xlErrorHandler 'esc tuşu devre dışı Application.DisplayAlerts = False 'hata mesajlarını gözardı et Dim sifre As String sifre = InputBox(""Lütfen Şifreyi Giriniz,"" & Chr(13) & Chr(13) & ""Şifre:123"", ""pir"") If sifre <> ""123"" Then 'şifre yanlışsa MsgBox ""Hatalı şifre"" Worksheets(""Sayfa1"").Select Exit Sub Else MsgBox (""Şifreyi Doğru Girdiniz"") ActiveWindow.DisplayWorkbookTabs = True Worksheets(""Sayfa2"").Select Application.DisplayAlerts = True End If End Sub " Sayfa sekmelerini hücrede göster "Private Sub Worksheet_Activate() [a1] = ActiveSheet.Name End Sub" Sayfa sekmelerinin gizlenmesi "Sub MasqueOnglet() With ActiveWindow .DisplayWorkbookTabs = Not .DisplayWorkbookTabs End With End Sub" Sayfa sıralama "Public Sub SortWorksheets() Dim Cnt As Integer Dim N As Integer Dim M As Integer On Error GoTo EndOfMacro Application.ScreenUpdating = False Cnt = ActiveWorkbook.Worksheets.Count For M = 1 To Cnt For N = M To Cnt If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then Worksheets(N).Move before:=Worksheets(M) End If Next N Next M EndOfMacro: Application.ScreenUpdating = True End Sub" Sayfa sıralama "Sub sheet_sorting () Dim i As Integer Dim j As Integer For i = 1 To Sheets.Count For j = 1 To Sheets.Count - 1 If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then Sheets(j).Move after:=Sheets(j + 1) End If Next j Next i End Sub" Sayfa sıralama "Public Sub SortWorksheets() Dim Cnt As Integer Dim N As Integer Dim M As Integer On Error GoTo EndOfMacro Application.ScreenUpdating = False Cnt = ActiveWorkbook.Worksheets.Count For M = 1 To Cnt For N = M To Cnt If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then Worksheets(N).Move before:=Worksheets(M) End If Next N Next M EndOfMacro: Application.ScreenUpdating = True End Sub" Sayfa silerken mesaj vermesin "Sub SayfaSil() Application.DisplayAlerts = False ActiveSheet.Delete End Sub Yanlız uyarıyı tekrar eski haline getirmelisiniz. Sub SayfaSil() Application.DisplayAlerts = False ActiveSheet.Delete Application.DisplayAlerts = True End Sub" Sayfa silme & adlandırmayı engelleme "Belli menu ve komutları (hem araç çubuğunda hem de sağ klik tuşundaki pop-up menüleri) seçilemez sub menükomutlarıiptal() Dim Ctrl As Office.CommandBarControl For Each Ctrl In Application.CommandBars.FindControls(ID:=847) Ctrl.Enabled = False'True menüleri aktif yapar Next Ctrl For Each Ctrl In Application.CommandBars.FindControls(ID:=889) Ctrl.Enabled = False'True menüleri aktif yapar Next Ctrl end sub 'MENÜ KOMUTLARINI AÇAR. sub menükomutlarıaç() Dim Ctrl As Office.CommandBarControl For Each Ctrl In Application.CommandBars.FindControls(ID:=847) Ctrl.Enabled = True'True menüleri aktif yapar Next Ctrl For Each Ctrl In Application.CommandBars.FindControls(ID:=889) Ctrl.Enabled = True'True menüleri aktif yapar Next Ctrl end sub " Sayfa sİlme & adlandirmayi engeller "Belli menu ve komutları (hem araç çubuğunda hem de sağ klik tuşundaki pop-up menüleri) seçilemez sub menükomutlarıiptal() Dim Ctrl As Office.CommandBarControl For Each Ctrl In Application.CommandBars.FindControls(ID:=847) Ctrl.Enabled = False'True menüleri aktif yapar Next Ctrl For Each Ctrl In Application.CommandBars.FindControls(ID:=889) Ctrl.Enabled = False'True menüleri aktif yapar Next Ctrl end sub 'MENÜ KOMUTLARINI AÇAR. sub menükomutlarıaç() Dim Ctrl As Office.CommandBarControl For Each Ctrl In Application.CommandBars.FindControls(ID:=847) Ctrl.Enabled = True'True menüleri aktif yapar Next Ctrl For Each Ctrl In Application.CommandBars.FindControls(ID:=889) Ctrl.Enabled = True'True menüleri aktif yapar Next Ctrl end sub " Sayfa silme inputbox a yazarak "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" Sayfa silme iptal (ing. excel ver.) "Option Explicit Private Sub Worksheet_Activate() With Application .CommandBars(""Worksheet Menu Bar"").Controls(""Edit"").Controls(""Delete Sheet"").Enabled = False .CommandBars(""Ply"").Controls(""Delete"").Enabled = False End With End Sub Private Sub Worksheet_Deactivate() With Application .CommandBars(""Worksheet Menu Bar"").Controls(""Edit"").Controls(""Delete Sheet"").Enabled = True .CommandBars(""Ply"").Controls(""Delete"").Enabled = True End With End Sub" Sayfa silme uyarı mesajı almadan "Sub sayfasil() Application.DisplayAlerts = False Worksheets(""Sayfa1"").Delete End Sub" Sayfa şifreleme "Sub ProtectSheet() Dim Password 'This line of code is optional Password = ""1234"" ActiveSheet.Protect Password, True, True, True End Sub Sub UnProtectSheet() Password = ""1234"" ActiveSheet.Unprotect Password End Sub" Sayfa şifreleme ve açma "Sub sifrele_ac() ActiveSheet.Unprotect ""a"" MsgBox ""Sayfa şifresi çözüldü"" ActiveSheet.Protect MsgBox ""Sayfa şifrelendi"" End Sub" Sayfa üzerinde sağ klik menü "Sub Auto_Open() PopUpMenu End Sub ' Sub PopUpMenu() Dim cb As CommandBar Set cb = Application.CommandBars(""Cell"") ' Set MenuObject = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True) MenuObject.Caption = ""Benim Menüm"" MenuObject.BeginGroup = True ' With MenuObject With .Controls.Add(Type:=msoControlButton) .OnAction = ""RaiderMacro1"" .FaceId = 7 .Caption = ""Alt Menüm - 1"" End With With .Controls.Add(Type:=msoControlButton) .OnAction = ""RaiderMacro2"" .FaceId = 17 .Caption = ""Alt Menüm - 2"" End With With .Controls.Add(Type:=msoControlButton) .OnAction = ""RaiderMacro3"" .FaceId = 27 .Caption = ""Alt Menüm - 3"" End With End With ' Set MenuObject2 = MenuObject.Controls.Add(Type:=msoControlPopup, Temporary:=True) MenuObject2.Caption = ""Benim 2nci Seviye Menüm - 1"" ' With MenuObject2 With .Controls.Add(Type:=msoControlButton) .OnAction = ""RaiderMacro4"" .FaceId = 37 .Caption = ""2nci Seviye(1) Alt Menüm - 1"" End With With .Controls.Add(Type:=msoControlButton) .OnAction = ""RaiderMacro5"" .FaceId = 47 .Caption = ""2nci Seviye(1) Alt Menüm - 2"" End With End With ' Set MenuObject3 = MenuObject.Controls.Add(Type:=msoControlPopup, Temporary:=True) MenuObject3.Caption = ""Benim 2nci Seviye Menüm - 2"" ' With MenuObject3 With .Controls.Add(Type:=msoControlButton, ID:=4) .Visible = True End With With .Controls.Add(Type:=msoControlButton, ID:=3) .Visible = True End With With .Controls.Add(Type:=msoControlButton, ID:=1695) .Visible = True End With End With ' Set cb = Nothing Set MenuObject = Nothing Set MenuObject2 = Nothing End Sub ' Sub RaiderMacro1() MsgBox ""RaiderMacro1 çalıştırıldı !"" & vbCrLf & vbCrLf & ""(AltMenü-1)"" End Sub ' Sub RaiderMacro2() MsgBox ""RaiderMacro2 çalıştırıldı !"" & vbCrLf & vbCrLf & ""(AltMenü-2)"" End Sub ' Sub RaiderMacro3() MsgBox ""RaiderMacro3 çalıştırıldı !"" & vbCrLf & vbCrLf & ""(AltMenü-3)"" End Sub ' Sub RaiderMacro4() MsgBox ""RaiderMacro4 çalıştırıldı !"" & vbCrLf & vbCrLf & ""(2nci Seviye AltMenü-1)"" End Sub ' Sub RaiderMacro5() MsgBox ""RaiderMacro5 çalıştırıldı !"" & vbCrLf & vbCrLf & ""(2nci Seviye AltMenü-2)"" End Sub ' Sub Auto_Close() Application.CommandBars(""Cell"").Reset End Sub " Sayfa1 a sütununda sıralı olmayan isimleri aynı anda sayfa2 a sütununda a-z ye sıralar "’Sayfa2 de mouse sağ click, Kod Görüntüle deyin çıkan ekrana bu kodları yapıştırın. Private Sub Worksheet_Activate() Set s1 = Sheets(""Sayfa1"") Set s2 = Sheets(""Sayfa2"") With s2.[A1:A1000] .Value = s1.[A1:A1000].Value .Sort [A1] End With Set s1 = Nothing Set s2 = Nothing End Sub" Sayfa1 a1,b1,c1 dolu ve b sütunu gizli,a1 ve c1 i sayfa2 de a1,b1 e kopyala "Option Explicit Sub sichtbare_kopieren() Range(""A1"").CurrentRegion _ .SpecialCells(xlCellTypeVisible).Copy _ Worksheets(""Tabelle2"").Range(""A1"") End Sub" Sayfa1 a1:a100 arasinda dolgu rengİ sari olan hÜcre varsa o satirin a:an araliĞini sayfa2 ye nasil kopyalariz "Sub Test2() Dim Sh1 As Worksheet, Sh2 As Worksheet Dim MyRng As Range Dim Nrow As Long Set Sh1 = Sheets(""Sheet1"") Set Sh2 = Sheets(""Sheet2"") Sh2.Range(""A1:A"" & Sh2.Range(""A65536"").End(xlUp).Row).Clear For Each MyRng In Sh1.Range(""A1:A100"") If MyRng.Interior.ColorIndex = 6 Then Nrow = Sh2.Range(""A65536"").End(xlUp).Row + 1 Sh1.Rows(MyRng.Row).Copy Sh2.Range(""A"" & Nrow).PasteSpecial End If Next Application.CutCopyMode = False Range(""A1"").Select End Sub " Sayfa1 de arar bulur, Sayfa2 de listeler "Sub Arabul_listele() Dim i As Integer Dim j As Integer Dim Sayac As Integer Dim SinananVeri As String Veri = InputBox(""Aranan Veriyi Belirtiniz"", ""ARANAN VERİ"", """") SinananVeri = ""*"" & Veri & ""*"" Set Say1 = Worksheets(""Sayfa1"") Set Say2 = Worksheets(""Sayfa2"") j = 1 For i = 1 To 10 If WorksheetFunction.CountIf(Say2.Cells(i, 1), SinananVeri) > 0 Then Say1.Cells(j, 1) = Say2.Cells(i, 1) Sayac = Sayac + 1 j = j + 1 End If Next i MsgBox Say2.Name & ""'de aramış olduğunuz "" & Veri & "" verisini içeren toplam "" & Sayac & "" adet hücre değeri bulundu ve "" & Say1.Name & ""'de listelendi."" End Sub" Sayfa1 excel aÇilirken 10 sanİye gÖzÜksÜn. "Application.wait metodu ile visual basic kodu: Sub Auto_Open() Sheets(""sayfa1"").Select Application.Wait Now + TimeValue(""00:00:10"") Sheets(""sayfa2"").Select End Sub Application.ontime metodu ile visual basic kodu: Sub Auto_Open() Sheets(""sayfa1"").Select zaman = Now + TimeValue(""00:00:10"") Application.OnTime zaman, ""sayfasec"" End Sub Sub sayfasec() Sheets(""sayfa2"").Select End Sub " Sayfa1 excel aÇilirken 10 sanİye gÖzÜksÜn "Application.wait metodu ile visual basic kodu: Sub Auto_Open() Sheets(""sayfa1"").Select Application.Wait Now + TimeValue(""00:00:10"") Sheets(""sayfa2"").Select End Sub Application.ontime metodu ile visual basic kodu: Sub Auto_Open() Sheets(""sayfa1"").Select zaman = Now + TimeValue(""00:00:10"") Application.OnTime zaman, ""sayfasec"" End Sub Sub sayfasec() Sheets(""sayfa2"").Select End Sub " Sayfa1 i yazdırma "Sub Print() Sheets(""Sayfa1"").PrintOut End Sub" Sayfa1 in tam ekran olması " Private Sub Workbook_Activate() If ActiveSheet.Name = ""Sayfa1"" Then Application.DisplayFullScreen = True End Sub Private Sub Workbook_Deactivate() Application.DisplayFullScreen = False End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) If ActiveSheet.Name = ""Sayfa1"" Then Application.DisplayFullScreen = True End Sub Private Sub Workbook_SheetDeactivate(ByVal Sh As Object) Application.DisplayFullScreen = False End Sub" Sayfa1'deki bütün kodları silebilirsiniz "Sub kod_sil() With ThisWorkbook.VBProject.VBComponents(""Sayfa1"").CodeModule .DeleteLines 1, .CountOfLines End With End Sub" Sayfa2 ye geçince b1 hücresini seç ve macro çalıştır: "Private Sub Worksheet_Activate() Range(""B1"").Select MsgBox""Sayfa2 ye Hoş Geldiniz"" End Sub" Sayfa2 yi çok gizler "Sub Hide_WS2() Worksheets(2).Visible = xlVeryHidden End Sub" Sayfa2 yi gizler "Sub Hide_WS1() Worksheets(2).Visible = Hide End Sub" Sayfa2 yi gizler gösterir(sırayla 2 tane tıkla) "Sub Toggle_Hidden_Visible() Worksheets(2).Visible = Not Worksheets(2).Visible End Sub" Sayfa2 yi göster "Sub UnHide_WS() Worksheets(2).Visible = True End Sub" Sayfada a,b,c,d harflerinden birine tıklayınca istenileni yazdırma "Thisworkbooka Option Explicit Private Sub Workbook_Deactivate() With Application.AutoCorrect .DeleteReplacement What:=""a"" .DeleteReplacement What:=""b"" .DeleteReplacement What:=""c"" .DeleteReplacement What:=""d"" End With End Sub Private Sub Workbook_Open() With Application.AutoCorrect .AddReplacement What:=""a"", Replacement:=""Klaus"" .AddReplacement What:=""b"", Replacement:=""Marcus"" .AddReplacement What:=""c"", Replacement:=""Peter"" .AddReplacement What:=""d"", Replacement:=""Berti"" End With End Sub" Sayfada b5:g22 arasını seçtirmeme "Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.CellDragAndDrop = False If Intersect(Target, Range(""B5:G22"")) Is Nothing Then Range(""A1"").Select End If End Sub" Sayfada belli hücrelere veri girilince yanındaki satıra tarihini atar "Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim RaBereich As Range, RaZelle As Range Set RaBereich = Range(""B3:B20, D1:D7"") ' ActiveSheet.Unprotect Application.EnableEvents = False For Each RaZelle In Range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then RaZelle.Offset(0, 1) = Date Next RaZelle ' ActiveSheet.protect Application.EnableEvents = True Set RaBereich = Nothing End Sub" Sayfada boş satırları gizler "Sub bossatir_gizle() Rows(""1:250"").EntireRow.Hidden = False For x = 5 To 250 gizle = 0 For y = 2 To 5 If Cells(x, y) <> 0 Then gizle = 1 Next y If Cells(x, 6) = ""E"" Then gizle = 1 If gizle = 0 Then Rows(x & "":"" & x).EntireRow.Hidden = True End If Next x Columns(""C:J"").EntireColumn.AutoFit End Sub " Sayfada boş satırları göster "Sub satirlari_ac() Rows(""1:250"").EntireRow.Hidden = False End Sub" Sayfada bul ve gÖster "Ocak, Ã ubat, Mart gibi aylar A2:A13 aralığında, 1975, 1976,. gibi yıllar B1:L1 aralığında, UserForm üzerinde TextBox1, TextBox2, Label1 ve CommandButton1 nesneleri varsa; Kod: Private Sub CommandButton1_Click() On Error GoTo ResumeSub: x = Range(""A2:A13"").Cells.Find(TextBox1).Row y = Range(""B1:L1"").Cells.Find(TextBox2).Column Label1.Caption = Cells(x, y) Exit Sub ResumeSub: Label1.Caption = ""Deger bulunamadi ."" End Sub " Sayfada buton ismi öğrenme "Sub buton_text() MsgBox (ActiveSheet.Buttons(Application.Caller).Text) End Sub" Sayfada büyük harf 1 "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 Or Target.Column = 3 Or Target.Column = 4 Then kelime = Replace(Target.Value, ""i"", ""İ"") kelime = Replace(kelime, ""ı"", ""I"") Target.Value = StrConv(kelime, vbUpperCase) End If End Sub" Sayfada büyük harf 2 "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = ""$A$"" & Target.Row Then kelime = Replace(Target.Value, ""i"", ""İ"") kelime = Replace(kelime, ""ı"", ""I"") Target.Value = StrConv(kelime, vbUpperCase) ElseIf Target.Address = ""$C$"" & Target.Row Then kelime = Replace(Target.Value, ""i"", ""İ"") kelime = Replace(kelime, ""ı"", ""I"") Target.Value = StrConv(kelime, vbUpperCase) ElseIf Target.Address = ""$D$"" & Target.Row Then kelime = Replace(Target.Value, ""i"", ""İ"") kelime = Replace(kelime, ""ı"", ""I"") Target.Value = StrConv(kelime, vbUpperCase) End If End Sub" Sayfada çift tıklama ile saat ekleme "Sub auto_open() Worksheets(""Sayfa1"").OnDoubleClick = ""Mein_Makro"" End Sub Sub Mein_Makro() ActiveCell.Value = Time End Sub" Sayfada çift tıklama yasak "Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, _ ByVal Target As Range, ByVal Cancel As Boolean) Cancel = True End Sub" Sayfada enter ile bir üst hücreye "Sayfanın kod bölümüne Private Sub Worksheet_Activate() Application.MoveAfterReturnDirection = xlUp End Sub Private Sub Worksheet_Deactivate() Application.MoveAfterReturnDirection = xlDown End Sub 'Thisworkbook a Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.MoveAfterReturnDirection = xlDown End Sub" Sayfada enter ile sağa doğru ilerleme "Sayfanın kod bölümüne Private Sub Worksheet_Activate() Application.MoveAfterReturnDirection = xlToRight End Sub Private Sub Worksheet_Deactivate() Application.MoveAfterReturnDirection = xlDown End Sub 'Thisworkbook a Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.MoveAfterReturnDirection = xlDown End Sub" Sayfada enter iptali "Sayfanın kod bölümüne Private Sub Worksheet_Activate() Application.MoveAfterReturnDirection = xlToLeft End Sub Private Sub Worksheet_Deactivate() Application.MoveAfterReturnDirection = xlDown End Sub 'Thisworkbook a Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.MoveAfterReturnDirection = xlDown End Sub" Sayfada formüller silinmesin (diğerlerinin silinmesine izin verir) "Sayfanın kod bölümüne Option Explicit Private Sub Worksheet_Deactivate() Application.OnKey ""{del}"" End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.HasFormula Then Application.OnKey ""{del}"", """" Else Application.OnKey ""{del}"" End If End Sub 'Thisworbook a Option Explicit" Sayfada formülleri silmeyi engelleme (delete tuş iptali) "sayfanın kod bölümüne Private Sub Worksheet_Deactivate() Application.OnKey ""{del}"" End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.HasFormula Then Application.OnKey ""{del}"", """" Else Application.OnKey ""{del}"" End If End Sub" Sayfada formüllü hücreleri records sayfasına ayrıntılı kaydeder "Sub ListNames() On Error GoTo ErrHndlr Application.ScreenUpdating = False Set OutputRange = Selection RetSheet = ActiveSheet.Name NameCnt = ActiveWorkbook.Names.Count For Each Sheet In ActiveWorkbook.Sheets Sheet.Select Set FnRange = Cells.SpecialCells(xlFormulas) For i = 1 To NameCnt With FnRange Set c = .Find(ActiveWorkbook.Names(i).Name, LookIn:=xlFormulas) If Not c Is Nothing Then firstAddress = c.Address Do OutputRange.Offset(n, 0).Value = ActiveWorkbook.Names(i).Name OutputRange.Offset(n, 1).Value = ActiveSheet.Name OutputRange.Offset(n, 2).Value = c.Address(False, False) OutputRange.Offset(n, 3).Value = ""'"" & c.Formula OutputRange.Offset(n, 4).Value = c.Value n = n + 1 Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With Next i Next Sheet Sheets(RetSheet).Select Application.ScreenUpdating = True Exit Sub ErrHndlr: Set FnRange = Cells(1, 1) Resume Next End Sub Sub FindNakamedRangeReferences() Dim NameArray() As String Count = 0 Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Sheets(""Record"").Delete Worksheets(1).Select Worksheets.Add.Name = ""Record"" With Worksheets(""Record"") .Range(""a1"").Value = ""Worksheet Name"" .Range(""b1"").Value = ""Cell Address"" .Range(""c1"").Value = ""Formula"" .Range(""d1"").Value = ""Value"" End With NamedRangeCount = ActiveWorkbook.Names.Count ReDim NameArray(NamedRangeCount) For i = 1 To NamedRangeCount NameArray(i) = ActiveWorkbook.Names.Item(i).Name Next i For j = 2 To ActiveWorkbook.Sheets.Count On Error Resume Next Worksheets(j).Activate Range(""a1"").Select Worksheets(j).Range(""a1"", Range(""a1"").SpecialCells(xlCellTypeLastCell)). _ SpecialCells(xlCellTypeFormulas).Select For Each myCell In Selection For i = 1 To NamedRangeCount If (InStr(myCell.Formula, NameArray(i)) <> 0) Then Worksheets(""Record"").Cells(2, 1).Offset(Count, 0).Value = Worksheets(j).Name Worksheets(""Record"").Cells(2, 1).Offset(Count, 1).Value = myCell.Address Worksheets(""Record"").Cells(2, 1).Offset(Count, 2).Value = ""'"" & myCell.Formula Worksheets(""Record"").Cells(2, 1).Offset(Count, 3).Value = myCell.Value Worksheets(""Record"").Cells(2, 1).Offset(Count, 4).Value = NameArray(i) Count = Count + 1 End If Next i Next myCell Next j Sheets(""Record"").Select End Sub" Sayfada internet explorer ile internet "Thisworkbooka Private Sub Workbook_Open() Tabelle1.WebBrowser1.Navigate ""http://www.excel-lex.de.vu"" End Sub" Sayfada kaç adet formül var sayar bulur "Sub Countformula() Dim R As Integer R = 0 Range(Cells(1, 1), Selection.SpecialCells(xlLastCell)).Select For Each Cell In Selection If Left(Cell.Formula, 1) = ""="" Then R = R + 1 End If Next Cell Selection.SpecialCells(xlFormulas, 23).Select MsgBox ""toplam "" & R & "" adet formül bulundu. Sayfa "" & ActiveSheet.Name & "" de"" End Sub Sub CountFormSub() MsgBox ActiveSheet.UsedRange.SpecialCells(xlFormulas).Count End Sub Function countformulas() As Integer Dim x As Range Dim y As Integer Application.Volatile For Each x In ActiveSheet.UsedRange If x.HasFormula Then y = y + 1 Next x countformulas = y End Function" Sayfada kayan yazi "SAYFADA KAYAN YAZI Sub KayanYazi() [J2] = """" For i = 1 To 10 On Error Resume Next For j = 1 To 1000000 j = j + 0 Next j Cells(1, i).Value = ""kayan yazi"" Cells(1, i - 1).Value = """" Next End Sub " Sayfada koruma olup olmadığını öğrenme "Sub Blattschutz_Ja_Nein() If ActiveSheet.ProtectContents = True Then MsgBox ""sayfa korumalı !"", 64, ""BLATTSCHUTZ"" Exit Sub End If If ActiveSheet.ProtectContents = False Then MsgBox ""Sayfada koruma yok !"", 64, ""BLATTSCHUTZ"" Exit Sub End If End Sub" Sayfada link silme "Private Sub Worksheet_Change(ByVal Target As Excel.Range) ActiveSheet.Hyperlinks.Delete End Sub" Sayfada metin kutusu oluşturma "Sub Make_Textbox() r = 5 c = 5 w = Cells(1, 1).Resize(1, c).Width h = Cells(1, 1).Resize(r, 1).Height Worksheets(1).Shapes.AddTextbox(msoTextOrientationHorizontal, w, h, 200, 50).TextFrame.Characters.Text = ""Test Box"" End Sub" Sayfada not verme "Sub Case_Kullan() Select Case ActiveCell.Value Case 0 To 44 ActiveCell.Offset(0, 1).Value = ""Kaldı"" Case 45 To 60 ActiveCell.Offset(0, 1).Value = ""Orta"" Case 61 To 80 ActiveCell.Offset(0, 1).Value = ""İyi"" Case 81 To 100 ActiveCell.Offset(0, 1).Value = ""Pekiyi"" End Select End Sub" Sayfada numerik değer girilirse mesaj ver "Private Sub Worksheet_Change(ByVal Target As Range) If IsNumeric(Target) Then MsgBox ""Dikkat?"", vbQuestion + vbYesNo Else MsgBox """", vbQuestion + vbYesNo End If End Sub " Sayfada rakamı bul veya yakınını bulma "Sub YakiniBul() Dim i As Integer Dim hucre As Range Range(""A1:A1000"").ClearFormats k = Abs(Range(""c1"") - Range(""B1"")) For i = 1 To WorksheetFunction.CountA(Range(""B1:B1000"")) deger = Abs(Range(""c1"") - Cells(i, 2)) If deger > k Then GoTo git Else k = deger End If git: Next i For Each hucre In Range(""B1:B1000"") If hucre.Value = k + Range(""C1"") Then hucre.Offset(0, -1).Font.ColorIndex = 3 ElseIf hucre.Value = Abs(k - Range(""C1"")) Then hucre.Offset(0, -1).Font.ColorIndex = 3 End If Next hucre End Sub" Sayfada renklendirilmesini istediğiniz sayıyı msgboxa yazınız "Option Explicit Option Compare Text Sub Check_Values_1() On Error Resume Next Dim CurCell As Range Dim Heading As String Dim Prompt As String Dim Criteria As Variant Dim Color As Long Dim lRows As Long Dim lCols As Long Dim lAllCells As Long lRows = ActiveSheet.Rows.Count lCols = ActiveSheet.Columns.Count lAllCells = lRows * lCols If Selection.Cells.Count = lAllCells Then MsgBox ""To check the entire sheet, please select only one cell"", 64 Exit Sub End If Heading = ""Enter Criteria"" Prompt = ""Enter the value you want to find and highlight."" Color = 3 Criteria = InputBox(Prompt, Heading) If Criteria = """" Then Exit Sub ElseIf IsNumeric(Criteria) Then Criteria = CLng(Criteria) ElseIf IsDate(Criteria) Then Criteria = CDate(Criteria) Else Criteria = CStr(Criteria) End If If Selection.Cells.Count > 1 Then For Each CurCell In Selection If CurCell.Value = Criteria Then CurCell.Interior.ColorIndex = Color Next CurCell Else For Each CurCell In ActiveSheet.UsedRange If CurCell.Value = Criteria Then CurCell.Interior.ColorIndex = Color Next CurCell End If End Sub" Sayfada resim (image) silme "Sub Macro1() ActiveSheet.DrawingObjects.Delete End Sub" Sayfada sabitlik "Menü aşağı-yukarı ve sağa-sola scrollunu kullanmanıza izin vermez. Basit bir kod, deneyince görürsünüz. Option Explicit Private Sub Workbook_Open() Sheets(""Anasayfa"").Select Sheets(""Anasayfa"").Range(""a1:p40"").ClearContents Sheets(""Anasayfa"").ScrollArea = ""c5"" End Sub" Sayfada sadece formüllü hücreleri kilitler diğerleri açık kalır "Sub formschutz() On Error GoTo fehlerbeh Application.ScreenUpdating = False ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _ Scenarios:=False With Cells .Locked = False .FormulaHidden = False End With With Cells.SpecialCells(xlFormulas, 23) .Locked = True .FormulaHidden = True End With ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _ Scenarios:=True Exit Sub fehlerbeh: If Err.Number <> 0 Then MsgBox Err.Description End If Application.ScreenUpdating = True End Sub" Sayfada sağ fareye menü "Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _ Cancel As Boolean) Dim icbc As Object For Each icbc In Application.CommandBars(""cell"").Controls If icbc.Tag = ""brccm"" Then icbc.Delete Next icbc If Not Application.Intersect(Target, Range(""b1:b10"")) _ Is Nothing Then With Application.CommandBars(""cell"").Controls _ .Add(Type:=msoControlButton, before:=6, _ temporary:=True) .Caption = ""New Context Menu Item"" .OnAction = ""MyMacro"" .Tag = ""brccm"" End With End If End Sub" Sayfada sağ fareye menü ekleme "Sub Auto_Open() With ShortcutMenus(xlWorksheetCell) .MenuItems.AddMenu ""Menüpunkt1"" With ShortcutMenus(xlWorksheetCell) _ .MenuItems(""Menüpunkt1"") .MenuItems.Add ""Untermenüpunkt1_1"", _ OnAction:=""Makro1"" .MenuItems.Add ""Untermenüpunkt1_2"", _ OnAction:=""Makro2"" .MenuItems.Add ""Untermenüpunkt3"", OnAction:=""Makro3"" End With .MenuItems.AddMenu ""Menüpunkt2"" With ShortcutMenus(xlWorksheetCell) _ .MenuItems(""Menüpunkt2"") .MenuItems.Add ""Untermenüpunkt2_1"", _ OnAction:=""Makro3"" .MenuItems.Add ""Untermenüpunkt2_2"", _ OnAction:=""Makro4"" End With End With End Sub Sub auto_close() Application.CommandBars(""Cell"").Reset End Sub" Sayfada sağ klik geçersiz "Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, _ Cancel As Boolean) Cancel = True MsgBox ""Sağ klik yasaklanmıştır! pir"" End Sub" Sayfada satır açar "Sub satirac() Dim i As Long Dim gec, s, st As String Sheets(""CIRO"").Select For i = 1 To 3000 s = Cells(i, 1).Value If i > 2 Then gec = Cells(i - 1, 1).Value Else gec = s If s = """" Then GoTo son If i = 82 Then s = s End If If (s <> gec) And (gec <> """") Then st = Str(i) Rows(st).Select Selection.Insert Shift:=xlDown ActiveCell.Value = gec + ""TOPLAM"" Selection.Interior.ColorIndex = 40 Selection.Font.Bold = True i = i + 1 End If Next i son: End Sub" Sayfada tanımlanan adları silme "Sub DeleteNames() Dim NameX As Name For Each NameX In Names ActiveWorkbook.Names(NameX.Name).Delete Next NameX End Sub" Sayfada tanımlı adları siler "Sub DeleteAllNames() Dim Nm As Name For Each Nm In Names Nm.Delete Next End Sub" Sayfada yazdığın her harfi büyük harfe çevirir "Private Sub Worksheet_Change(ByVal Target As Excel.Range) Application.EnableEvents = False Target = UCase(Target) Application.EnableEvents = True End Sub" Sayfada, hücrede çift tıklamayla diğer sayfaya gitme "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) sayfa = Target.Cells.Value Sheets(""Sayfa3"").Select End Sub " Sayfada, hücrede tek tıklamayla diğer sayfaya gitme "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = ""$C$18"" Then Sheets(""Sayfa2"").Select End Sub " Sayfadaki butonların üzerine gitme "Private Declare Function SetCursorPos Lib ""user32"" (ByVal X As Long, ByVal Y As Long) As Long 'pir buton1 c4:e7 genişiliğinde 'buton2 g12:ı15 Sub Cursor1() SetCursorPos 540, 350 'hier die Bildschirmposition anpassen End Sub Sub Cursor2() SetCursorPos 220, 200 End Sub" Sayfadaki butonun çalışmasını engeller "Sub sheetbuton_disable () Sheets(""Sayfa1"").Buttons(1).Enabled = False End Sub" Sayfadaki commandbuttonun basılmasını önleme "Sub SchaltflaecheInaktivieren() Sheets(""Sayfa1"").Buttons(1).Enabled = False End Sub" Sayfadaki dolu alanı seçmek "activesheet.usedrange.select veya, C2 den başlayarak C sütunundaki son dolu hücreye kadar seçim: range(""c2:c"" & cells(65536, 3).end(xlup).row).select başka bir yazım şekli de; range(""c2:c"" & range(""c65536"").end(xlup).row).select" Sayfadaki en son dolu hücreden üstteki boş hücreleri siler "Sub DeleteEmptyRows() LastRow = ActiveSheet.UsedRange.Row - 1 + _ ActiveSheet.UsedRange.Rows.Count Application.ScreenUpdating = False For r = LastRow To 1 Step -1 If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete Next r End Sub SATIR BOŞLUKLARINI DOLDURUR(sayfada) Private Sub CommandButton8_Click() LastRow = ActiveSheet.UsedRange.Row - 1 + _ ActiveSheet.UsedRange.Rows.Count Application.ScreenUpdating = False For r = LastRow To 1 Step -1 If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete Next r End Sub " Sayfadaki formüllü hücrelerin formüllerini açıklama olarak ekleme ve silme "Sub FormulesEnCommentaires() Dim cell, largeur, hauteur On Error Resume Next For Each cell In ActiveSheet.UsedRange If cell.HasFormula Then cell.AddComment cell.Comment.Text Text:=cell.FormulaLocal With cell.Comment.Shape largeur = .Width hauteur = .Height .TextFrame.AutoSize = True If .Width > 350 Then .Width = 350 .Height = 55 End If End With End If Next End Sub Sub SupprimeCommentaires() For i = ActiveSheet.Comments.Count To 1 Step -1 ActiveSheet.Comments(i).Delete Next i End Sub" Sayfadaki kilitli hücrenin kilidini çift tıklama ile açma "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) ActiveSheet.Unprotect (kubilay) End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) ActiveSheet.Protect password:=kubilay, DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub" Sayfadaki resmi 180 derece çevirme "Sub Rotate() ' select the shape that called this macro ActiveSheet.Shapes(Application.Caller).Select For i = 1 To 180 Selection.ShapeRange.IncrementRotation 4 Application.Calculate ' Just to slow things down a bit Next i Range(""A1"").Select End Sub" Sayfadan adres alıp sütun genişliği ayarlama "Sub Summary_All_Worksheets_With_Formulas() Dim Sh As Worksheet Dim Newsh As Worksheet Dim myCell As Range Dim ColNum As Integer Dim RwNum As Long Dim Basebook As Workbook With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With Set Basebook = ThisWorkbook Set Newsh = Basebook.Worksheets.Add On Error Resume Next Newsh.Name = ""Summary-Sheet"" If Err.Number > 0 Then MsgBox ""The Summary sheet already exist in this workbook."" With Application .DisplayAlerts = False Newsh.Delete .DisplayAlerts = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With Exit Sub End If RwNum = 1 'The links to the first sheet will start in row 2 For Each Sh In Basebook.Worksheets If Sh.Name <> Newsh.Name And Sh.Visible Then ColNum = 1 RwNum = RwNum + 1 Newsh.Cells(RwNum, 1).Value = Sh.Name 'Copy the sheet name in the A column For Each myCell In Sh.Range(""A1,D5:E5,Z10"") ' <----Change the range ColNum = ColNum + 1 Newsh.Cells(RwNum, ColNum).Formula = _ ""='"" & Sh.Name & ""'!"" & myCell.Address(False, False) Next myCell End If Next Sh Newsh.UsedRange.Columns.AutoFit With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub " Sayfadan sayfaya geçerken hangi sayfanın aktif olduğunu mesajla bildirir "Private Sub Workbook_SheetActivate(ByVal Sh As Object) MsgBox Sh.Name End Sub" Sayfadan sayfaya geçiş "CTRL+PAGE UP, CTRL PAGE DOWN OLAYI İPTALİ Private Sub Workbook_SheetActivate(ByVal Sh As Object) Sheets(""sayfa1"").Select End Sub" Sayfadan var İse sayfaadİ nİ seÇİp sayfa Üzerİnde İŞleme devam edecek yok İse eĞer sayfaadİ altinda yenİ ÇaliŞma sayfasi aÇacak "textbox'larla uğraşmamak için inputbox kullandım, onu değiştirirsiniz. Kodunuzdaki hata elseif için şart döngü içinde kullandığınız için her halikarda sağlanmış oluyor. yani (ElseIf Worksheets(sayfa).Name <> sayfaadi Then ) bu satır sayfalardan birinde illaki sağlanır. visual basic kodu: Sub sayfalar() sayfaadi = InputBox(""sayfaadi"") For sayfa = 1 To Worksheets.Count If Worksheets(sayfa).Name = sayfaadi Then Worksheets(sayfaadi).Select Range(""a4"").Value = 11 Exit Sub End If Next sayfa Worksheets.Add ActiveSheet.Name = sayfaadi ActiveSheet.Select Range(""a4"").Value = 111 End Sub" Sayfakadi dolu alanı seçmek. Satır değişken sütun sabit "activesheet.usedrange.select veya, C2 den başlayarak C sütunundaki son dolu hücreye kadar seçim: range(""c2:c"" & cells(65536, 3).end(xlup).row).select başka bir yazım şekli de; range(""c2:c"" & range(""c65536"").end(xlup).row).select" Sayfakadİ dolu alani seÇmek. "activesheet.usedrange.select veya, C2 den başlayarak C sütunundaki son dolu hücreye kadar seçim: range(""c2:c"" & cells(65536, 3).end(xlup).row).select başka bir yazım şekli de; range(""c2:c"" & range(""c65536"").end(xlup).row).select" Sayfalara araç çubuklu ve menülü geçiş "Sub sheets_menu() Dim sayfamenu As CommandBar, pir As CommandBarButton, sh As Worksheet On Error Resume Next Application.CommandBars(""menuler"").Delete On Error GoTo 0 Set sayfamenu = CommandBars.Add(Name:=""SayfaMenü"", temporary:=True) With sayfamenu .Position = msoBarFloating .Visible = True End With For Each sh In ActiveWorkbook.Sheets Set pir = sayfamenu.Controls.Add(Type:=msoControlButton) With pir .Style = msoButtonCaption .Caption = Left(sh.Name & "" "", 16) .Tag = sh.Name .OnAction = ""Start"" .BeginGroup = True End With Next sh Set pir = sayfamenu.Controls.Add(Type:=msoControlButton) With pir .Style = msoButtonCaption .Caption = ""sayfa geçişi"" .OnAction = ""sheets_menu"" .BeginGroup = True End With sayfamenu.Width = 1 End Sub Sub Start() Sheets(Application.CommandBars.ActionControl.Tag).Activate End Sub ‘thisworkbook a Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error Resume Next Application.CommandBars(""menuler"").Delete On Error GoTo 0 End Sub Private Sub Workbook_Open() Call sheets_menu End Sub" Sayfalara İsteĞe baĞli verİ kaydetmek "Levetn beyin yaptığı kodu devam ediyorum. Aşağıdaki şekle getirirseniz liste sayfasında hangi satırda iseniz o satırı veri giriş sayfasına taşır. Kod: Sub kaydet2() a = ActiveCell.Row Sheets(""liste"").Range(""A"" & a & "":G"" & a).Copy Sheets(""veri"").Range(""B2"").PasteSpecial , , , True Application.CutCopyMode = False End Sub " Sayfalara otomatik özel alt ve üst bilgi ekleme "Sub InsertHeaderFooter() ' inserts the same header/footer in all worksheets Dim ws As Worksheet Application.ScreenUpdating = False For Each ws In ActiveWorkbook.Worksheets Application.StatusBar = ""Changing header/footer in "" & ws.Name With ws.PageSetup .LeftHeader = ""Company name"" .CenterHeader = ""Page &P of &N"" .RightHeader = ""Printed &D &T"" .LeftFooter = ""Path : "" & ActiveWorkbook.Path .CenterFooter = ""Workbook name &F"" .RightFooter = ""Sheet name &A"" End With Next ws Set ws = Nothing Application.StatusBar = False End Sub" Sayfalara Şİfre koymak "Private Sub Worksheet_Activate() Range(""A65536"").Select If InputBox(""şifre Gir?"", ""şifre"") = ""123"" Then Range(""A1"").Select Else MsgBox (""şifre Yanlış"") Sheets(""Sayfa1"").Select End If End Sub ' Sayfayı gizleyin. (Biçim/Sayfa/Gizle) sonra açılış makrusuna şu kodu ekleyin Kod: Sub Auto_Open() [b]Sheets(""Gizli Sayfa"").Visible = True[/b] End Sub Burada mantık şu Makrolar etkinleştirlmesse sayfa görünmez. Etkinleştirldiğinde ise o sayfaya tıklandığında sayfanın kod böülümüne şu kodu ekleyin Kod: Private Sub Worksheet_Activate() Dim sifre Dim durum git: sifre = Application.InputBox(""Lütfen Kullanıcı Kodunu Giriniz"", _ ""Sayın ; "" & Application.UserName, ""şifre"") If sifre = Empty Then Sheets(""DiğerSayfa"").Select If sifre <> ""şifre"" Then durum = MsgBox(""Girdiğiniz şifre Yanlıştır "" _ & vbNewLine & ""Lütfen doru şifre giriniz."" _ & vbNewLine & ""Tekrar şifre Girmek İstiyormusunuz"", vbYesNo, Application.UserName) If durum = vbYes Then GoTo git Else MsgBox ""şifre Doğrudur ..!"", vbInformation, Application.UserName Exit Sub End If Sheets(""DiğerSayfa"").Select End Sub " Sayfaları alfabetik sıralama "Sub SortSheets() Dim SheetNames() As String Dim SheetHidden() As Boolean Dim i As Integer Dim SheetCount As Integer Dim VisibleWins As Integer Dim Item As Object Dim OldActive As Object If ActiveWorkbook Is Nothing Then Exit Sub SheetCount = ActiveWorkbook.Sheets.Count If ActiveWorkbook.ProtectStructure Then MsgBox ActiveWorkbook.Name & "" is protected."", _ vbCritical, ""Cannot Sort Sheets."" Exit Sub End If Application.EnableCancelKey = xlDisabled SheetCount = ActiveWorkbook.Sheets.Count ReDim SheetNames(1 To SheetCount) ReDim SheetHidden(1 To SheetCount) Set OldActive = ActiveSheet For i = 1 To SheetCount SheetNames(i) = ActiveWorkbook.Sheets(i).Name Next i For i = 1 To SheetCount SheetHidden(i) = Not ActiveWorkbook.Sheets(i).Visible If SheetHidden(i) Then ActiveWorkbook.Sheets(i).Visible = True Next i Call BubbleSort(SheetNames) Application.ScreenUpdating = False For i = 1 To SheetCount ActiveWorkbook.Sheets(SheetNames(i)).Move _ before:=ActiveWorkbook.Sheets(i) Next i For i = 1 To SheetCount If SheetHidden(i) Then ActiveWorkbook.Sheets(i).Visible = False Next i OldActive.Activate End Sub Sub BubbleSort(List() As String) Dim First As Integer Dim Last As Integer Dim i As Integer Dim j As Integer Dim Temp As String First = LBound(List) Last = UBound(List) For i = First To Last - 1 For j = i + 1 To Last If UCase(List(i)) > UCase(List(j)) Then Temp = List(j) List(j) = List(i) List(i) = Temp End If Next j Next i End Sub" Sayfaları alfabetik sıralama "Sub sirala() For a = 1 To Sheets.Count For b = a + 1 To Sheets.Count If LCase(Sheets(b).Name) > LCase(Sheets(a).Name) Then GoTo 10 Sheets(b).Move before:=Sheets(a) 10 Next Next End Sub" Sayfaları a-z veya z-a ya göre sıralama "Sub SortSheetUp() Dim iMax As Integer Dim tb1 As Integer Dim tb2 As Integer Application.ScreenUpdating = False iMax = ThisWorkbook.Sheets.Count For tb1 = 1 To iMax For tb2 = tb1 To iMax If UCase(Sheets(tb2).Name) _ < UCase(Sheets(tb1).Name) Then Sheets(tb2).Move before:=Sheets(tb1) End If Next tb2 Next tb1 Application.ScreenUpdating = True End Sub Sub SortSheetDown() Dim iMax As Integer Dim tb1 As Integer Dim tb2 As Integer Application.ScreenUpdating = False iMax = ThisWorkbook.Sheets.Count For tb1 = 1 To iMax For tb2 = tb1 To iMax If UCase(Sheets(tb2).Name) _ > UCase(Sheets(tb1).Name) Then Sheets(tb2).Move before:=Sheets(tb1) End If Next tb2 Next tb1 Application.ScreenUpdating = True End Sub" Sayfaları gösteren userform (form olmadan kod ile) "Option Explicit Dim dlg As DialogSheet ' global variable Sub SheetNavigation() Dim ws As Worksheet Application.ScreenUpdating = False Set dlg = ActiveWorkbook.DialogSheets.Add With dlg.DialogFrame .Left = 0 .Top = 0 .Height = 300 ' dialog height .Width = 300 ' dialog width End With dlg.Buttons(1).Left = 245 ' position of button1 dlg.Buttons(2).Left = 245 ' position of button2 With dlg.ListBoxes.Add(10, 15, 230, 275) ' size of listbox For Each ws In ActiveWorkbook.Worksheets If ws.Visible Then .AddItem ws.Name Next ws .ListIndex = 0 .OnAction = ""DisplaySheet"" End With dlg.DialogFrame.Text = ""Select the worksheet you want to activate"" dlg.Visible = False Application.ScreenUpdating = True If dlg.Show Then Worksheets(dlg.ListBoxes(1).List(dlg.ListBoxes(1).ListIndex)).Activate End If Application.DisplayAlerts = False dlg.Delete Application.DisplayAlerts = True Set ws = Nothing Set dlg = Nothing End Sub Private Sub DisplaySheet() Sheets(dlg.ListBoxes(1).List(dlg.ListBoxes(1).ListIndex)).Activate End Sub" Sayfaları koruma "Public Sub ProtectGroupedSheets() Const csPASSWD As String = ""drowssap"" Dim mySheets As Sheets Dim actSheet As Worksheet Dim wkSht As Worksheet Set actSheet = ActiveSheet Set mySheets = ActiveWindow.SelectedSheets actSheet.Select For Each wkSht In mySheets wkSht.Protect Password:=csPASSWD Next wkSht actSheet.Select mySheets.Select False End Sub" Sayfaları köprü olarak ekler "Sub BlattName() For Blatt = 2 To ActiveWorkbook.Sheets.Count Sheets(1).Cells(Blatt, 1).Select Sheets(Blatt).Name = Sheets(1).Cells(Blatt, 1) ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="""", SubAddress:= _ Sheets(Blatt).Name & ""!A1"", TextToDisplay:=ActiveCell.Formula Next Blatt Sheets(1).Select End Sub" Sayfaları menü olarak ekleme "Dim MyControl Sub Auto_Open() MyMenu Range(""A1"").Select End Sub Sub MyMenu() On Error Resume Next If Not MyControl Is Nothing Then GoTo ResumeSub: Set MyControl = CommandBars.FindControl(Type:=msoControlComboBox, Tag:=""MyMenu"", Visible:=True) MyControl.Delete On Error GoTo 0 Set MyBar = Application.CommandBars(""standard"") Set NewCombo = MyBar.Controls.Add(Type:=msoControlComboBox) ResumeSub: With NewCombo .Clear .Text = ""Sayfa secin"" .Tag = ""MyMenu"" .Width = 150 .Text = ActiveSheet.Name For i = 1 To Worksheets.Count .AddItem Sheets(i).Name, i Next .DropDownLines = 5 .DropDownWidth = 90 .OnAction = ""MyCombo"" End With Set NewCombo = Nothing Set MyBar = Nothing Set MyControl = Nothing End Sub ' Sub MyCombo() Set MyControl = CommandBars.FindControl(Type:=msoControlComboBox, Tag:=""MyMenu"", Visible:=True) Sheets(MyControl.Text).Select Set MyControl = Nothing End Sub ' Sub DelMyMenu() Set MyControl = CommandBars.FindControl(Type:=msoControlComboBox, Tag:=""MyMenu"", Visible:=True) MyControl.Delete Set MyControl = Nothing End Sub ' Sub Auto_Close() DelMyMenu End Sub" Sayfaları seçer aynı hücreleri kalın yapıp, fontunu değiştirir "Sub Alle_auswählen() ReDim Matrixvariable(1 To Sheets.Count) For Each Blattname In Sheets Blattzähler = Blattzähler + 1 Matrixvariable(Blattzähler) = Blattname.Name Next For y = 1 To Blattzähler Next Sheets(Matrixvariable()).Select With Selection.Font .Name = ""Arial"" .Size = 14 End With End Sub" Sayfaları sırala a dan z ye "Sub sayfa_sirala() Dim intI As Integer, intJ As Integer For intI = 1 To Sheets.Count For intJ = 1 To Sheets.Count - 1 If UCase(Sheets(intJ).Name) > UCase(Sheets(intJ + 1).Name) Then Sheets(intJ).Move after:=Sheets(intJ + 1) End If Next Next End Sub" Sayfaları tarar ve veri varsa baskı önizleme yapar "Sub MappeDrucken() Dim Sh As Worksheet For Each Sh In Worksheets If Sh.Visible = True Then Sh.PrintPreview End If Next Sh End Sub" Sayfaları z-a ya sıralar "Sub SortSheets() Dim i As Integer, j As Integer For i = 1 To Sheets.Count For j = 1 To Sheets.Count - 1 If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then Sheets(j).Move after:=Sheets(j + 1) End If Next j Next i End Sub" Sayfaları, sütunları, satırları, hücrelerin raporunu verir "Sub AllsheetsInOpenBooks() 'Example in http://www.mvps.org/dmcritchie/excel/collections.htm Dim wkBook As Workbook, wkSheet As Worksheet ' 2001-11-24 Dim iRow As Long, iSheet As Long: iRow = 1 'Create a new sheet in the current workbook ' added " Sayfalarıdaki verileri seçilen tarih aralığında rapor sayfasına listeyen kodlar aşağıdadır. "Private Sub CommandButton1_Click() Bastar = TextBox1 SonTar = TextBox2 Set S1 = Sheets(""RAPOR"") Range(""A2:F4500"").Select Selection.ClearContents Range(""A2"").Select SAYAC = 1 For sayfa = 1 To Worksheets.Count Worksheets(sayfa).Select If ActiveSheet.Name <> ""RAPOR"" Then 'If [B1] <> ""RAPOR"" Then Range(""b3"").Select Do While ActiveCell.Value <> """" If Format(ActiveCell.Value, ""dd/mm/yyyy"") >= Bastar And Format(ActiveCell.Value, ""dd/mm/yyyy"") <= SonTar Then S1.Cells(1 + SAYAC, 1).Value = SAYAC S1.Cells(1 + SAYAC, 2).Value = ActiveCell.Value S1.Cells(1 + SAYAC, 3).Value = ActiveCell.Offset(0, 1).Value S1.Cells(1 + SAYAC, 4).Value = ActiveCell.Offset(0, 2).Value S1.Cells(1 + SAYAC, 5).Value = ActiveCell.Offset(0, 3).Value S1.Cells(1 + SAYAC, 6).Value = ActiveCell.Offset(0, 4).Value SAYAC = SAYAC + 1 End If ActiveCell.Offset(1, 0).Select Loop End If Next End Sub" Sayfaların index numaraları mesajla, grafik sayfası ekleme "Public Sub WorksheetIndex() Dim I As Integer For I = 1 To ThisWorkbook.Worksheets.Count MsgBox ThisWorkbook.Worksheets(I).Name & _ "" has Index = "" & ThisWorkbook.Worksheets(I).Index Next I End Sub Public Sub InsertChartsBeforeWorksheets()'grafik Dim Worksheet1 As Worksheet For Each Worksheet1 In Worksheets Charts.Add Before:=Sheets(Worksheet1.Index) Next Worksheet1 End Sub Public Sub InsertChartsBeforeWorksheets2() Dim Worksheet1 As Worksheet For Each Worksheet1 In Worksheets Charts.Add Before:=Worksheet Next Worksheet1 End Sub Public Sub InsertChartsAfterWorksheets() Dim Worksheet1 As Worksheet Dim Chart1 As Chart For Each Worksheet1 In Worksheets Set Chart1 = Charts.Add Chart1.Move After:=Worksheet1 Next Worksheet1 End Sub" Sayfaların menü olarak listelenmesi "Sub Menu() Application.CommandBars(""Workbook tabs"").ShowPopup 930, 30 End Sub" Sayfalarızın isimlerini gizleyin "Module bölümüne; Global WCnt Global Sh(1 To 100) As Worksheet Global ShNames(1 To 100) As String 'workbook'un code una; Public Sub Workbook_Open() Dim i As Integer WCnt = Worksheets.Count For i = 1 To WCnt ShNames(i) = Sheets(i).Name Set Sh(i) = Sheets(ShNames(i)) Next i End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim z As Integer For z = 1 To WCnt Sh(z).Name = ShNames(z) Next z End Sub" Sayfalarin kisa yolunu ekrana getİrİr "SAYFA KISA YOLLARINI EKRANA GETİRİR Sub Menu() Application.CommandBars(""Workbook tabs"").ShowPopup 500, 150 End Sub " Sayfam aktİfken dosyam , alt+f4 İle veya x İŞaretİne tiklayarak kapanmasin İstİyorum "ThisWorkbook modulüne yerleştirilecek kodlar: visual basic kodu: Private Sub Workbook_BeforeClose(Cancel As Boolean) If ActiveSheet.Name = ""Liste2"" Then Cancel = True End If End Sub " Sayfanın adını ,footerınada sayfa numarasını yazar.1Of 5 gibi "Sub tester() Dim ws As Worksheet For Each ws In ActiveWorkbook.Worksheets With ws.PageSetup .LeftHeader = ""&A"" .LeftFooter = ""Page &P of &N"" End With Next ws End Sub" Sayfanın en üstüne gider "Sub top() Application.GoTo Reference:=ActiveSheet.Range(""A1""), Scroll:=True End Sub" Sayfanın kopyasını alma (adını siz belirleyin) "Sub copysheets() Dim iMax As Integer Dim tb1 As Integer Dim tb2 As Integer Dim ws As String ws = InputBox(""Bitte geben Sie einen neuen TabBlattNamen ein"") Sheets(""Blanko_zum_Kopieren"").Copy After:=Sheets(1) 'TabBlattName anpassen Sheets(""Blanko_zum_Kopieren (2)"").Name = ws Application.ScreenUpdating = False iMax = ActiveWorkbook.Sheets.Count For tb1 = 1 To iMax For tb2 = tb1 To iMax If UCase(Sheets(tb2).Name) _ < UCase(Sheets(tb1).Name) Then Sheets(tb2).Move before:=Sheets(tb1) End If Next tb2 Next tb1 Application.ScreenUpdating = True End Sub" Sayfanın sağ alt köşesine çalışma kitabının adını alt bilgi olarak yazdırır "Sub PfadInFusszeile() ActiveSheet.PageSetup.LeftFooter = ActiveSheet.Parent.FullName End Sub" Sayfanızda hücreye 1 yazılınca bire karşılık gelen cümle otomatik yazılır "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If IsEmpty(Target) Then Exit Sub If Target = ""1"" Then Target = ""İlçe Milli EĞitim Müdürlüğü"" If Target = ""2"" Then Target = ""Ahmet Aşkın KÜÇÜKKAYA"" If Target = ""3"" Then Target = ""Ordu İli Kabataş İlçesi"" If Target = ""4"" Then Target = ""Kabataş"" End Sub" Sayfanızdaki çalışma alanınızı belirleyen ve iptal eden macrolar "Sub LimiteDefilement() ActiveSheet.ScrollArea = ""A1:A10"" End Sub Sub RetablitDefilement() ActiveSheet.ScrollArea = """" End Sub" Sayfanin aktİf hÜcresİnden aŞaĞiya doĞru sayfalariniza kÖprÜ atilir "çalışma sayfalarınızı yaptıktan sonra makro çalıştırılır v e bulunduğunuz sayfanın aktif hücresinden aşağıya doğru sayfalarınıza köprü atılır Sub Tabellennamen_auflisten() Dim i As Integer Dim myRange As Range Set myRange = ActiveCell myRange.Resize(Worksheets.Count).Select If (MsgBox(""UYARI: Sayfalara köprü oluşturulacak !"" & vbCrLf & _ Chr(13) & "" Emin misin ?"", vbYesNo)) _ <> vbYes Then Exit Sub For i = 1 To Worksheets.Count With myRange.Cells(i) .Value = Worksheets(i).Name .Hyperlinks.Add _ Anchor:=myRange.Cells(i), _ Address:="""", _ SubAddress:=.Value & ""!"" & .Address, _ ScreenTip:=""Blatt ("" & .Value & "")"", _ TextToDisplay:=.Value End With Next i myRange.Select MsgBox ("" Toplam "") & ThisWorkbook.Worksheets.Count & _ ("" Çalışma sayfasına köprü oluşturuldu""), vbOKOnly, ThisWorkbook.Name End Sub" Sayfaya gÖre form aÇ. "Sayfa, CommandButton ve makro isimlerini kendi çalışmana göre düzenle Private Sub CommandButton1_Click() Select Case ActiveSheet.Name Case ""Sheet1"" Makro1 Case ""Sheet2"" Makro2 Case ""Sheet3"" Makro3 Case Else Makro4 End Select Unload Me End Sub " Sayfaya isim verme Sheets("Sayfa1").Name = "Sayfa1" Sayfaya jpeg eklemek "Bu resim ekleme makrosu. Sub ekle() Range(""A3"").Select resimadi = Range(""A1"").Text & "".jpg"" ActiveSheet.Pictures.Insert(""C:\DEN\Resim\"" & resimadi).Select Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Height = 198.75 Selection.ShapeRange.Width = 226.5 Selection.ShapeRange.Rotation = 0# End Sub Silme makrosu da çalışıyor fakat butonları da siliyor. O şimdilik muallakta kalsın yada bir kardeş el atsın Sub sil() ActiveSheet.Shapes.SelectAll Selection.Delete Range(""I7"").Select End Sub" Sayfaya koruma koyma "Sub Protection() ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub" Sayfaya koruma koyma ve kaldırma "Sub KorumaKaldir() Dim ws As Worksheet For Each ws In Worksheets ws.Unprotect (""a"") Next End Sub Sub KorumaKoy() Dim ws As Worksheet For Each ws In Worksheets ws.Protect (""a"") Next End Sub" Sayfaya koruma koyma ve kaldırma "Sub BlattSchutzAus() Dim wks As Worksheet For Each wks In ThisWorkbook.Worksheets wks.Unprotect Password:=""a"" Next wks End Sub Sub BlattSchutzEin() Dim wks As Worksheet For Each wks In ThisWorkbook.Worksheets wks.Protect Password:=""a"" Next wks End Sub" Sayfaya koruma koyma ve kaldırma 2 "Sub deneme() Sheets(""Sayfa1"").Unprotect Password:=""sifre"" 'Buraya sizin kodlarınız yazın Sheets(""Sayfa1"").Protect Password:=""sifre"" End Sub " Sayfaya şifre koymak "Private Sub Worksheet_Activate() Range(""A65536"").Select If InputBox(""Şifre Gir?"", ""Şifre"") = ""123"" Then Range(""A1"").Select Else MsgBox (""Şifre Yanlış"") Sheets(""Sayfa2"").Select End If End Sub " Sayfayı aktive edip aktif hücreye sayı girin "Sub SetValue() Worksheets(""Sheet1"").Activate ActiveCell.Value = 35 End Sub" Sayfayı gizle "Sayfa Gizle Sub auto_open() Worksheets(""Sayfa1"").Visible = False End Sub " Sayfayı kaydederken mesaj farklı kaydet iptal "Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) MsgBox ""Impossible d'enregistrer"" Cancel = False End Sub" Sayfayı kopyalar ve dün tarihli bir sayfa oluşturup bilgileri onun içerisine atar "Sub Add_Sheet() Dim wSht As Worksheet Dim shtName As String shtName = Format(Now - 1, ""dd.mm"") For Each wSht In Worksheets If wSht.Name = shtName Then MsgBox ""Sheet already exists Make necessary "" & _ ""corrections and try again."" Exit Sub End If Next wSht Sheets.Add.Name = shtName Sheets(shtName).Move After:=Sheets(Sheets.Count) Sheets(""Ana_Sayfa"").Range(""A2:F50"").Copy _ Sheets(shtName).Range(""A1"") End Sub" Sayfayı koru c sütununu gizleyerek "Sub Spalten_trotz_Blattschutz_ausblenden() ActiveSheet.Protect userinterfaceonly:=True Columns(""C:C"").Select Selection.EntireColumn.Hidden = True End Sub" Sayfayı mesajla listeler sen sadece numarasını yaz o sayfaya gider "Sub Go2sheet() myShts = ActiveWorkbook.Sheets.Count For i = 1 To myShts myList = myList & i & "" - "" & ActiveWorkbook.Sheets(i).Name & "" "" & vbCr Next i Dim mySht As Single mySht = InputBox(""Select sheet to go to."" & vbCr & vbCr & myList) Sheets(mySht).Select End Sub" Sayfayı Ön İzleme yap "Sub onizleme() ActiveWindow.SelectedSheets.PrintPreview ActiveSheet.DisplayAutomaticPageBreaks = False 'sayfa sonlarını göstermez End Sub " Sayfayı parola ile koruma "Sub ProtectFeuil() Dim sht As Worksheet Dim MotPass MotPass = InputBox(""Taper un mot de passe"", 2) For Each sht In ActiveWorkbook.Worksheets sht.Protect Password:=(MotPass), Contents:=True, _ DrawingObjects:=True, Scenarios:=True Next sht End Sub" Sayfayı yatay yapar ve a1 hücresini yazdırır "Sub PrintRpt1() Sheets(1).PageSetup.Orientation = xlLandscape Range(""a1"").PrintOut Copies:=1 End Sub" Sayfayı yazdırırken çalışma kitabınızın adı ile yazdırır "Sub HeaderName() ActiveSheet.PageSetup.LeftHeader = _ ThisWorkbook.FullName ActiveSheet.PrintPreview End Sub" Sayfayi gİzle "Sayfa Gizle Sub auto_open() Worksheets(""Sayfa1"").Visible = False End Sub " Sayfayi İstenİlen sayi kadar yazdirma ve numaralandirma "Sub aktifsayfayazdir() Dim Kopyasayısı As Long Dim Kopyanumarası As Long Kopyasayısı = Application.InputBox(""Kaç kopya alacaksınız"", Type:=1) For Kopyanumarası = 1 To Kopyasayısı ActiveSheet.PrintOut Next Kopyanumarası End Sub" Sayı bulma "Sub NumeroDeLigne() NumeroLigne = Cells.Find(""100"").Row MsgBox NumeroLigne End Sub" Sayı formatı virgülden sonra 2 basamak TextBox1.text = format(xxxx,"0.00") Sayı tutma "Function Uret(Basamak) ReDim Sayi(0 To Basamak) For i = 1 To Basamak YeniSayiTut: Randomize If i = 1 Then Sayi(i) = Int(Rnd * 9) + 1 Else Sayi(i) = Int(Rnd * 10) End If For j = 1 To i - 1 If Sayi(i) = Sayi(j) Then GoTo YeniSayiTut Next j retStr = retStr & Sayi(i) Next i Uret = Val(retStr) End Function" Sayı yaz sonuna ",00" koysun sütun genişliğini ayarlasın, sola yaslasın "Sub MoveMinus() On Error Resume Next Dim cel As Range Dim myVar As Range Set myVar = Selection For Each cel In myVar If Right((Trim(cel)), 1) = ""-"" Then cel.Value = cel.Value * 1 End If Next With myVar .NumberFormat = ""#,##0.00_);[Red](#,##0.00)"" .Columns.AutoFit End With End Sub" Sayı yuvarla (matematiksel işlemler) "Kod: [code]Sub bicim() [A2].Value = Abs(1) End Sub[/code] Kod: Sub bicim2() [A2].Value = Atn(1) * 1 End Sub Kod: Sub bicim3() '/- sayıları yuvarla '/- 101 sayısını döndürür [A2].Value = Int(100.9 + 0.5) End Sub Kod: Sub bicim4() '/- sayıları yuvarla '/- 100 sayısını döndürür [A2].Value = Int(100.4 + 0.5) End Sub Kod: Sub bicim5() '/- sayıları yuvarla '/- eksi 101 sayısını döndürür [A2].Value = Int(-100.9 + 0.5) End Sub Kod: Sub bicim6() '/- sayıları yuvarla '/- eksi 100 sayısını döndürür [A2].Value = Int(-100.4 + 0.5) End Sub Kod: Sub bicim7() '/- belirtilen sayıda ondalık basamağa yuvarlanmış olan nümerik bir terim döndürür '/- eksi 3 sayısını döndürür [A2].Value = Round(3, 49) End Sub Kod: Sub bicim8() '/- belirtilen sayıda ondalık basamağa yuvarlanmış olan nümerik bir terim döndürür '/- eksi 4 sayısını döndürür [A2].Value = Round(3, 51) End Sub" Sayı yuvarla 1 "[code]Sub bicim() [A2].Value = Abs(1) End Sub[/code]" Sayı yuvarla 2 "Sub bicim2() [A2].Value = Atn(1) * 1 End Sub" Sayı yuvarla 3 "Sub bicim3() '/- belirtilen sayıda ondalık basamağa yuvarlanmış olan nümerik bir terim döndürür '/- eksi 3 sayısını döndürür [A2].Value = Round(3, 49) End Sub" Sayı yuvarla 4 "Sub bicim4() '/- belirtilen sayıda ondalık basamağa yuvarlanmış olan nümerik bir terim döndürür '/- eksi 4 sayısını döndürür [A2].Value = Round(3, 51) End Sub" Sayıyı dakika ve saniye cinsinden yazma "örnek textbox1=150 'textbox2=2 dakika 30saniye Private Sub CommandButton1_Click() Dim Isec As Integer Isec = Val(TextBox1.Text) BreakSec = Str$(Int(Isec / 60)) & "" dakika "" & Str$(Isec Mod 60) & "" saniye "" TextBox2.Text = BreakSec End Sub" Sayıyı dolar olarak okuma =dollartext(a1) "Function DollarText(vNumber) As Variant 'see also Function SpellNumber(ByVal MyNumber), PSS ID Number: Q140704 Dim sDollars As String Dim sCents As String Dim iLen As Integer Dim sTemp As String Dim iPos As Integer Dim iHundreds As Integer Dim iTens As Integer Dim iOnes As Integer Dim sUnits(2 To 5) As String Dim bHit As Boolean Dim vOnes As Variant Dim vTeens As Variant Dim vTens As Variant If Not IsNumeric(vNumber) Then Exit Function End If sDollars = Format(vNumber, ""###0.00"") iLen = Len(sDollars) - 3 If iLen > 15 Then DollarText = CVErr(xlErrNum) Exit Function End If sCents = Right$(sDollars, 2) & ""/100 Dollar"" 'Hier die Währung ändern If vNumber < 1 Then DollarText = sCents Exit Function End If sDollars = Left$(sDollars, iLen) vOnes = Array("""", ""one"", ""two"", ""three"", ""four"", ""five"", _ ""six"", ""seven"", ""eight"", ""nine"") vTeens = Array(""ten"", ""eleven"", ""twelve"", ""thirteen"", ""fourteen"", _ ""fifteen"", ""sixteen"", ""seventeen"", ""eighteen"", ""nineteen"") vTens = Array("""", """", ""twenty"", ""thirty"", ""forty"", ""fifty"", _ ""sixty"", ""seventy"", ""eighty"", ""ninety"") sUnits(2) = ""thousand"" sUnits(3) = ""million"" sUnits(4) = ""billion"" sUnits(5) = ""trillion"" sTemp = """" For iPos = 15 To 3 Step -3 If iLen >= iPos - 2 Then bHit = False If iLen >= iPos Then iHundreds = Asc(Mid$(sDollars, iLen - iPos + 1, 1)) - 48 If iHundreds > 0 Then sTemp = sTemp & "" "" & vOnes(iHundreds) & "" hundred"" bHit = True End If End If iTens = 0 iOnes = 0 If iLen >= iPos - 1 Then iTens = Asc(Mid$(sDollars, iLen - iPos + 2, 1)) - 48 End If If iLen >= iPos - 2 Then iOnes = Asc(Mid$(sDollars, iLen - iPos + 3, 1)) - 48 End If If iTens = 1 Then sTemp = sTemp & "" "" & vTeens(iOnes) bHit = True Else If iTens >= 2 Then sTemp = sTemp & "" "" & vTens(iTens) bHit = True End If If iOnes > 0 Then If iTens >= 2 Then sTemp = sTemp & ""-"" Else sTemp = sTemp & "" "" End If sTemp = sTemp & vOnes(iOnes) bHit = True End If End If If bHit And iPos > 3 Then sTemp = sTemp & "" "" & sUnits(iPos \ 3) End If End If Next iPos DollarText = Trim(sTemp) & "" and "" & sCents End Function 'DollarText" Sayıyı paranteze alma örnek: 3- = (3) sayının yanına çizgi şart "Sub DashMasher() On Error Resume Next Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Set TextCells = Cells.SpecialCells(xlCellTypeConstants, xlTextValues) n = TextCells.Count For Each Cell In TextCells x = Cell.Value If Right(x, 1) = ""-"" Then x = -Left(x, Len(x) - 1) Cell.Value = x End If c = c + 1 Application.StatusBar = ""Percent Complete: "" & Int(c / n * 100) & ""%"" Next Cell Application.StatusBar = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub" Sayıyı rakama kuruşlu çevirmek " Function ParaCevir(para As Double) If Not IsNumeric(sayi) Then GoTo hata If (para - Int(para)) = 0 Then paracevir= cevir(para) Else tamsayi = cevir(Int(para)) ondalik = cevir((para - Int(para)) * 100) ondalik = LCase(Mid(ondalik, 1, 1)) + Mid(ondalik, 2, Len(ondalik) - 1) paracevir = tamsayi + ""virgül"" + ondalik End If GoTo tamam hata: paracevir = ""Hata"" tamam: End Function Private Function cevir(sayi As Double) Dim b(9) As String Dim y(9) As String Dim m(4) As String Dim v(15) Dim c(3) b(0) = """" b(1) = ""bir"" b(2) = ""iki"" b(3) = ""üç"" b(4) = ""dört"" b(5) = ""beş"" b(6) = ""altı"" b(7) = ""yedi"" b(8) = ""sekiz"" b(9) = ""dokuz"" y(0) = """" y(1) = ""on"" y(2) = ""yirmi"" y(3) = ""otuz"" y(4) = ""kırk"" y(5) = ""elli"" y(6) = ""altmış"" y(7) = ""yetmiş"" y(8) = ""seksen"" y(9) = ""doksan"" m(0) = ""trilyon"" m(1) = ""milyar"" m(2) = ""milyon"" m(3) = ""bin"" m(4) = """" a = Str(Round(sayi, 0)) If Left(a, 1) = "" "" Then pozitif = 1 Else pozitif = 0 a = Right(a, Len(a) - 1) If Len(a) > 15 Then GoTo hata a = String(15 - Len(a), ""0"") + a For x = 1 To 15 v(x) = Val(Mid(a, x, 1)) Next x s = """" For x = 0 To 4 c(1) = v(x * 3 + 1) c(2) = v(x * 3 + 2) c(3) = v(x * 3 + 3) If c(1) = 0 Then e = """" ElseIf c(1) = 1 Then e = ""yüz"" Else e = b(c(1)) + ""yüz"" End If e = e + y(c(2)) + b(c(3)) If e <> """" Then e = e + m(x) If (x = 3) And (e = ""birbin"") Then e = ""bin"" s = s + e Next x If s = """" Then s = ""sıfır"" If pozitif = 0 Then s = ""eksi"" + s cevir = UCase(Mid(s, 1, 1)) + Mid(s, 2, Len(s) - 1) End Function exit sub Hata: cevir=""HATA"" end function" Sayinin karekÖkÜ "İlgili sayıyı sqr() ile karekök olarak dönüştürebilirsiniz. Ã rnek A1 de sayımız olsun; Kod: Sub karekok() sonuc = Sqr(Range(""A1"").Value) MsgBox (sonuc) End Sub" Seç bir aşağıya sürüklesin "Sub Einfügen() Dim Letzte As Long Dim Zeile As Integer Dim I As Long Letzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row Zeile = Application.InputBox(""Nach wieviel Zeilen Leerzeile einfügen"", ""Zeilenanzahl"", 0, Type:=1) If Zeile = 0 Then Exit Sub For I = Letzte To 2 Step Zeile * -1 Rows(I).Insert Shift:=xlDown Next I End Sub" Seç birleştir ortala "Sub CenterAcrossColumns() With Selection .HorizontalAlignment = xlCenterAcrossSelection .MergeCells = False End With End Sub" Seçilen alanın 2 sayfa olarak yazdırılması Selection.PrintOut Copies:=2 Seçilen alanın baskı önizlemesi "Sheets(""Sayfa1"").PageSetup.PrintArea = ""$A$1:$k$58"" ActiveWindow.SelectedSheets.PrintPreview " Seçilen alanları bir kağıtta yazdırır eder "Çoklu çalışma sayfalarında yazdırma (print) komutu uygulaması 'Tüm seçili sayfalardan vede seçili alanlardan tek bir sayfanın print yapılması ? Sub MultiSheetPrint() Dim oActive As Object Dim oSheet As Object Dim oSheets As Object Dim wsPrint As Worksheet Dim oLastPic As Object Dim iPics As Integer ' remember where we are Set oSheets = ActiveWindow.SelectedSheets If oSheets.Count = 1 Then Selection.PrintOut preview:=True Exit Sub End If Set oActive = ActiveSheet Application.ScreenUpdating = False oActive.Select ' otherwise we get lots of new sheets Set wsPrint = Worksheets.Add For Each oSheet In oSheets If TypeName(oSheet) = ""Worksheet"" Then iPics = iPics + 1 oSheet.Activate Selection.CopyPicture wsPrint.Cells(iPics * 3 - 2, 1).Value = oSheet.Name wsPrint.Paste wsPrint.Cells(iPics * 3 - 1, 1) wsPrint.Rows(iPics * 3 - 1).RowHeight = _ wsPrint.Pictures(iPics).Height End If Next wsPrint.PrintOut preview:=True Application.DisplayAlerts = False wsPrint.Delete Application.DisplayAlerts = True oSheets.Select oActive.Activate Application.ScreenUpdating = True End Sub " SeÇİlen alanlari bİr kaĞitda yazdirir eder "Çoklu çalışma sayfalarında yazdırma (print) komutu uygulaması 'Tüm seçili sayfalardan vede seçili alanlardan tek bir sayfanın print yapılması ? Sub MultiSheetPrint() Dim oActive As Object Dim oSheet As Object Dim oSheets As Object Dim wsPrint As Worksheet Dim oLastPic As Object Dim iPics As Integer ' remember where we are Set oSheets = ActiveWindow.SelectedSheets If oSheets.Count = 1 Then Selection.PrintOut preview:=True Exit Sub End If Set oActive = ActiveSheet Application.ScreenUpdating = False oActive.Select ' otherwise we get lots of new sheets Set wsPrint = Worksheets.Add For Each oSheet In oSheets If TypeName(oSheet) = ""Worksheet"" Then iPics = iPics + 1 oSheet.Activate Selection.CopyPicture wsPrint.Cells(iPics * 3 - 2, 1).Value = oSheet.Name wsPrint.Paste wsPrint.Cells(iPics * 3 - 1, 1) wsPrint.Rows(iPics * 3 - 1).RowHeight = _ wsPrint.Pictures(iPics).Height End If Next wsPrint.PrintOut preview:=True Application.DisplayAlerts = False wsPrint.Delete Application.DisplayAlerts = True oSheets.Select oActive.Activate Application.ScreenUpdating = True End Sub " Seçilen dosyanın adını okur "Sub DateinameFiltern() Dim strDName strDName = Application.GetOpenFilename strDName = Dir(strDName) MsgBox strDName End Sub" Seçilen hücre rakamsa 0 yapar harfse yapmaz "Sub ResetValues2() For i = 1 To Worksheets.Count On Error GoTo ErrorHandler For Each n In Worksheets(i).UsedRange If IsNumeric(n) Then If n.Value <> 0 Then n.Value = 0 ProtectedCell: End If End If Next n ErrorHandler: If Err = 1005 Then Resume ProtectedCell End If Next i End Sub" Seçilen hücreler renklenir "Workbook code bölümüne Option Explicit Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range) Static OldCell As Range If Not OldCell Is Nothing Then OldCell.Interior.ColorIndex = xlColorIndexNone End If Target.Interior.ColorIndex = 6 Set OldCell = Target End Sub 'Sayfanın code bölümüne Option Explicit 'son aktif olan hücrenin rengi sabit olarak kalıyor. Buna bir çözüm varmı? Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) ActiveCell.Interior.ColorIndex = xlColorIndexNone End Sub" Seçilen hücrelerdeki formülleri değere dönüştürür "Sub formullerideğeryap() For Each fCell In Selection fCell.Value = fCell.Value Next fCell End Sub" Seçilen hücrelerdeki formülleri değere dönüştürür 2 "Sub metnecevır() Col = 1 DerLig = Cells(65536, Col).End(xlUp).Row For i = 1 To DerLig Cells(i, Col).Formula = ""'"" & Cells(i, Col) Cells(i, Col).Formula = """" & Cells(i, Col) Next i End Sub" Seçilen hücrelerdeki sıralı sayıları tersten sıralar "Sub Cevir() For Each hucre In Selection n = n + 1 Next hucre ReDim aralik(n) For Each hucre In Selection aralik(i) = hucre.Value i = i + 1 Next hucre For Each hucre In Selection i = i - 1 hucre.Value = aralik(i) Next hucre End Sub" Seçilen hücreyi sol üst köşeye alır "Sub TopLeft() ActiveCell.Select With ActiveWindow .ScrollColumn = ActiveCell.Column .ScrollRow = ActiveCell.Row End With End Sub" Seçilen tüm hücreleri 0 yapar "Sub ResetValues() On Error GoTo ErrorHandler For Each n In ActiveSheet.UsedRange If n.Value <> 0 Then n.Value = 0 End If TypeMismatch: Next n ErrorHandler: If Err = 13 Then 'Type Mismatch Resume TypeMismatch End If End Sub" Seçileni word belgesi olarak açar ve kopyalar "Sub WordSheetRangeCopy() Dim WordObj As Object Selection.Copy Set WordObj = CreateObject(""Word.Basic"") With WordObj .AppShow .FileNew .EditPaste End With Set WordObj = Nothing End Sub" Seçilenin yazdırılması ve sorulması "Sub PrintSelectedCells() ' prints selected cells, use from a toolbar button or a menu Dim aCount As Integer, cCount As Integer, rCount As Integer Dim i As Integer, j As Long, aRange As String Dim rHeight() As Single, cWidth() As Single Dim AWB As Workbook, NWB As Workbook If UCase(TypeName(ActiveSheet)) <> ""WORKSHEET"" Then Exit Sub ' useful only in worksheets aCount = Selection.Areas.Count If aCount = 0 Then Exit Sub ' no cells selected cCount = Selection.Areas(1).Cells.Count If aCount > 1 Then ' multiple areas selected Application.ScreenUpdating = False Application.StatusBar = ""Printing "" & aCount & "" selected areas "" Set AWB = ActiveWorkbook rCount = ActiveSheet.Cells.SpecialCells(xlLastCell).Row cCount = ActiveSheet.Cells.SpecialCells(xlLastCell).Column ReDim rHeight(rCount) ReDim cWidth(cCount) For i = 1 To rCount ' find the row height of every row in the selection rHeight(i) = Rows(i).RowHeight Next i For i = 1 To cCount ' find the column width of every column in the selection cWidth(i) = Columns(i).ColumnWidth Next i Set NWB = Workbooks.Add ' create a new workbook For i = 1 To rCount ' set row heights Rows(i).RowHeight = rHeight(i) Next i For i = 1 To cCount ' set column widths Columns(i).ColumnWidth = cWidth(i) Next i For i = 1 To aCount AWB.Activate aRange = Selection.Areas(i).Address ' the range address Range(aRange).Copy ' copying the range NWB.Activate With Range(aRange) ' pastes values and formats .PasteSpecial Paste:=xlValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False .PasteSpecial Paste:=xlFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False End With Application.CutCopyMode = False Next i NWB.PrintOut NWB.Close False ' close the temporary workbook without saving Application.StatusBar = False AWB.Activate Set AWB = Nothing Set NWB = Nothing Else If cCount < 10 Then ' less than 10 cells selected If MsgBox(""Are you sure you want to print "" & _ cCount & "" selected cells ?"", _ vbQuestion + vbYesNo, ""Print celected cells"") = vbNo Then Exit Sub End If Selection.PrintOut End If End Sub" Seçili alanları durum çuğunda anlık toplar "Option Explicit Public bColored As Integer Sub ColoredToBW() Dim cht As Chart Dim chtSC As SeriesCollection Dim x As Integer Dim iSeriesCount As Integer Dim iColors(1 To 5, 0 To 1) As Integer Dim iColor As Integer 'Set colors for BW series iColors(1, 0) = 1 'Black iColors(2, 0) = 56 'Gray-80% iColors(3, 0) = 16 'Gray-50% iColors(4, 0) = 48 'Gray-40% iColors(5, 0) = 15 'Gray-25% 'Set colors for Color series iColors(1, 1) = 55 'Indigo iColors(2, 1) = 7 'pink iColors(3, 1) = 6 'yellow iColors(4, 1) = 8 'Turquoise iColors(5, 1) = 13 'Violet 'Toggle Color/BW change 0 to 1 or 1 to 0 bColored = 1 - bColored Set cht = ActiveChart 'check that a chart is selected If cht Is Nothing Then MsgBox (""Select a chart"") Exit Sub End If Set chtSC = cht.SeriesCollection 'Check for MIN of number of series or 'colors and only do the minimum iSeriesCount = Application.WorksheetFunction.Min _ (UBound(iColors), chtSC.Count) For x = 1 To iSeriesCount 'Define the color iColor = iColors(x, bColored) 'Set the LINE color chtSC(x).Border.ColorIndex = iColor 'Marker color With chtSC(x) .MarkerBackgroundColorIndex = xlNone .MarkerForegroundColorIndex = iColor End With Next x End Sub" Seçili hücrelerdeki en büyük değeri bulur ve kalın yapar "Sub ValMaxi() Dim Cel As Range Dim Val As Integer Dim Adr As String For Each Cel In Selection If Val < Cel Then Val = Cel 'Valeur de la cellule Adr = Cel.Address 'Adresse de la cellule End If Next Range(Adr).Font.Bold = True 'La plus grande valeur est contenu dans la variable Val End Sub" Seçili hücreleri emaille gönderir "Sub Excel_an_Outlook_Aufgabe() On Error GoTo ErrorAufgabe Dim MyError As Integer Dim Faellig As Date Dim Link As String Dim myolApp As Object, myitem As Object 'Eigene Fehleroutine/Nummer eröffnen MyError = 1 'Fälligkeit ist übermorgen Faellig = Date + 1 MyError = 2 Set myolApp = CreateObject(""Outlook.Application"") Set myitem = myolApp.CreateItem(3) myitem.Subject = ""Datei ERFASSEN !"" ' Text der Aufgabe myitem.DueDate = Faellig myitem.ReminderTime = Faellig 'Ein Link kann nur erstellt werden, wenn die Pfadangabe eine 'Angabe mit einem ShareName ist myitem.Body = ""\\Computername\Freigabename\dateiname.xls"" myitem.Save Set myitem = Nothing ErrorExit: Exit Sub ErrorAufgabe: Select Case MyError Case 1 MsgBox ""Die Datei wurde noch nicht gespeichert"" Case 2 MsgBox ""Outlook kann nicht gestartet werden"" & Chr$(13) &_ ""Aufgabe wurde nicht erstellt !"" End Select Resume ErrorExit End Sub" Seçili hücrelerin hepsi küçük harf (yazım düzeni) "Sub LowerCase() Dim cell As Range For Each cell In Selection.Cells If cell.HasFormula = False Then cell = LCase(cell) End If Next End Sub" Seçili hücreye boş bir açıklama ekler "Sub imgComment() Dim nom$ On Error Resume Next For Each C In Selection nom = C.Value With C .AddComment .Comment.Shape.Fill.UserPicture ActiveWorkbook.Path & ""\"" & nom & "".jpg"" End With Next End Sub" Seçili hücreye gider "Sub InserImage() Dim nom$ Dim fichimg$ [C10].Select With ActiveWindow y = .Selection.Width End With On Error Resume Next nom = Selection.Offset(0, -1).Value fichimg = ActiveWorkbook.Path & ""\"" & nom & "".jpg"" ActiveSheet.Pictures.Insert(fichimg).Select Selection.ShapeRange.Width = y End Sub" Seçili hücreye isim verir (ad tanımlar) "Sub RngName() Selection.Name = ""myRange"" End Sub" Seçili hücreye mesajla 100 yazdırır "Sub Message() msg = ""Voulez-vous continuer ?"" ' Définit le message. Style = vbYesNo + vbDefaultButton1 'Définit les boutons. Title = ""Bonjour !"" ' Définit les titres. Réponse = MsgBox(msg, Style, Title) If Réponse = vbYes Then ' Vous avez choisi le bouton "" Oui "". Set MaSélection = Application.ActiveCell MaSélection.Value = 100 Else Range(""A1:b2"").Select ' Accomplit une autre chose. End If End Sub" Seçili hücreyi kopyalar ve word e aktarır "Sub Nach_Word_Kopieren() Dim WordObj As Object Selection.Copy Set WordObj = CreateObject(""Word.Basic"") With WordObj .AppShow 'Word 6/7: .AnwAnzeigen .FileNew 'Word 6/7: .DateiNeu .EditPaste 'Word 6/7: .BearbeitenEinfügen End With Set WordObj = Nothing End Sub" Seçili satırın silinmesi, siğer sütunlardaki formülleri silmeden "Dim s as integer Dim r as integer s = 8 ActiveCell.ClearContents r = ActiveCell.Row Range(""A"" & r + 1 & "":A"" & s).Select Selection.Cut Destination:=Range(""A"" & r & "":A"" & s - 1) Range(""a"" & r).Select" SeÇİm ekle sub Çİft_kayitlarİ_arala "Sub çift_kayıtlari_arala() toplamsatır = ActiveSheet.UsedRange.Rows.Count For Row = toplamsatır To 2 Step -1 If Cells(Row, 1).Value <> Cells(Row - 1, 1).Value Then Rows(Row).Insert Next Row End Sub " Seçli hücrelerin zoom edilmesi "Range(""A1:F15"").Select 'set range zoom ActiveWindow.zoom = True" Seri rakam gir tarihe çevirsin "Dim hucre As Integer Dim eski_hucre, eski_hucre_column As String Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next If eski_hucre_column = ""1"" Then veri = ActiveCell Range(eski_hucre) = Format(DateValue(Left(Range(eski_hucre).Value, 2) & ""."" & _ Mid(Range(eski_hucre).Value, 3, 2) _ & ""."" & Right(Range(eski_hucre), 4)), ""dd.mm.yyyy"") End If eski_hucre = ActiveCell.Address eski_hucre_column = ActiveCell.Column End Sub" Seslİ okutma "Function seslioku(sy) On Error Resume Next sesx$ = ThisWorkbook.Path & ""\"" & ""numaralı cihazın kaydı yapılmıştır.wav"" '--Eklenen kod---- dz1 = Array("" "", ""bir"", ""iki"", ""üç"", ""dört"", ""beş"", ""altı"", ""yedi"", ""sekiz"", ""dokuz"") dz2 = Array("" "", ""on"", ""yirmi"", ""otuz"", ""kırk"", ""elli"", ""altmış"", ""yetmiş"", ""seksen"", ""doksan"") dz3 = Array("" "", """", ""bin"", ""milyon"", ""milyar"", ""trilyon"", ""katrilyon"") tur = Len(sy) \ 3 kalan = Len(sy) Mod 3 k = 2 sayı = """" For i = 1 To tur sya = Mid(sy, (Len(sy) - k), 3) sy1 = dz1(Mid(sya, 3, 1)): sy2 = dz2(Mid(sya, 2, 1)): sy3 = dz1(Mid(sya, 1, 1)) Select Case Mid(sya, 1, 1) Case 1 sy3 = ""yüz"" Case Is > 1 sy3 = sy3 & "" "" & ""yüz"" End Select If i = 2 Then Select Case Val(sya) Case 0 sy1 = """" Case 1 sy1 = ""bin"" Case Is > 1 sy1 = sy1 & "" "" & ""bin"" End Select Else birim = dz3(i) End If If Val(sya) > 0 Then sayı = sy3 & "" "" & Trim(sy2) & "" "" & sy1 & "" "" & birim & "" "" & Trim(sayı) k = k + 3 Else k = k + 3 End If Next i If kalan = 0 Then f = sayı p = InStr(1, LTrim(f), "" "") Do While p > 0 s = Trim(Mid(f, 1, p)) f = LTrim(Mid(f, p, Len(f))) p = InStr(1, f, "" "") ses$ = ThisWorkbook.Path & ""\"" & s & "".wav"" Call PlaySound(ses$, 1, 0) Loop If f <> """" Then s = f ses$ = ThisWorkbook.Path & ""\"" & s & "".wav"" Call PlaySound(ses$, 1, 0) End If Call PlaySound(sesx$, 1, 0) '-------Eklenen kod------ Exit Function Else End If syb = Mid(sy, 1, kalan) sy11 = dz1(Mid(syb, kalan, 1)): sy22 = dz2(Mid(sy, kalan - 1, 1)) If tur = 1 Then Select Case Val(Mid(syb, 1, 2)) Case 0 sy11 = """" Case 1 sy11 = ""bin"" Case Is > 1 sy11 = sy11 & "" "" & ""bin"" End Select Else birim1 = dz3(tur + 1) End If sayı = sy22 & "" "" & sy11 & "" "" & birim1 & "" "" & sayı f = LTrim(sayı) p = InStr(1, f, "" "") Do While p > 0 s = Trim(Mid(f, 1, p)) f = LTrim(Mid(f, p, Len(f))) p = InStr(1, f, "" "") ses$ = ThisWorkbook.Path & ""\"" & s & "".wav"" Call PlaySound(ses$, 1, 0) Loop If f <> """" Then s = f ses$ = ThisWorkbook.Path & ""\"" & s & "".wav"" Call PlaySound(ses$, 1, 0) End If Call PlaySound(sesx$, 1, 0) '-------Eklenen kod------ End Function" Sesli saat "Sub Beeper() Beep start2 = Now() + TimeSerial(0, 0, 0.9) Application.Wait start2 For i = 2 To 3 start2 = Now() + TimeSerial(0, 0, 0.8) Application.Wait start2 Beep Next i End Sub" Sheet'lerİ bİr sheette toplamak "Bu kodu bir module ekleyip çalıştırırsanız kendıne yenı bır sayfa olusturup ne kadar sayfa varsa yenı sayfa da bırlestırıyor. Kod: Sub SayfaBirleştir() Dim YeniSayfa As Worksheet Dim SayfaSay SayfaSay = Worksheets.Count Set YeniSayfa = Worksheets.Add(After:=Worksheets(SayfaSay)) With YeniSayfa For i = 1 To SayfaSay Worksheets(i).UsedRange.Copy .Range(""A"" & IIf(i = 1, 1, .UsedRange.Rows.Count + 1)) Next End With End Sub" Sıfıra bölünme hatasını yakalama "Sub Button32_Click () On Error GoTo HataKontrol A = 5 B = 0 Sunuc = A / B Exit Sub 'burada programa son verilir. HataKontrol: Select Case Err.Number Case 11: Mesaj = ""Sıfıra bölünme hatası oluştu!!!"" End Select MsgBox Mesaj Resume Next End Sub" Sıralı (artan) sayfa ekler "örnek pir1, pir2, pir3 Option Explicit Public addShtCount As Long Public Sub AddSheets() addShtCount = addShtCount + 1 Dim straddShtCount As String straddShtCount = addShtCount newShtName = ""pir"" + straddShtCount Worksheets.Add ActiveSheet.Name = newShtName End Sub" Sıralı sayfa ekler "Sub sayfaekle() For a = 1 To [a3] Sheets.Add.Move After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = a Next End Sub" Sıralı ve hücre genişliğinde textbox oluşturma "Sub textbox_olustur() Dim a, b, c, d, e, f, g, h, i, j, Button Set a = [A2]: Set b = [B2]: Set c = [C2]: Set d = [D2]: Set e = [E2] Set f = [A4]: Set g = [B4]: Set h = [C4]: Set i = [D4]: Set j = [E4] ' Set Button = ActiveSheet.Buttons.Add(a.Left, a.Top, a.Width, a.Height) Set Button = ActiveSheet.Buttons.Add(b.Left, b.Top, b.Width, b.Height) Set Button = ActiveSheet.Buttons.Add(c.Left, c.Top, c.Width, c.Height) Set Button = ActiveSheet.Buttons.Add(d.Left, d.Top, d.Width, d.Height) Set Button = ActiveSheet.Buttons.Add(e.Left, e.Top, e.Width, e.Height) ' Set Button = ActiveSheet.Buttons.Add(f.Left + 3, f.Top + 3, f.Width - 4, f.Height - 4) Set Button = ActiveSheet.Buttons.Add(g.Left + 3, g.Top + 3, g.Width - 4, g.Height - 4) Set Button = ActiveSheet.Buttons.Add(h.Left + 3, h.Top + 3, h.Width - 4, h.Height - 4) Set Button = ActiveSheet.Buttons.Add(i.Left + 3, i.Top + 3, i.Width - 4, i.Height - 4) Set Button = ActiveSheet.Buttons.Add(j.Left + 3, j.Top + 3, j.Width - 4, j.Height - 4) End Sub" Sırasıyla, b,c,d sütunlarına göre sıralama yapar. "Sub sirala() [b3:f65536].Sort Key1:=[B3], Key2:=[C3], Key3:=[D3] End Sub" Sil penceresi "Sub Dialog_26() Application.Dialogs(xlDialogFileDelete).Show End Sub" Simgeleri, menüleri ve butonları sayfaya ekleyin "Dim cbb As CommandBarButton, ComBar As CommandBar, cbc As CommandBarControl Sub CommandBarControlID_List() Dim a, b, c Application.ScreenUpdating = False For Each ComBar In Application.CommandBars If ComBar.Name = ""test"" Then ComBar.Delete Next Set ComBar = Application.CommandBars.Add(Name:=""test"", Position:=msoBarTop) b = 0 c = 1 For a = 1 To 50000 On Error Resume Next Set cbb = ComBar.Controls.Add(ID:=a) If Err.Number <> 0 Then GoTo weiter cbb.CopyFace With Workbooks(""FaceIDs"").Sheets(1) .Cells((c Mod 100) + 1, (c \ 100) + b + 1).Formula = a .Cells((c Mod 100) + 1, (c \ 100) + b + 2).Activate ActiveSheet.Paste .Cells((c Mod 100) + 1, (c \ 100) + b + 3).Formula = cbb.Caption End With If (c + 1) Mod 100 = 0 Then b = b + 3 c = c + 1 weiter: Application.CommandBars(""test"").FindControl(ID:=a).Delete Err.Clear Next End Sub Sub CommandBarFaceID_List() Dim a, b Application.ScreenUpdating = False For Each ComBar In Application.CommandBars If ComBar.Name = ""test"" Then ComBar.Delete Next On Error Resume Next Set ComBar = Application.CommandBars.Add(Name:=""test"", Position:=msoBarTop) Set cbb = ComBar.Controls.Add(ID:=1) b = 0 For a = 1 To 3518 With cbb .FaceId = a .CopyFace End With With ThisWorkbook.Sheets(1) .Cells((a Mod 100) + 1, (a \ 100) + b + 1).Formula = a .Cells((a Mod 100) + 1, (a \ 100) + b + 2).Activate ActiveSheet.Paste End With If (a + 1) Mod 100 = 0 Then b = b + 2 Next End Sub Sub CommandBar_List() Application.ScreenUpdating = False Dim a, b, c, cbc, d b = 1 d = 0 For Each a In Application.CommandBars Cells(b + d, 1) = a.Name Cells(b + d, 2) = ""Item-no: "" & b For Each cbc In a.Controls d = d + 1 Cells(b + d, 3) = cbc.Caption Cells(b + d, 4) = Cells(cbc.Type, 10) Cells(b + d, 5) = ""Type: "" & cbc.Type Cells(b + d, 6) = ""ID: "" & cbc.ID Next b = b + 1 Next End Sub" Siralama alttakİ ayni numarayi seÇtİĞİmde seÇİlİ numaranin bİlgİlerİnİn textboxa alinmasini İstİyorum "bl = combobox1.ListIndex+1 cells(bl,2).select TextBox1.Value = ActiveCell.Offset(0, 0).Value TextBox2.Value = ActiveCell.Offset(0, 1).Value TextBox3.Value = ActiveCell.Offset(0, 2).Value TextBox4.Value = ActiveCell.Offset(0, 3).Value TextBox5.Value = ActiveCell.Offset(0, 4).Value TextBox6.Value = ActiveCell.Offset(0, 5).Value TextBox7.Value = ActiveCell.Offset(0, 6).Value TextBox8.Value = ActiveCell.Offset(0, 7).Value TextBox9.Value = ActiveCell.Offset(0, 8).Value TextBox10.Value = ActiveCell.Offset(0, 9).Value TextBox11.Value = ActiveCell.Offset(0, 10).Value TextBox12.Value = ActiveCell.Offset(0, 11).Value TextBox13.Value = ActiveCell.Offset(0, 12).Value TextBox14.Value = ActiveCell.Offset(0, 13).Value " Sistem raporu "Sub SysInfo() Dim s As String, oSystem As Object, item As Object Set oSystem = GetObject(""winmgmts:"").instancesOf(""Win32_ComputerSystem"") For Each item In oSystem s = ""Computer Info"" & vbCrLf s = s & ""-----------"" & vbCrLf s = s & ""Name: "" & item.Name & vbCrLf s = s & ""Status: "" & item.Status & vbCrLf s = s & ""Type: "" & item.SystemType & vbCrLf s = s & ""Mfg: "" & item.Manufacturer & vbCrLf s = s & ""Model: "" & item.Model & vbCrLf s = s & ""RAM: "" & item.TotalPhysicalMemory \ 1024000 & ""mb"" & vbCrLf s = s & ""Domain: "" & item.Domain & vbCrLf s = s & ""Role: "" & TranslateDomainRole(item.DomainRole) & vbCrLf s = s & ""Current User: "" & item.UserName & vbCrLf MsgBox s Next Set oSystem = Nothing End Sub Function TranslateDomainRole(ByVal roleID) As String Dim RetString As String Select Case roleID Case 0 RetString = ""Standalone Workstation"" Case 1 RetString = ""Member Workstation"" Case 2 RetString = ""Standalone Server"" Case 3 RetString = ""Member Server"" Case 4 RetString = ""Backup Domain Controller"" Case 5 RetString = ""Primary Domain Controller"" Case Else RetString = ""Unknown"" End Select TranslateDomainRole = RetString End Function " Sistem tarihini açma "Private Sub cmdSetClock_Click() Shell ""rundll32.exe shell32.dll,Control_RunDLL timedate.cpl"", vbNormalFocus End Sub" Sistem yazıcılarını görme "Sub yazlist() Shell (""rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL PrintersFolder"") End Sub" Sİyahla yazili .. Lari Çiktida gÖrÜnmemesİ İÇİn beyaz renklİ olmasini İstİyorum "Sub mt() Columns(""b:b"").Select Selection.Font.ColorIndex = 2 End Sub " Solda, sağdan karakter sayma + kaç karakter var onu da sayar "Sub myEdit() MsgBox Left(""abcd"", 2) 'soldan 2 karakter say MsgBox Right(""abcd"", 2) 'sağdan 2 karakter say MsgBox Len(""abcd"") 'sayısal olarak karakter say End Sub" Son dolu satır ve sütun "Sub sondolu_satir() i = ActiveSheet.UsedRange.Rows.Count MsgBox i End Sub Sub sondolu_sutun() i = ActiveSheet.UsedRange.Columns.Count MsgBox i End Sub" Son yazilan sayfanin sİlİnmesİ İÇİnde ÇikiŞ butonuna aŞaĞidakİ kodu yazin. "Private Sub CommandButton3_Click() Application.DisplayAlerts = False Sheets(Sheets.Count).Delete Unload Me End Sub" SÖzlÜk kodlari "SÖZLÜK OLUŞTURMA KODLARI Sub auto_open() Dim cbMenu As CommandBarControl MenuSil Set cbMenu = Application.CommandBars(1).Controls.Add(msoControlPopup, , , , True) With cbMenu .Caption = ""&Sözlük"" .OnAction = ""formac"" .Tag = ""MyTag"" .BeginGroup = True End With If cbMenu Is Nothing Then Exit Sub Set cbSubMenu = Nothing Set cbMenu = Nothing End Sub Sub MenuSil() kaldir ""MyTag"" End Sub Private Sub kaldir(CustomControlTag As String) On Error Resume Next Do Application.CommandBars.FindControl(, , CustomControlTag, False).Delete Loop Until Application.CommandBars.FindControl(, , CustomControlTag, False) Is Nothing On Error GoTo 0 End Sub Sub auto_close() MenuSil End Sub Sub formac() UserForm1.Show End Sub SÖZLÜK OLUŞTURMA KODLARI Private Sub UserForm_Initialize() With ListBox1 .RowSource = ""[Sözlük.xla]TrEng!A1:A16174"" .Font.Name = ""Verdana"" .Font.Size = 10 End With With ComboBox1 .RowSource = ""[Sözlük.xla]TrEng!A1:A16174"" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Font.Name = ""Verdana"" .Font.Size = 10 End With With ComboBox2 .RowSource = ""[Sözlük.xla]TrEng!B1:B16174"" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Locked = True .Font.Name = ""Verdana"" .Font.Size = 10 End With With ListBox2 .RowSource = ""[Sözlük.xla]EngTr!A1:A11435"" .Font.Name = ""Verdana"" .Font.Size = 10 End With With ComboBox3 .RowSource = ""[Sözlük.xla]EngTr!A1:A11435"" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Font.Name = ""Verdana"" .Font.Size = 10 End With With ComboBox4 .RowSource = ""[Sözlük.xla]EngTr!B1:B11435"" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Locked = True .Font.Name = ""Verdana"" .Font.Size = 10 End With End Sub 'BU KOD COMBOBOX1'E YAZILACAK Private Sub ComboBox1_Change() ListBox1.ListIndex = ComboBox1.ListIndex ComboBox2.ListIndex = ComboBox1.ListIndex End Sub 'BURASI BOŞ KALACAK Private Sub ComboBox2_Change() End Sub 'BU KOD BUTTON'A YAZILACAK Private Sub CommandButton1_Click() Unload UserForm1 End Sub 'BU KOD LİSTBOX1'E YAZILACAK Private Sub ListBox1_Click() ComboBox1.ListIndex = ListBox1.ListIndex ComboBox2.ListIndex = ListBox1.ListIndex End Sub 'BU KOD FORM İÇİNE YAZILACAK Private Sub UserForm_Initialize() With ListBox1 .RowSource = ""sayfa1!A1:A12174"" .Font.Name = ""Verdana"" .Font.Size = 10 End With With ComboBox1 .RowSource = ""sayfa1!A1:A12174"" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Font.Name = ""Verdana"" .Font.Size = 10 End With With ComboBox2 .RowSource = ""sayfa1!B1:B12174"" .ShowDropButtonWhen = fmShowDropButtonWhenNever .Locked = True .Font.Name = ""Verdana"" .Font.Size = 12 End With End Sub " Spİnbutton İle lİstbox'ta İlk ve son satira gİtmek. "visual basic kodu: Private Sub SpinButton1_SpinDown() ListBox1.ListIndex = ListBox1.ListCount - 1 End Sub visual basic kodu: Private Sub SpinButton1_SpinUp() ListBox1.ListIndex = 0 End Sub " Status barda mesajla bekleterek makro yaptırma "Sub RowsToColumns() Dim rCol As Range Dim rCell1 As Range, rCell2 As Range Dim i As Integer, iPBcount As Integer Dim Sht As Worksheet Application.StatusBar = ""Converting, please wait .!"" Application.ScreenUpdating = False 'Set range variable to Selection Set Sht = ActiveSheet Set rCol = Sht.UsedRange.Columns(1) 'Insert page breaks Sht.PageSetup.PrintArea = """" Sht.PageSetup.Zoom = 100 ActiveWindow.View = xlPageBreakPreview 'Count only horizontal page breaks and pass to an Integer iPBcount = Sht.HPageBreaks.Count On Error Resume Next 'Loop as many times as there horizontal page breaks. For i = 1 To iPBcount 'Set variable 1 to page break X Set rCell1 = Sht.HPageBreaks(i).Location 'Set variable 2 to X page break Set rCell2 = Sht.HPageBreaks(i + 1).Location.Offset(-1, 0) If rCell2 Is Nothing Then 'Last page break Range(rCell1, rCol.Cells(65536, 1).End(xlUp)).Cut Destination:=Sht.Cells(1, i + 1) Else Range(rCell1, rCell2).Cut Destination:=Sht.Cells(1, i + 1) End If Set rCell1 = Nothing Set rCell2 = Nothing Next i On Error GoTo 0 ActiveWindow.View = xlNormalView Application.ScreenUpdating = True Sht.DisplayPageBreaks = False Application.Goto rCol.Cells(1, 1), True Set rCol = Nothing Application.StatusBar = """" End Sub" Statusbar da (durum çubuğunda) kayan yazı "Declare Sub Sleep Lib ""kernel32"" _ (ByVal dwMilliseconds As Long) Private Declare Function WaitForSingleObject Lib ""kernel32"" _ (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Function CloseHandle Lib ""kernel32"" _ (ByVal hObject As Long) As Long Private Declare Function OpenProcess Lib ""kernel32"" _ (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) As Long Private Const INFINITE = -1& Private Const SYNCHRONIZE = &H100000 Dim LaufbandExit As Integer Sub LaufbandStart() Dim OrStatus As String Dim LaufText As String Dim B As Range Dim BZelle As Range LaufbandExit = 0 OrStatus = Application.DisplayStatusBar Application.DisplayStatusBar = True Set B = Sheets(""Lauftext"").Range(""A1:D10"") LaufText = String(130, "" "") For Each BZelle In Sheets(""Lauftext"").Range(""A1:D10"") LaufText = LaufText & "" "" & BZelle.Text Next BZelle Application.StatusBar = LaufText Do Sleep 100 'Verzögerung in Millisekunden LaufText = Right(LaufText, Len(LaufText) - 1) & Left(LaufText, 1) Application.StatusBar = LaufText DoEvents If LaufbandExit = 1 Then Application.StatusBar = False Application.DisplayStatusBar = OrStatus LaufbandExit = 0 Exit Sub End If Loop End Sub Sub LaufbandEnde() LaufbandExit = 1 End Sub" Statusbar da 10 dan geriye doğru say ve mesaj ver "Option Explicit Sub Countdown() Dim intCounter As Integer Dim bln As Boolean bln = Application.DisplayStatusBar For intCounter = 10 To 1 Step -1 Application.StatusBar = ""Noch "" & _ intCounter & "" Sekunden "" Application.Wait Now + TimeSerial(0, 0, 1) Next intCounter Application.StatusBar = False Application.DisplayStatusBar = bln MsgBox ""Fertig "", vbOKOnly, ""© K.-M. Buss"" End Sub" Statusbar da mükemmel ınitialize "Sub Fortschritt() Dim i%, y% For i = 1 To 10 StatusLED ""İşlem Yapılıyor: "", i / 10 Application.Wait Now + TimeSerial(0, 0, 1) Next i End Sub Function StatusLED(Msg As String, Pct As Single) Dim PctDone As Integer Dim NumReps As Integer With Application PctDone = .Round(Pct, 2) * 100 NumReps = Int(PctDone / 5) .StatusBar = Msg & .Rept(Chr(14), NumReps) & _ .Rept(""**"", 20 - NumReps) & "" "" & PctDone & ""%"" End With End Function" Statusbar(durum çubuğu) da saniyeli mesaj "Sub StatusBarExample() Application.ScreenUpdating = False Application.DisplayStatusBar = True Application.StatusBar = ""Please wait while performing task 1 "" ' add some code for task 1 that replaces the next sentence Application.Wait Now + TimeValue(""00:00:02"") Application.StatusBar = ""Please wait while performing task 2 "" ' add some code for task 2 that replaces the next sentence Application.Wait Now + TimeValue(""00:00:02"") Application.StatusBar = False End Sub" Statusbar1 saat gÖsterme "Private Sub UserForm_Activate() Do DoEvents StatusBar1.Panels(1).Text = Time Loop End Sub ' Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) End End Sub" Stil penceresi "Sub Dialog_05() Application.Dialogs(xlDialogApplyStyle).Show End Sub Sub Dialog_21() Application.Dialogs(xlDialogDefineStyle).Show End Sub" Sub dosyabul() "sub dosyabul() dim a as string a = application.findfile msgbox a end sub " Sutun seçimini makrodaki ("c:c") değeriyle oynayarak değiştirebilirsiniz "Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range Set rng = Columns(""C:C"") If Not (Intersect(Target, rng) Is Nothing) Then rng.ColumnWidth = 30 Else rng.ColumnWidth = 10.71 End If End Sub" Sutun seÇİmİnİ makrodakİ ("c:c") deĞerİyle oynayarak deĞİŞtİrebİlİrsİnİz "Sutun seçimini makrodaki (""C:C"") değeriyle oynayarak değiştirebilirsiniz örnek:(""E:E"") veya (""A:A"") Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng As Range Set rng = Columns(""C:C"") If Not (Intersect(Target, rng) Is Nothing) Then rng.ColumnWidth = 30 Else rng.ColumnWidth = 10.71 End If End Sub " Sutunu ve aranacak değer makronun içine yazılır "Sub bul() Dim cell As Range i = 0 For Each cell In Sheets(""Sayfa1"").Range(""B1:B"" & Range(""B65536"").End(xlUp).Row) i = i + 1 If cell = ""kubilay"" Then cell.Offset(0, 1) = ""bulundu"" End If Debug.Print i Next cell End Sub " SÜre sona erdİrme "Application.Visible = False Dim d, x, y d = GetSetting(""DANISMAN"", ""Ayarlar"", ""Ilk Giris"", """") If d = """" Then SaveSetting ""DANISMAN"", ""Ayarlar"", ""Ilk Giris"", Date Else If (Date - CDate(d)) > 365 Then MsgBox (""Programin Demo Süresi dolmustur."") DoCmd.Close Application.Quit Else x = GetSetting(""DANISMAN"", ""Ayarlar"", ""Son Çikis Tarihi"", """") If x = """" Then 'End Else If CVDate(x) > Date Then MsgBox (""Programin Deneme Süresi Doldu Lütfen Israr Etmeyin"") DoCmd.Close Else y = GetSetting(""DANISMAN"", ""Ayarlar"", ""Son Çikis Saati"", """") If (CVDate(x) = Date) And (CVDate(y) > Time) Then MsgBox (""Programin Deneme Süresi Doldu Lütfen Israr Etmeyin"") DoCmd.Close End If End If x = GetSetting(""DANISMAN"", ""Ayarlar"", ""Sayi"", ""1"") MsgBox (""Programi"" & x & "". defa çalistiriyorsunuz."") SaveSetting ""DANISMAN"", ""Ayarlar"", ""Sayi"", x + 1 End If End If End If siparisfrm.Show Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) SaveSetting ""DANISMAN"", ""Ayarlar"", ""Son Çikis Tarihi"", Date SaveSetting ""DANISMAN"", ""Ayarlar"", ""Son Çikis Saati"", Time Application.Visible = True Application.Quit End Sub " Sürekli flash veren makro örneği "Dim NextTime As Date Sub Flash() NextTime = Now + TimeValue(""00:00:01"") With ActiveWorkbook.Styles(""Flash"").Font If .ColorIndex = 2 Then .ColorIndex = 3 Else .ColorIndex = 2 End With Application.OnTime NextTime, ""Flash"" End Sub Sub StopIt() Application.OnTime NextTime, ""Flash"", schedule:=False ActiveWorkbook.Styles(""Flash"").Font.ColorIndex = xlAutomatic End Sub" Süreli userform "Private Sub UserForm_Activate() Dim Pausenlänge, Start, Ende, Gesamtdauer Pausenlänge = 10 ' Dauer festlegen. Start = Timer ' Anfangszeit setzen. UserForm1.Caption = ""http://www.excel-lex.de.vu © 2003 K.-M. Buss"" Do While Timer < Start + Pausenlänge DoEvents ' Steuerung an andere Prozesse ' abgeben. Loop Ende = Timer ' Ende festlegen. Gesamtdauer = Ende - Start ' Gesamtdauer berechnen. UserForm1.Hide End Sub" Süreli userform 1 "Private Sub UserForm_Activate() ' Récupération de l'heure d'affichage de la BdD TimeDebut = Timer ' Donne la main à excel pour facilité l'affichage de la BdD DoEvents ' Boucle tant que 2 secondes ne se sont pas écoulé While Timer < TimeDebut + 10 Wend ' Fermeture de la BdD Unload Me End Sub" Süreli userform 2 "Private Sub UserForm_Activate() Application.Wait Now + TimeSerial(0, 0, 3) Unload Me End Sub" Sürücü seri numarası göster "Sub Sürücü_Seri_Numarası_Göster() On Error GoTo hata: Dim ds, d, s, t Set ds = CreateObject(""Scripting.FileSystemObject"") Set d = ds.GetDrive(""C:\"") Select Case d.DriveType Case 0: t = ""Bilinmiyor"" Case 1: t = ""Çıkarılabilir"" Case 2: t = ""HardDisk"" Case 3: t = ""Ağ"" Case 4: t = ""CD-ROM"" Case 5: t = ""RAM Disk"" End Select s = ""Sürücü "" & d.DriveLetter & "": "" & t If d.IsReady Then s = s & vbCrLf & d.SerialNumber MsgBox s Else s = s & vbCrLf & ""Sürücü Hazır Değil."" MsgBox s End If End hata: MsgBox ""Böyle Bir Sürücü Yok"" End Sub" Sürücü1) sürücünün olup olmadığını arama "Sub Sürücü_ara() Set ds = CreateObject(""Scripting.FileSystemObject"") a = ds.DriveExists(""Ğ:\"") If a = True Then MsgBox ""Bu isimde bir sürücü var"" Else MsgBox ""Bu isimde bir sürücü yok"" End If End Sub" Sürücü2) sürücü kaç tane acaba "Sub Sürücü_Sayısı() Dim ds, dc, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set dc = ds.Drives s = dc.Count MsgBox s End Sub" Sürücü3) sürücü isimlerini öğrenmek için "Sub Sürücü_İsimleri() Dim ds, dc, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set dc = ds.Drives For Each sürücü In dc s = s & vbCrLf & sürücü Next MsgBox s End Sub" Sürücü4) sürücü harfi göster "Sub Sürücü_Harfi_Göster() Dim ds, d, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set d = ds.GetDrive(""C:\"") s = d.DriveLetter MsgBox s End Sub" Sürücü6) boş alan göster "Sub Boş_Alan_Göster() Dim ds, d, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set d = ds.GetDrive(ds.GetDriveName(""C:\"")) s = UCase(d) & "" Sürücüsünde Boş Alan:"" & Chr(13) _ + vbCrLf & FormatNumber(d.AvailableSpace) s = s & "" Bytes"" MsgBox s End Sub" Sürücü7) sürücü hazır mı göster "Sub Sürücü_Hazır_Mı_Göster() On Error GoTo hata: Dim ds, d, s, t Set ds = CreateObject(""Scripting.FileSystemObject"") Set d = ds.GetDrive(""F:\"") Select Case d.DriveType Case 0: t = ""Bilinmiyor"" Case 1: t = ""Çıkarılabilir"" Case 2: t = ""HardDisk"" Case 3: t = ""Ağ"" Case 4: t = ""CD-ROM"" Case 5: t = ""RAM Disk"" End Select s = ""Sürücü "" & d.DriveLetter & "": "" & t If d.IsReady Then s = s & vbCrLf & ""Sürücü Hazır."" Else s = s & vbCrLf & ""Sürücü Hazır Değil."" End If MsgBox s End hata: MsgBox ""Böyle Bir Sürücü Yok"" End Sub" Sürücünün dosya formatını öğrenme "Sub Give_Filesystem() Dim myFSO As Object, myDrv As Object, strFS As String Set myFSO = CreateObject(""Scripting.FileSystemObject"") Set myDrv = myFSO.GetDrive(""c:"") strFS = myDrv.FileSystem MsgBox strFS End Sub" Sürürcü5) sürücü tipi göster "Sub Sürücü_Tipi_Göster() On Error GoTo hata: Dim ds, d, s, t Set ds = CreateObject(""Scripting.FileSystemObject"") Set d = ds.GetDrive(""F:\"") Select Case d.DriveType Case 0: t = ""Bilinmiyor"" Case 1: t = ""Çıkarılabilir"" Case 2: t = ""HardDisk"" Case 3: t = ""Ağ"" Case 4: t = ""CD-ROM"" Case 5: t = ""RAM Disk"" End Select s = ""Sürücü "" & d.DriveLetter & "": "" & t MsgBox s End hata: MsgBox ""Böyle Bir Sürücü Yok"" End Sub " Sütun aktarma ayınısı gibi c,i "Sub AKTAR1() Range(""l1:l100"").ClearContents For x = 1 To 100 If Cells(x, 3) <> """" Then Cells(x, 12) = Cells(x, 3) Next End Sub" Sütun aktarma sırasıyla, boşluk silerek c,i "Sub AKTAR2() c = 0 Range(""l1:l100"").ClearContents For x = 1 To 100 If Cells(x, 3) <> """" Then c = c + 1 Cells(c, 12) = Cells(x, 3) End If Next End Sub" Sütun başlıkları rc stili ve normal stil "Sub Spaltenziffern() With Application .ReferenceStyle = xlR1C1 End With End Sub Sub Spaltenbuchstaben() With Application .ReferenceStyle = xlA1 End With End Sub" Sütun genişliği 5 ayarla "Sub LargeurColonne() For Each col In Selection.Columns If col.Column Mod 2 = 0 Then col.ColumnWidth = 5 End If Next col End Sub" Sütun genişliği ayarlama penceresi "Sub Dialog_13() Application.Dialogs(xlDialogColumnWidth).Show End Sub" Sütun gizleme şartlı "A1:AL1 hücreleri arasında ""Mahmut"" yazan sütunları gizleme For Each ALAN In Range(""A1:AL1"") If ALAN.Value <> ""Mahmut"" Then ALAN.EntireColumn.Hidden = True End If Next End Sub " Sütunda arama "Seç hücre=columns(“D”).Find (what:=”ist.”) - --> D sütununda “ist.” Sözcüğü aranıyor.Bulunan ilk hücrenin adresi hücre değişkenine atanıyor.What , find metodun bir argümanıdır." Sütunda boş olan satırları hepsini sil "Sub sil() Range(""c1"").Select Application.ScreenUpdating = False Dim hucre As Range For Each hucre In Range(""c1:c"" & WorksheetFunction.CountA(Range(""c1:c5000""))) Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop ActiveCell.EntireRow.Select Selection.Delete Shift:=xlUp Next Application.ScreenUpdating = True End Sub " Sütunda boş olan satırları teker teker sil "Sub sil() Range(""c1"").Select Application.ScreenUpdating = False Dim hucre As Range For Each hucre In Range(""c1:c"" & WorksheetFunction.CountA(Range(""c1:c5000""))) Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop ActiveCell.EntireRow.Select Selection.Delete Shift:=xlUp Next Application.ScreenUpdating = True End Sub" Sütunda dolu olanları seçer c "Sub Düğme1_Tıklat() ActiveSheet.UsedRange.Select Range(""c1:c"" & Cells(65536, 3).End(xlUp).Row).Select End Sub" Sütunda satırları seç boş olanları silsin "Sub DeleteRow() Application.ScreenUpdating = False Dim N As Long For N = Selection(1, 1).Row + Selection.Rows.Count - 1 _ To Selection(1, 1).Row Step -1 With Cells(N, 1) If .Value = 0 And Not .HasFormula Then .EntireRow.Delete End If End With Next N End sub" Sütundaki (a:a) dolu satırların altına boş satır ekler "Sub ZeileEinfuegen() Dim Zeile As Integer Zeile = 2 Application.ScreenUpdating = False Do Until Range(""a"" & Zeile).Value = """" Rows(Zeile & "":"" & Zeile).Select Selection.Insert Shift:=xlDown Zeile = Zeile + 2 Loop Range(""A1"").Select Application.ScreenUpdating = True End Sub" Sütundaki dolu olanları 65536 dan çıkarır "Sub CountCellvide() numBlanks = 0 For Each c In Selection If c.Value = """" Then numBlanks = numBlanks + 1 End If Next c MsgBox ""Il y a "" & numBlanks & "" cellules vides dans cette plage."" End Sub" Sütundaki en son dolu satırın bir altındaki boş satıra gider "Sub leere_zelle() [A1].Select ActiveCell.End(xlDown).Select ActiveCell.Offset(1, 0).Range(""A1"").Select End Sub Sub zahl_suchen() leere_Zeile = Range(""A"" & Rows.Count).End(xlUp).Row + 1 For i = 1 To leere_Zeile Range(""A"" & i).Select If ActiveCell = 5 Then Exit Sub Next i End Sub" Sütundaki harfler ve rakamlardan rakamları ayırır "Private Sub metinayikla() Dim nums As String For i = 1 To Cells(65536, 1).End(xlUp).Row For b = 1 To Len(Cells(i, 1)) If IsNumeric(Mid(Cells(i, 1), b, 1)) = True Then nums = nums & Mid(Cells(i, 1), b, 1) End If Next b Cells(i, 1) = nums nums = """" Next i End Sub" Sütundaki ilk boş hücreye gider "Sub BosHucreyeGit() ActiveCell.End(xlDown).Offset(1, 0).Select ' sütundaki ilk boş hücreye gider End Sub" Sütundaki satır sayısını öğrenme "Sub NombreDeLigne() With Selection MsgBox Selection.Rows.Count End With End Sub" SÜtunlarin gİzlenmesİ "Aşağıdaki kodu uygulayınız. (Sayfa yazdırma ayarlarınızı yaptığınızı varsaydım.) Kod: Sub GİZLE_YAZDIR() Range(""C:C,F:F,H:H"").Select 'Buradaki sütunları artırabilirsiniz. Selection.EntireColumn.Hidden = True Range(""A1"").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End Sub Gizlenen sütunlarıda tekrar görünür hale getirmek için aşağıdaki kodu uygulayın. Kod: Sub SÜTUNLARI_GÖSTER() Range(""C:C,F:F,H:H"").Select Selection.EntireColumn.Hidden = False Range(""A1"").Select End Sub" Sütunu hücredeki veriye göre daraltma "Sub ajuste_colonne() Selection.Columns.AutoFit End Sub" Sütunu seç dolu olan veri sayısı söylesin "Sub CompteLesNonVides() NonVide = 0 For Each Cellule In Selection.Cells If Not IsEmpty(Cellule) Then NonVide = NonVide + 1 Next MsgBox ""Il y a "" & NonVide & "" cellules non vides dans la sélection"" End Sub" Sütunu seç kırmızı renkli rakamları a1 e toplasın "Sub Somme_Rouge() Dim Cel As Range Dim SomRoug As Integer For Each Cel In Selection If Cel.Font.ColorIndex = 3 Then SomRoug = SomRoug + Cel End If Next Range(""A1"") = SomRoug End Sub" Sütunu seç verili hücreden itibaren seçsin "Sub Select_from_ActiveCell_to_Last_Cell_in_Column() Dim topCel As Range Dim bottomCel As Range On Error GoTo errorHandler Set topCel = ActiveCell Set bottomCel = Cells((65536), topCel.Column).End(xlUp) If bottomCel.Row >= topCel.Row Then Range(topCel, bottomCel).Select End If Exit Sub errorHandler: MsgBox ""Error no. "" & Err & "" - "" & Error End Sub" Sütunun sonuna kadar yandaki iki sütunun farkini al "Sub Auto_Open() [M1] = WorksheetFunction.Sum(Range(""L1:L65536"")) - WorksheetFunction.Sum(Range(""J1:J65536"")) End Sub" Sütunundaki dolu hücreleri bulur ve yazdırma alanı içine alır "Sub setPrintArea() Dim rng As Range Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell) stcell = ""A1"": lcell = rng.Address ActiveSheet.PageSetup.PrintArea = stcell & "":"" & lcell End Sub" Süzlü aktarma "1. Veri adında bir sayfayı index'i 1 olacak şekilde ayarlayın. Yani en sol başa yerleştirin. 2. Veri sayfasına A1'den başlayarak isimleri sırasıyla yazınız. 3. Veri sayfasını takip eden ilk Sayfa'da bahsettiğiniz değerler olsun. Yani bu sayfanında index'i 2 olmalı. Soldan ikinci sayfa yani. 4. Yeteri kadar sayfa açın. Yani isimleriniz kadar sayfa ekleyin. Bunu otomatik de yapabilirdik ama bu satırları yazarken aklıma geldi. Aşağıdaki kodu ekleyin. Sub Aktarma_Yap() Dim i As Integer Set veri = Worksheets(""Veri"") For i = 1 To 2 Range(""A1"").AutoFilter Range(""A1"").AutoFilter Field:=1, Criteria1:=veri.Cells(i, 1) Range(""A1"").CurrentRegion.Copy Sheets(i + 2).Range(""A1"") Next i End Sub Değerlerinizin olduğu sayfadan bu kodu çalıştırın" Süzme sütunda kırmızıları (butonla) "Private Sub CommandButton1_Click() k = 1 For i = 1 To Range(""B65536"").End(xlUp).Row If Range(""A"" & i).Font.Color = vbRed Then Cells(k, 3) = Cells(i, 2) k = k + 1 End If Next i End Sub" Süzülenlerin comboboxta sıralanması Selection.AutoFilter Field:=5, Criteria1:=ComboBox1.Value ŞArta baĞli makro "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If [B18].Value = 20 Then Call Makro1 End If End Sub " ŞArta gÖre mesajbox gÖrÜntÜleme "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> ""$B$1"" Then Exit Sub If [b1] < [a1] Then MsgBox ""girdiğiniz değer yanlış"" End Sub" ŞArtlara gÖre aktİf yada pasİf olan komut dÜĞmesİ "Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then CommandButton1.Enabled = False Else CommandButton1.Enabled = True End If End Sub ilk başta komut düğmesinin enable özelliğini false yapmayı unutmayın." ŞArtlı wav çaldırma "Sub Auto_Open() Worksheets(""Sayfa1"").OnCalculate = ""PlayIt"" End Sub Sub PlayIt() If Range(""A1"").Value > 5 Then ExecuteExcel4Macro (""SOUND.PLAY(,""""C:\Windows\Media\Tada.wav"""")"") End If End Sub" Şekillerin alanlarını hesaplama "Private Sub Command1_Click() Dim a, b, c As Double If Option1.Value = True Then a = Val(Text1.Text) b = 3.14 * a ^ 2 Text3.Text = b End If If Option2.Value = True Then a = Val(Text1.Text) b = a ^ 2 Text3.Text = b End If If Option3.Value = True Then a = Val(Text1.Text) b = Val(Text2.Text) c = a * b Text3.Text = c End If If Option4.Value = True Then a = Val(Text1.Text) b = Val(Text2.Text) c = (a * b) / 2 Text3.Text = c End If End Sub Private Sub option1_click() Text1.Text = """" Text2.Text = """" Text3.Text = """" Label2.Visible = False Text2.Visible = False Label1.Caption = ""yarıçap(r)"" Label3.Caption = ""Alan"" End Sub Private Sub option2_click() Text1.Text = """" Text2.Text = """" Text3.Text = """" Label2.Visible = False Text2.Visible = False Label1.Caption = ""Kenar(a)"" Label3.Caption = ""Alan"" End Sub Private Sub option3_click() Text1.Text = """" Text2.Text = """" Text3.Text = """" Label2.Visible = True Text2.Visible = True Label1.Caption = ""Kenar(a)"" Label2.Caption = ""Kenar(b)"" Label3.Caption = ""Alan"" End Sub Private Sub option4_click() Text1.Text = """" Text2.Text = """" Text3.Text = """" Label2.Visible = True Text2.Visible = True Label1.Caption = ""Taban(a)"" Label2.Caption = ""Yükseklik(h)"" Label3.Caption = ""Alan"" End Sub" ŞIfreleme de son nokta "Bu komut Visual Basic ve VBA da dahili bir komut olduğu için herhangi bir ön hazırlığa gerek duymaz. Görevi : Windows kayıt defteri(registry)ne kayıt yapar. Kullanımı : SaveSetting Program(uygulama) adı, Bölüm, Anahtar, Değer Private Sub CommandButton1_Click() 'Bu prosedürde registry'e en son girilen kaydedilir. SaveSetting ""partner"", ""Settings"", ""UserForm1"", TextBox1.Text End Sub Yukarıdaki prosedirde registere gerekli kayıt yapılıyor. Aşağıdaki prosedürde ise registry'e kaydedilen bilgi TextBoxa geri çağrılıyor. Kayıtları okumak için GetSetting komutu kullanılır. SaveSetting'in tersidir. Kullanımı: Değişken = GetSetting (Program adı, Bölüm, Anahtar, [Kayıt Yoksa Değer]) Kayıt Yoksa Değer parametresi zorunlu değildir. Registerde belirtilen kayıt yoksa varsayılan olarak atanacak değeri buraya yazabilirsiniz. Private Sub UserForm_Initialize() 'UserFormdaki TextBox1 e yazdığınız en son bilgi UserForm aktif olduğunda tekrar çağırılır TextBox1.Text = GetSetting(""partner"", ""Settings"", ""UserForm1"") End Sub Peki bu kayıt register'in neresinde diye soranlara? Başlat / Çalıştır 'a regedit yazıp enter'e basın. Aşağıdaki görülen resimdeki adrese ulaşın. Kaydı orada göreceksiniz." ŞIfreli giriş 0-254 arası bir sayı "ThisWorkbook'a Private Sub Workbook_Open() Test1 End Sub Sub Test1() Dim NumberofColumns As Integer Dim BMax As Integer Dim InputErrorCheck As Boolean InputErrorCheck = False Do While InputErrorCheck = False NumberofColumns = Application.InputBox(prompt:=""Şifre kodunuzu giriniz "", Type:=1) If IsNumeric(NumberofColumns) Then If NumberofColumns <= 254 And NumberofColumns > 0 Then ' Şifre kodunun 0-254 arası bir sayı olduğu varsayılmıştır. InputErrorCheck = True End If End If If NumberofColumns = False Then MsgBox (""İşlem iptal edildi"") Exit Sub End If Loop MsgBox (NumberofColumns) ' Burada input alındıktan sonra esas yapılmamk istenen işlem prosedürleri çağrılacak End Sub" ŞIfreli giriş userformda textboxlu "2 adet TextBox 1.si şifre 2.Şifre Tekrar yazma '1 adet Command Buton giriş Private Sub CommandButton1_Click() If TextBox1.Value = ""kubilay"" Or TextBox1.Value = ""B"" Then GoTo Kontrol2 Else Unload UserForm1 MsgBox ""TEKRAR DENE İSTERSEN OLMADI!"", vbCritical, ""HATA"" ActiveWorkbook.Close 0 Exit Sub End If Kontrol2: If TextBox2.Value = ""kubilay"" Or TextBox2.Value = ""2"" Then MsgBox ""Programa girişiniz onaylanmıştır."", vbInformation Unload Me Application.Visible = True Else Unload UserForm1 MsgBox ""Üzgünüm girdiğiniz parola hatalı."", vbCritical, ""HATA"" ActiveWorkbook.Close 0 Exit Sub End If End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode <> 1 Then Cancel = True End Sub" ŞIfreli yazıyı deşifre etme "Public gszData As String Public Sub DemoEncryptData() gszData = CStr(Application.InputBox(""Enter a string to be encrypted."", ""Encyrption Demo"")) If (gszData <> CStr(False)) And (Len(gszData) > 0) Then EncryptDecrypt gszData MsgBox ""The encrypted string is:"" & vbLf & vbLf & gszData, vbInformation, ""Encryption Demo"" Else gszData = vbNullString End If End Sub Public Sub DemoDecryptData() If Len(gszData) > 0 Then EncryptDecrypt gszData MsgBox ""The decrypted string is:"" & vbLf & vbLf & gszData, vbInformation, ""Encryption Demo"" Else MsgBox ""There is no stored data to decrypt."", vbExclamation, ""Encryption Demo"" End If End Sub Private Sub EncryptDecrypt(ByRef szData As String) Const lKEY_VALUE As Long = 215 Dim bytData() As Byte Dim lCount As Long bytData = szData For lCount = LBound(bytData) To UBound(bytData) bytData(lCount) = bytData(lCount) Xor lKEY_VALUE Next lCount szData = bytData End Sub" ŞIfreyi girince kodlar tekrar aktif olsun "If Date >= CDate(""23.02.2005"") Then sifre = InputBox(""Devam edebilmek için şifre girmelisiniz!"", ""Progranım Kullanım Süresi Dolmuştur"") If sifre <> ""1234"" Then Exit Sub End If MsgBox ""Çalışan kodlar""" ŞIfreyi girmeye zorlama girince diğer sayfaya yönlendirir "Sub Registrierung() ActiveWindow.DisplayWorkbookTabs = False Worksheets(""Codeabfrage"").Select On Error GoTo Abbruch Application.EnableCancelKey = xlErrorHandler Application.DisplayAlerts = False Heute = Now Verfalldatum = #5/14/2003# 'Hier Verfalldatum im Format MM/TT/JJJJ eintragen If Verfalldatum < Heute Then Dim passwort As String passwort = InputBox(""Die Testphase ist abgelaufen,"" & Chr(13) & Chr(13) & "" bitte geben Sie Ihre Registrierungs-Nr.:"", ""Testphase abgelaufen, Reg.Nr. erforderlich"") If passwort <> ""36"" Then Registrierung End If MsgBox (""Registrierung erfolgreich"") ActiveWindow.DisplayWorkbookTabs = True Worksheets(""Datenbereich"").Select Application.DisplayAlerts = True End If Exit Sub Aufraeumen: Application.EnableCancelKey = xlInterrupt ThisWorkbook.Close Exit Sub Abbruch: ThisWorkbook.Close End Sub" Şifre açma "Sub sifreac() Dim a As Integer For a = 1 To 10000 Application.DisplayAlerts = False Workbooks.Open Filename:=""C:\Documents and Settings\usak0018\Belgelerim\YTL.xls"", Password:=a Next a End Sub" Şifrelemede son nokta "Bu komut Visual Basic ve VBA da dahili bir komut olduğu için herhangi bir ön hazırlığa gerek duymaz. Görevi : Windows kayıt defteri(registry)ne kayıt yapar. Kullanımı : SaveSetting Program(uygulama) adı, Bölüm, Anahtar, Değer Private Sub CommandButton1_Click() 'Bu prosedürde registry'e en son girilen kaydedilir. SaveSetting ""partner"", ""Settings"", ""UserForm1"", TextBox1.Text End Sub Yukarıdaki prosedirde registere gerekli kayıt yapılıyor. Aşağıdaki prosedürde ise registry'e kaydedilen bilgi TextBoxa geri çağrılıyor. Kayıtları okumak için GetSetting komutu kullanılır. SaveSetting'in tersidir. Kullanımı: Değişken = GetSetting (Program adı, Bölüm, Anahtar, [Kayıt Yoksa Değer]) Kayıt Yoksa Değer parametresi zorunlu değildir. Registerde belirtilen kayıt yoksa varsayılan olarak atanacak değeri buraya yazabilirsiniz. Private Sub UserForm_Initialize() 'UserFormdaki TextBox1 e yazdığınız en son bilgi UserForm aktif olduğunda tekrar çağırılır TextBox1.Text = GetSetting(""partner"", ""Settings"", ""UserForm1"") End Sub Peki bu kayıt register'in neresinde diye soranlara? Başlat / Çalıştır 'a regedit yazıp enter'e basın. Aşağıdaki görülen resimdeki adrese ulaşın. Kaydı orada göreceksiniz." ŞİFrelİ kapali bİr dosyadan verİ almak "Aşağıdaki kodu güncelleştirme yapılan dosyanın thisworkbook sayfasına kopyalayın. Dosyayı her açtığınızda link olan tüm dosyaları otomatik olarak güncelleştirecektir. Private Sub workbook_open() Link = ActiveWorkbook.LinkSources(xlExcelLinks) If IsEmpty(Link) = False Then For a = 1 To UBound(Link) Workbooks.Open Link(a), Password:=""9876"", WriteResPassword:=""9876"" ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources ActiveWorkbook.Close False Next End If End Sub" T.C. Merkez Bankası Güncel Döviz Kurlarını alma "‘Microsoft İnternet Transfer Control, version 6.0 ı ekleyiniz. ‘C:\Windows\System32 de MSINET.OCX i ‘Bu kodlar genellikle *.html ve *.htm uzantılı sayfalarda işlem görmektedir. partner = Inet1.OpenURL(""http://www.tcmb.gov.tr/kurlar/today.html"") TextBox1.Text = Mid(partner, InStr(partner, ""USD"") + 42, 6) & "" YTL"" ' USD adlı kelimeyi bulur ve 42. karakterden itibaren 6 karakter sağındakine kadar TextBox1 e aktarır. ‘Aşağıdakileri de bu şekilde yorumlayabilirsiniz. TextBox2.Text = Mid(partner, InStr(partner, ""USD"") + 55, 6) & "" YTL"" TextBox3.Text = Mid(partner, InStr(partner, ""EUR"") + 42, 6) & "" YTL"" TextBox4.Text = Mid(partner, InStr(partner, ""EUR"") + 55, 6) & "" YTL""" Tab ile textbox içeriğini seçme "Private Sub TextBox2_Enter() Me.TextBox2.EnterFieldBehavior = fmEnterFieldBehaviorRecallSelection End Sub" Tab ile textbox içeriğini seçme 2 "Private Sub TextBox2_Enter() Me.TextBox2.EnterFieldBehavior = fmEnterFieldBehaviorSelectAll End Sub" Tablo boşaltır "YENİ VERİ GİRMEK İÇİN TABLOYU BOŞALTIR Private Sub CommandButton5_Click() Unload Günlük Günlük.Show End Sub 'TABLOYU TEMİZLE Private Sub CommandButton10_Click() ComboBox1.Value = """" TextBox2.Value = """" TextBox3.Value = """" ComboBox1.SetFocus End Sub " Tablo boŞaltir "YENİ VERİ GİRMEK İÇİN TABLOYU BOŞALTIR Private Sub CommandButton5_Click() Unload Günlük Günlük.Show End Sub 'TABLOYU TEMİZLE Private Sub CommandButton10_Click() ComboBox1.Value = """" TextBox2.Value = """" TextBox3.Value = """" ComboBox1.SetFocus End Sub " Tablonuz açıldığı anda internettesiniz: "Private Sub Workbook_Open() Tabelle1.WebBrowser1.Navigate ""http://www.mynet.com"" End Sub " Tablonuz aÇildiĞi anda "Private Sub Workbook_Open() Tabelle1.WebBrowser1.Navigate ""http://www.excel.web.tr"" End Sub " Tablonuzu tam ekran yapar " Makro bölümüne yapıştırın ve tuşa atayın Tam ekran için Kod: Sub tam() Application.DisplayFullScreen = True End Sub Normal görünüm için Kod: Sub normal() Application.DisplayFullScreen = False End Sub " Takvimi sayfaya yazar(yılı değiştiriniz) "Sub takvim() Dim varYear As Variant Dim bytMonth As Byte Dim bytDay As Byte Dim bytWeekday As Byte Dim strWeekday As String Dim ws As Worksheet varYear = 2005 For Each ws In Worksheets If ws.Name = ""Jahr "" & varYear Then ws.Delete End If Next ws Set ws = Worksheets.Add ws.Name = ""Jahr "" & varYear For bytMonth = 1 To 12 With Cells(1, bytMonth) .Value = Format(DateSerial(varYear, bytMonth, 1), ""mmmm"") .Interior.ColorIndex = 36 .Font.Bold = True End With For bytDay = 1 To Day(DateSerial(varYear, bytMonth + 1, 0)) With Cells(bytDay + 1, bytMonth) bytWeekday = Weekday(DateSerial(varYear, bytMonth, bytDay)) strWeekday = WhichWeekday(bytWeekday) .Value = strWeekday & "", "" & bytDay If bytWeekday = 7 Or bytWeekday = 1 Then .Interior.ColorIndex = 22 End If End With Next bytDay Next bytMonth End Sub Function WhichWeekday(ByVal bytWeekday As Byte) As String Select Case bytWeekday Case 1 WhichWeekday = ""pazar"" Case 2 WhichWeekday = ""p.tesi"" Case 3 WhichWeekday = ""salı"" Case 4 WhichWeekday = ""carsamba"" Case 5 WhichWeekday = ""persembe"" Case 6 WhichWeekday = ""cuma"" Case 7 WhichWeekday = ""c.tesi"" End Select End Function " Tam dizin ismini veren bir kod "Sub Tam_Dizin_İsmi() Dim ds, a Set ds = CreateObject(""Scripting.FileSystemObject"") a = ds.GetAbsolutePathName("""") MsgBox a End Sub" Tam ekran için "Sub tam() Application.DisplayFullScreen = True End Sub " Tam ekran normal ekran "EKRANI BÜYÜLTÜR Sub Auto_Open() Sheets(""kitap1"").Select Application.DisplayFullScreen = True Application.DisplayFormulaBar = False Application.DisplayFormulaBar = False With ActiveWindow .DisplayHorizontalScrollBar = False .DisplayVerticalScrollBar = False .DisplayWorkbookTabs = False End With Range(""A1"").Select End Sub EKARNI KÜÇÜLTÜR Sub Auto_Close() Sheets(""kitap1"").Select Application.DisplayFullScreen = False Application.DisplayFormulaBar = True With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True .DisplayWorkbookTabs = True End With End Sub " Tam ekran normal ekran "EKRANI BÜYÜLTÜR Sub Auto_Open() Sheets(""kitap1"").Select Application.DisplayFullScreen = True Application.DisplayFormulaBar = False Application.DisplayFormulaBar = False With ActiveWindow .DisplayHorizontalScrollBar = False .DisplayVerticalScrollBar = False .DisplayWorkbookTabs = False End With Range(""A1"").Select End Sub EKARNI KÜÇÜLTÜR Sub Auto_Close() Sheets(""kitap1"").Select Application.DisplayFullScreen = False Application.DisplayFormulaBar = True With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True .DisplayWorkbookTabs = True End With End Sub " Tam ekran userform "Private Sub UserForm_Activate() Me.Top = Application.Top Me.Left = Application.Left Me.Height = Application.Height Me.Width = Application.Width End Sub" Tam ekran yap, ve çubuğu gizle "Application.DisplayFullScreen = True Application.CommandBars(""Full Screen"").Enabled = False" Tanımlı adları silme "Sub name_delete() Dim definedName As Object For Each definedName In ActiveWorkbook.Names definedName.Delete Next End Sub" Tarİh formati yanliŞ İse uyarsin. "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If TextBox1.Value <> """" And IsDate(TextBox1.Value) = False Then MsgBox (""hatalı veri girişi"" & vbCrLf & TextBox1) TextBox1.Value = """" Else TextBox1 = Format(TextBox1, ""dd.mm.yyyy"") End If End Sub " Tarih işlemleri 1 "Function ayekle(EklenecekSure As Integer, ilkTarih As Date) ayekle = DateAdd(""m"", EklenecekSure, ilkTarih) End Function Function yilekle(EklenecekSure As Integer, ilkTarih As Date) yilekle = DateAdd(""yyyy"", EklenecekSure, ilkTarih) End Function Function gunekle(EklenecekSure As Integer, ilkTarih As Date) gunekle = DateAdd(""d"", EklenecekSure, ilkTarih) End Function Function ayfarki(ilkTarih As Date, sonTarih As Date) ayfarki = DateDiff(""m"", ilkTarih, sonTarih) End Function Function yilfarki(ilkTarih As Date, sonTarih As Date) yilfarki = DateDiff(""yyyy"", ilkTarih, sonTarih) End Function Function gunfarki(ilkTarih As Date, sonTarih As Date) gunfarki = DateDiff(""d"", ilkTarih, sonTarih) End Function Function ayinsonu(tarih As Date) Dim ay As Integer Dim yil As Integer ay = Month(tarih) yil = Year(tarih) ayinsonu = IIf(ay = 2, IIf((yil Mod 4) > 0, 28, 29), IIf(ay = 4, 30, IIf(ay = 6, 30, IIf(ay = 9, 30, IIf(ay = 11, 30, 31))))) End Function Function yildakigun(tarih As Date) Dim yil As Integer yil = Year(tarih) yildakigun = IIf((yil Mod 4) > 0, 365, 366) End Function" Tarih işlemleri 2 "Function TarihEkle(Tarih As Date, Optional Gun As Integer, Optional Hafta As Integer, Optional Ay As Integer, Optional Yil As Integer) TarihEkle = DateAdd(""d"", Gun, Tarih) TarihEkle = DateAdd(""ww"", Hafta, TarihEkle) TarihEkle = DateAdd(""m"", Ay, TarihEkle) TarihEkle = DateAdd(""yyyy"", Yil, TarihEkle) End Function" Tarih ve sıra numarasına göre kayıt "Private Sub Kaydet_Click() Sheets(""Sayfa1"").Select On Error Resume Next Dim i, r, y As Integer Dim s As String Dim q As Date s = txtyer For i = 5 To WorksheetFunction.CountA(Range(""a2:a40"")) + 1 If Cells(i, 1).Value = s Then q = txttarih For r = 5 To WorksheetFunction.CountA(Range(""a3:AJ40"")) + 1 If Cells(3, r).Value = q Then d = txtsonuç Cells(i, r).Value = d MsgBox ""KAYIT TAMAMLANDI"", , ""KAYIT"" Exit Sub End If Next r End If Next i MsgBox ""ARANAN YER BULUNAMADI !"" End Sub" Tarih yıln kaçıncı haftası " Dim tarih As Date, hafta As Integer tarih = Date hafta = DatePart(""ww"", tarih, vbMonday, vbFirstJan1) MsgBox ""Bugün: "" & Date & "" --> Yılın "" & hafta & "". Haftası"" " Tarihe göre kitap açma makrosu (belirlenen tarih geçmişse kitabı açmaz) "Sub Auto_Open() Dim exdate As Date exdate = ""11/30/2004"" If Date > exdate Then MsgBox (""You have reached end of your trail period"") ActiveWorkbook.Close End If MsgBox (""You have "" & exdate - Date & ""Days left"") End Sub" Tarİhİ macroya metİn olarak okuma. "sub deneme() [d2].select selection.numberformat = ""yyyy/mm/dd hh:mm:ss"" end sub" Tarihi seriye çevirme "Sub ConvertToDateSerial() 'Convert from recognizable US date to date serial 'For dates on/after March 1, 1900 back to dateserial Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range On Error Resume Next '-- in case no cells selected For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlCellTypeConstants)) cell.Value = Int(DateValue(cell.Value)) cell.NumberFormat = ""general"" Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub" Tarihi tam gir o tarihten sonraki ve o yıl içerisindeki haftaları sayfa olarak eklesin "Sub YearWorkbook() Dim iWeek As Integer Dim sht As Variant Dim sTemp As String Dim dSDate As Date sTemp = InputBox(""Date for the first worksheet:"", ""End of Week?"") dSDate = CDate(sTemp) Application.ScreenUpdating = False Worksheets.Add After:=Worksheets(Worksheets.Count), _ Count:=(52 - Worksheets.Count) For Each sht In Worksheets sht.Name = Format(dSDate, ""dd-mmm-yyyy"") dSDate = dSDate + 7 Next sht Application.ScreenUpdating = True End Sub" Tarihli hücrede eğer (ıf) makro "Sub tarih() If [a1] = Date Then [b1] = 1 End If If [a1] = Date + 1 Then [b1] = 2 End If If [a1] = Date + 2 Then [b1] = 3 End If End Sub " Tarihli kopya "Public Sub Dateikopie() Dim InI As Integer Workbooks.Add With ThisWorkbook ' Datei mit Code ActiveWorkbook.SaveAs .Path & ""\Kopie_von"" & ThisWorkbook.Name ' neue Datei Workbooks.Add For InI = .Worksheets.Count To 1 Step -1 ' Anzahl Register in ThisWorkbook Sheets.Add .Worksheets(InI).Cells.Copy With ActiveWorkbook.ActiveSheet.Cells .PasteSpecial Paste:=xlPasteValues ' Werte .PasteSpecial Paste:=xlFormats ' Formate End With ActiveWorkbook.ActiveSheet.Name = .Worksheets(InI).Name Next InI Application.CutCopyMode = False 'Zwischenspeicher löschen Application.DisplayAlerts = False Worksheets(ActiveWorkbook.Worksheets.Count).Delete Application.DisplayAlerts = True MsgBox ""Reine Datentabelle gespeichert als: "" & .Path & ""\Kopie_von"" & ThisWorkbook.Name ActiveWorkbook.Close True End With End Sub" Tarihli ve saatli yedek alma "Sub DateiUnter TagesdatumAbspeichern() Tagesdatum = Application.Text(Now(), ""mm-dd-yy hh-mm"") Sicherung = ""Backup"" & Tagesdatum & "".XLS"" ActiveWorkbook.SaveCopyAs Sicherung End Sub" Tarihli yedek almak 1 "Sub tarihli_yedek_al() Dim dname As String, strTest As String dname = ""C:\DATA\kubilay.xls"" & Format(Now(), ""yyyy_mmdd"") strTest = Dir(dname, vbDirectory) If (strTest = """") Then MkDir (dname) ActiveWorkbook.SaveCopyAs dname & ""\BK_"" & Range(""A1"") & Range(""a2"") ActiveWorkbook.Save End Sub " Tarihli yedek almak 2 "Sub tarihli_yedek_al() Dim dname As String, strTest As String dname = ""C:\DATA\"" & Range(""A1"") & "" "" & Range(""a2"") & Format(Now(), ""yyyy_mmdd"") strTest = Dir(dname, vbDirectory) If (strTest = """") Then MkDir (dname) ActiveWorkbook.SaveCopyAs dname & ""\BK_"" & Range(""A1"") & Range(""a2"") ActiveWorkbook.Save End Sub " Tarihten gün çıkarma "Private sub Commandbutton1_click() TextBox9 = Format(DateAdd(""d"", -TextBox4, ComboBox6), ""dd.mm.yyyy"") end sub" Tek bİr userform İle İŞlem yapmak "Sub kayıt() UserForm1.OptionButton1.Visible = False UserForm1.OptionButton2.Visible = False UserForm1.Show End Sub" Tek buton İle belİrlİ hÜcrelerİ temİzleme "Sub temizle() For t = 1 To Sheets.Count Sheets(t).Select For Each hucre In [a1:e20] If hucre.Interior.Color = vbYellow Then hucre.ClearContents Next Next End Sub" Tek hücrede yer alan "ad soyad" bilgisini ayrı hücrelere alma "B1 hücresine aşağıdaki formülü girin: =SOLDAN(YERİNEKOY(A1;"" "";""*"";UZUNLUK(A1)-UZUNLUK(YERİNEKOY(A1;"" "";"""")));BUL(""*"";YERİNEKOY(A1;"" "";""*"";UZUNLUK(A1)-UZUNLUK(YERİNEKOY(A1;"" "";"""")));1)-1) Bu formül ile A1 hücresindeki ismin ""Adı"" kısmını B1 hücresine almış bulunmaktayız. Formülün bu kadar uzun olmasına neden olan ise bazı adların 2 isimden oluşabilmesidir. A1 hücresine ""Mehmet Ali Ceylan"" yazdığınızda B1 hücresinde ""Mehmet Ali"" yazıldığını görebilirsiniz. Soyadlarını ayırmak için de C1 hücresine aşağıdaki formülü girin: =PARÇAAL(A1;UZUNLUK(B1)+2;UZUNLUK(A1)-UZUNLUK(B1)) B1 ve C1 hücresindeki formülleri listeniz uzunluğunca kopyaladığında listenizdeki bütün kayıtlar ""Adı"" ve ""Soyadı"" halinde 2 farklı sütuna kopyalanmış olacaktır. " Tek tıklamayla çıktı almak "Sub yaz() For a=1 To 22 [j7]=a ActiveSheet.PrintOut Next End Sub" Tek tıklamayla sayfa2'ye git "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = ""$C$18"" Then Sheets(""Sayfa2"").Select End Sub " Temizleme penceresi "Sub Dialog_11() Application.Dialogs(xlDialogClear).Show End Sub" Tersten yazdırma "Sub ReverseText() Dim strText As String, strReverseText As String Dim intPos As Integer, intLen As Integer strText = Selection.Text intLen = Len(strText) For intPos = 1 To Len(strText) strReverseText = strReverseText & Mid(strText, intLen - intPos + 1, 1) Next intPos ActiveCell.FormulaR1C1 = strReverseText End Sub" Texboox1 e bu gÜnÜn tarİhİnİ atmasini İstİyorum "Private Sub UserForm_Initialize() TextBox1 = Format(Date, ""mm.dd.yyyy"") End Sub saat içinde; Private Sub UserForm_Initialize() TextBox1 = Format(Time, ""hh:mm"") End Sub " Texbox la veri arama "A stununda isimler var Formuma eklediğim textbox kutusunun adı ""isim"" ve o ismi listeden bulmak istiyorum.. - Dim bak As Range For Each bak In Range(""A1:A"" & WorksheetFunction.CountA(Worksheets(""sayfa1"").Range(""A1:A10000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(isim.Value, vbUpperCase) Then bak.Select msgbox(""Aradığınız "" & ActiveCell.Offset(0, 0).Value & ""isim bulundu. Hücre adresi"" & ActiveCell.Offset(0, 0).address) ----------------- mesaj kutusunda aradığınız ismi ve adresini görüntüler. " Texboxta yazı rengi TextBox1.ForeColor = vbRed Text box bİÇİmlendİrme "Private Sub TextBox1_Change() If Len(TextBox1.Text) >= 15 Then TextBox1 = Left(TextBox1, 15) If Len(TextBox1.Text) < 10 Then TextBox1 = Replace(TextBox1, "" "", """") Else TextBox1.Text = Format(TextBox1, ""(###) ### ## ##"") End If End Sub" Text dosyası1) oluşturma "Dosya isminden sonra False yazarsak eski bilgilerin üstüne yazılmaz ve “File Already Exists” yani “Dosya Zaten Var” uyarısı gelir. True yazarsak,eski bilgiler silinir,yenileri yazılır. Bu örnekte bilgi yazma kısmına yer vermedik. Bilgi yazma kısmı makalemizin ikinci kısmında,Alt FSO bölümünde bulunmaktadır. İkinci kısım False olursa dosya ASCII,True olursa UNICODE olur. Sub Text_Dosyası_Oluştur() Dim ds, a Set ds = CreateObject(""Scripting.FileSystemObject"") Set a = ds.CreateTextFile(""C:\SXS\Deneme.txt"", True, False) 'İlk true Overwrite,İkinci False ASCII true olursa Unicode End Sub" Text dosyası2) silme "Dosya silmeye yarar.Dosya isminden sonra gelen yere ,dosya Salt okunursa True yazmalısınız.Yoksa ""Access Denied"" yani ""Giriş Reddedildi"" der. Sub Dosya_Sil() Dim ds Set ds = CreateObject(""Scripting.FileSystemObject"") ds.DeleteFile ""C:\SXS\Deneme.txt"", True End Sub" Text dosyası3) açma ve hazırlama "Sub Text_Dosyası_Aç() Const ForReading = 1, ForWriting = 2, ForAppending = 3 'For Reading Sadece Okur,For Appending ise hem Okur hem Yazar Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") Set f = ds.OpenTextFile(""c:\testfile.txt"", ForAppending, TristateFalse) 'TristateUseDefault'da System Default,TristateTrue 'da Unicode,TristateFalse'da ASCII kullanılır. End Sub" Text dosyası4) oluştur ve yaz "Sub Text_Dosyası_Oluştur_Yaz() Dim ds, a Set ds = CreateObject(""Scripting.FileSystemObject"") Set a = ds.CreateTextFile(""C:\Deneme.txt"", True, False) 'İlk true Overwrite,İkinci False ASCII true olursa Unicode a.WriteLine (""İlk Satır"") a.Close End Sub" Text dosyasından veri alma (alt alta, tüm veriler) "Sub Import() Open ""d:\data.txt"" For Input As #1 R = 1 While Not EOF(1) 'Scan file line by line C = 1 Entry = """" Line Input #1, Buffer Length = Len(Buffer) i = 1 While i <= Length 'split comma-delimited string into cells If (Mid(Buffer, i, 1)) = "","" Then With Application.Cells(R, C) .NumberFormat = ""@"" 'Text formatting .Value = Entry End With C = C + 1 Entry = """" Else Entry = Entry + Mid(Buffer, i, 1) End If i = i + 1 Wend If Len(Entry) > 0 Then With Application.Cells(R, C) .NumberFormat = ""@"" 'Text formatting .Value = Entry End With End If R = R + 1 Wend Close #1 End Sub" Text dosyasından veri alma a sütununa yazma "Sub OuvreTXT() Workbooks.OpenText Filename:=""C:\ajeter\TEST.TXT"", _ Origin:=xlWindows, StartRow:=1, _ DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=True, Comma:=False, Space:=False, _ Other:=False, FieldInfo:=Array(Array(1, 1), _ Array(2, 1), Array(3, 1)) End Sub" Text dosyasını açar yeni kitaba açar "Sub Dateiimport() Quelle = Application.GetOpenFilename(""TXT-Dateien , *.TXT"") Workbooks.OpenText Filename:=Quelle, Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon _ :=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(1, 1) End Sub" Textboka verİ kopyalama "TEK BOK 1'İ KESER (BAŞKA YERE YAPIŞTIRMAK İÇİN) Private Sub CommandButton2_Click() TextBox1.Cut End Sub 'TEK BOKA VERİ YAPIŞTIRIR Private Sub CommandButton7_Click() TextBox11.Paste End Sub " Textbok'tan hÜcrelere verİ gİrme "BU KODU TextBox1 E YAZARSANIZ TEXTBOXA GİRDİĞİNİZ VERİLERİ A1 HÜCRESİNE YAZAR Private Sub TextBox1_Change() [a1] = TextBox1.Text End Sub " TextBox 10 dan küçük ise uyarı verir "Textbox çıkışına veya commandbutona bağlayabilirsiniz Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If Val(TextBox1.Text) <= 10 Then MsgBox ""Sayı 10'den büyük olmalı"", vbInformation TextBox1.SetFocus Exit Sub End If End Sub" Textbox büyük harf türkçe karakter sorunu "Private Sub TextBox1_Change() On Error Resume Next [aa1] = ""=büyükharf("""""" & TextBox1 & """""")"" [aa1] = ""=upper("""""" & TextBox1 & """""")"" TextBox1 = [aa1] End Sub Veya; Private Sub TextBox1_Change() On Error Resume Next TextBox1 = Evaluate(""=büyükharf("""""" & TextBox1 & """""")"") TextBox1 = Evaluate(""=upper("""""" & TextBox1 & """""")"") End Sub " Textbox da alt+enter ve rakam formatİ / boŞ hucreyİ bul "Private Sub CommandButton1_Click() For a = 1 To 40 b = Sheets(""sayfa1"").Cells(a, 1).Value If b = """" Then Sheets(""sayfa1"").Cells(a, 1) = TextBox1.Value Sheets(""sayfa1"").Cells(a, 2) = ComboBox1.Text GoTo 10 End If Next a Sheets(""sayfa1"").Cells(1, 3) = ""TÜM SATIRLAR DOLU"" 'UYARI MESAJI 10 End Sub " Textbox format "Aşağıdaki şekilde yazın sorununuz çözülecektir. TextBox17=Format(TextBox17,""#,##0.00"") " Textbox her seÇİldİĞİnde İÇerİĞİ sİlİnsİn "Private Sub TextBox1_GotFocus() TextBox1.Text = """" End Sub" Textbox her seçildiğinde içeriğinin silinmesi "Private Sub TextBox1_GotFocus() TextBox1.Text = """" End Sub" Textbox hÜcre toplaminin yazdirilmasi "UserForm Üzerinde; TextBox1,TextBox2 ve TextBox3 olduğunu varsayalım. TextBox1 A1 Hücresine ilişik TextBox2 A2 Hücresine ilişik TextBox3 A3 Hücresine ilişik TextBox3'de Toplam Sonucu Görmek isterseniz. Textbox1 ve 2'deki değerleri TextBox3'de görmek için. Kod: Private Sub TextBox1_Change() TextBox3.Value = Val(TextBox1.Value) + Val(TextBox2.Value) End Sub Private Sub TextBox2_Change() TextBox3.Value = Val(TextBox1.Value) + Val(TextBox2.Value) End Sub Hücredeki değeri Sn Leventm 'nin yazdığı şekilde zaten alıyorsunuz. Ayrıca Girdiğiniz değerlerin TextBoxlarla birlikte Hücrelerde Anında görünmesini isterseniz. Kod: Private Sub TextBox1_Change() Range(""A1"").Select [a1] = TextBox1.Value TextBox3.Value = Val(TextBox1.Value) + Val(TextBox2.Value) End Sub Private Sub TextBox2_Change() Range(""A2"").Select [a2] = TextBox2.Value TextBox3.Value = Val(TextBox1.Value) + Val(TextBox2.Value) End Sub Private Sub TextBox3_Change() Range(""A3"").Select [a3] = TextBox3.Value End Sub " Textbox içeriğini kopyalamak "If TextBox1 <> Empty Then TextBox1.SelStart = 0 TextBox1.SelLength = TextBox1.TextLength TextBox1.Copy MyData.GetFromClipboard MsgBox ""TextBox1 icerigi hafizaya kopyalandı ."" End If" Textbox İÇİnde gÜnÜn tarİhİ "Private Sub TextBox3_Change() TextBox3 = Format(TextBox3, ""mm""""/""""dd""""/""""yyyy"") End Sub" Textbox içine gelindiğinde renklendirme "Private Sub TextBox2_Enter() TextBox1.BackColor = &HFFFF00 End Sub Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1.BackColor = vbWhite End Sub Private Sub TextBox4_Enter() TextBox3.BackColor = &HFFFF00 End Sub Private Sub TextBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox3.BackColor = vbWhite End Sub Private Sub TextBox6_Enter() TextBox5.BackColor = &HFFFF00 End Sub Private Sub TextBox6_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox5.BackColor = vbWhite End Sub Private Sub TextBox8_Enter() TextBox7.BackColor = &HFFFF00 End Sub Private Sub TextBox8_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox7.BackColor = vbWhite End Sub " Textbox karakter kısıtlaması "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If Len(TextBox1) < 11 Then MsgBox ""EKSİK KARAKTER GİRİŞİ !"" & vbCrLf & ""EN AZ 11 KARAKTER GİREBİLİRSİNİZ."", vbCritical Cancel = True ElseIf Len(TextBox1) > 11 Then MsgBox ""FAZLA KARAKTER GİRİŞİ !"" & vbCrLf & ""EN FAZLA 11 KARAKTER GİREBİLİRSİNİZ."", vbCritical Cancel = True Else Cancel = False End If End Sub" Textbox kutusu görünmez ise görünür yap "Private Sub CommandButton1_Click() 'Eğer text kutusu görünmez ise görünür yap If TextBox1.Visible = False Then TextBox1.Visible = True: GoTo 10 'Eğer text kutusu görünürse görünmez yap. If TextBox1.Visible = True Then TextBox1.Visible = False: GoTo 10 10: End Sub" Textbox lara gİrİlen rakamlarin para bazinda gÖsterİlmesİ "Private Sub CommandButton1_Click() Range(""a1"").Select ActiveCell.Formula = TextBox1 End Sub" Textbox nesnesi tab tuşuyla veya mausla seçildiğinde yani aktif olduğunda renk değiştirme "Private Sub TextBox1_Enter() TextBox1.BackColor = vbYellow End Sub Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1.BackColor = vbWhite End Sub " Textbox ta 2 karakterden fazla yazı yazılırsa diğer textbox a geçer "Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) Select Case Len(TextBox1.Value) Case Is >= 2 TextBox2.SetFocus Case Else TextBox2.Value = """" End Select End Sub" Textbox ta 2 karakterden fazla yazı yazılırsa diğer textbox ta mesaj verir "Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If Len(TextBox1.Value) >= 2 Then TextBox2.Value = ""Artık ben aktifim"" Else TextBox2.Value = """" End If End Sub" Textbox ta 2 karakterden fazla yazı yazılırsa diğer textbox ta mesaj verir "Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) Select Case Len(TextBox1.Value) Case Is >= 2 TextBox2.Value = ""Artık ben aktifim"" Case Else TextBox2.Value = """" End Select End Sub" Textbox ta binlik ayıracı "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""##,##.00"") End Sub" Textbox ta virgul kullanmasin nokta ile giris yapsin ve noktadan once ve sonra 2 rakam girilsin. "Private Sub TextBox1_Change() uz = Len(TextBox1) par = Right(TextBox1, 1) If uz < 3 And IsNumeric(par) = False Or uz > 5 Then SendKeys ""{bs}"" If uz = 3 And par <> ""."" Then SendKeys ""{bs}"" If uz > 3 And IsNumeric(par) = False Then SendKeys ""{bs}"" End Sub" Textbox taki boşlukları aldırma "Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If KeyAscii = 32 Then KeyAscii = 0 End If End Sub" Textbox tarih formatı "Private Sub TextBox1_Change() With TextBox1 .SelLength = 1 If .SelText = ""."" Then .SelStart = .SelStart + 1 .SelLength = 1 End If End With End Sub Private Sub UserForm_Initialize() With TextBox1 .MaxLength = 10 .EnterFieldBehavior = fmEnterFieldBehaviorRecallSelection .Text = ""##.##.####"" .SelStart = 0 .SelLength = 1 End With End Sub" Textbox tarih örneği "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If Right(TextBox1.Value, 4) >= 2000 Then TextBox1.Value = Format(TextBox1.Value, ""dd""""/""""mm""""/""""yyyy"") Else MsgBox ""hatalı"" End If End Sub" Textbox un rengi değişsin "Private Sub TextBox1_Enter() TextBox1.BackColor = &HFF& End Sub" Textbox ve comboboxtakileri sayfaya sıralı kaydetme "Private Sub CommandButton1_Click() Application.ScreenUpdating = False satir = WorksheetFunction.CountA(Sheets(""TABLO"").Range(""A1:A65536"")) + 1 'VERİ sayfasında, a kolonundaki son dolu hücreden sonraki satir Sheets(""TABLO"").Cells(satir, 1) = ComboBox1.Value Sheets(""TABLO"").Cells(satir, 2) = TextBox1.Value Sheets(""TABLO"").Cells(satir, 3) = TextBox2.Value Sheets(""TABLO"").Cells(satir, 4) = TextBox3.Value Sheets(""TABLO"").Cells(satir, 5) = TextBox4.Value ComboBox1.Value = """" TextBox1.Value = """" TextBox2.Value = """" TextBox3.Value = """" TextBox4.Value = """" End Sub" Textbox yazılan kelimelerin ilk harfini büyük yazmak "Public Function AutoType(c As Control, KeyAscii As Integer) As Integer AutoType = KeyAscii If KeyAscii > 95 And KeyAscii < 123 Then If c.SelStart = 0 Then AutoType = AutoType - 32 ElseIf Mid$(c.Text, c.SelStart, 1) < ""!"" Then AutoType = AutoType - 32 End If End If End Function Private Sub Text1_KeyPress(KeyAscii As Integer) KeyAscii = AutoType(Screen.ActiveControl, KeyAscii) End Sub" Textbox`a metİn gİrİŞİnde paraĞraf yapabİlİrmİyİz enter "Private Sub UserForm_Initialize() With TextBox1 .EnterKeyBehavior = True .TabKeyBehavior = True .MultiLine = True End With End Sub " Textbox`dakİ yazinin hÜcreye aktarilmasi "Private Sub TextBox1_Change() If Len(TextBox1.Text) > 14 Then MsgBox (""Karakter sayısı uzun"") TextBox1.Enabled = False Else TextBox1.Enabled = True End If Label1.Caption = ""Karakter sayı"" & "" "" & Len(TextBox1.Text) & "" "" End Sub Private Sub UserForm_Click() End Sub " Textbox1 de arama textbox2 de bulma "Private Sub TextBox1_Change() On Error Resume Next Satırno = Sheets(""Sayfa1"").[B2:B65536].Find(TextBox1.Value).Row TextBox2 = Sheets(""Sayfa1"").Cells(Satırno, 3).Value End Sub" Textbox1 e gİrİlen bİr İsİmle yenİ ÇaliŞma sayfasi aÇma "Private Sub CommandButton2_Click() If Not TextBox1 = Empty Then For i = 1 To Worksheets.Count If Sheets(i).Name = TextBox1 Then MyQ = MsgBox(""Bu isimde bir şirket var, değişik bir isim girmelisiniz !"") TextBox1 = Empty TextBox1.SetFocus Exit Sub End If Next Set NewSh = Worksheets.Add With NewSh .Name = TextBox1 .Range(""A1"") = Label2 .Range(""A2"") = Label3 .Range(""A3"") = Label4 .Range(""A4"") = Label5 .Range(""B1"") = TextBox2 .Range(""B2"") = TextBox3 .Range(""B3"") = TextBox4 .Range(""B4"") = TextBox5 .Range(""B5"") = TextBox6 .Columns(""A:A"").ColumnWidth = 12 .Columns(""B:B"").ColumnWidth = 34 .Columns(""C:C"").ColumnWidth = 19 .Columns(""D:D"").ColumnWidth = 19 End With End If With Range(""A9:D9"") With .Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin End With With .Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin End With With .Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin End With With .Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin End With With .Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin End With End With With Range(""A1:D8"") .Borders(xlDiagonalDown).LineStyle = xlNone .Borders(xlDiagonalUp).LineStyle = xlNone With .Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin End With With .Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin End With With .Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin End With With .Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin End With .Borders(xlInsideVertical).LineStyle = xlNone .Borders(xlInsideHorizontal).LineStyle = xlNone End With Set NewSh = Nothing End Sub " Textbox1'e tarih, textbox2'ye ay girdiğinizde sayfada bunun kesişimi olan değeri label'a yazar "Ocak, Şubat, Mart gibi aylar A2:A13 aralığında, 1975, 1976,. gibi yıllar B1:L1 aralığında, UserForm üzerinde TextBox1, TextBox2, Label1 ve CommandButton1 nesneleri varsa; Private Sub CommandButton1_Click() On Error GoTo ResumeSub: x = Range(""A2:A13"").Cells.Find(TextBox1).Row y = Range(""B1:L1"").Cells.Find(TextBox2).Column Label1.Caption = Cells(x, y) Exit Sub ResumeSub: Label1.Caption = ""Deger bulunamadi ."" End Sub" Textbox2 textbox1 den büyükse mesaj ver 1 "Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) If TextBox1 <> 0 Then If TextBox1.Value < TextBox2 Then MsgBox ""hata"" TextBox2 = """" End if End If End Sub" Textbox2 textbox1 den büyükse mesaj ver 2 "Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) If TextBox1 <> 0 And Val(TextBox1.Text) < Val(TextBox2.Text) Then MsgBox ""hata"":TextBox2 = """" End Sub" Textbox7'de verİler saĞa yanaŞik yazilsin. "Userforma aşağıdaki kodu yazın. visual basic kodu: Private Sub UserForm_Initialize() TextBox7.TextAlign = fmTextAlignRight End Sub " Textboxa alfabetik, backspace ve spacebar a izin verir "Private Sub TextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If (Asc(UCase(Chr(KeyAscii))) < 65 Or Asc(UCase(Chr(KeyAscii))) > 91) And KeyAscii <> 8 And KeyAscii <> 32 Then KeyAscii = 0 End If End Sub" Textboxa çift tıklama ile form açılması "Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) UserForm2.Show End Sub" Textbox'a girerken her üç rakamın arasına bir nokta koyma "Bir UserForm üzerine 3 adet TextBox nesnesi ve 1 adet CommandButton nesnesi yerleştirin. Aşağıdaki kodları UserForm'unuza kopyalayın. Private Sub CommandButton1_Click() Dim t1 As Double Dim t2 As Double t1 = TextBox1.Value t2 = TextBox2.Value TextBox3 = t1 + t2 End Sub Private Sub TextBox1_Change() TextBox1 = Format(TextBox1, ""###,0"") End Sub Private Sub TextBox2_Change() TextBox2 = Format(TextBox2, ""###,0"") End Sub" Textboxa harf girilince ses çıkarsın " Sub TextBox1_change() Dim N$ N = ""0123456789."" If KeyAscii <> 8 Then If InStr(N, Chr(KeyAscii)) = 0 Then Beep KeyAscii = 0 Exit Sub End If End If End Sub" Textboxa numerik girmeye zorlama "Private Sub TextBox1_Change() If Len(TextBox1.Text) = 0 Then Exit Sub If Not IsNumeric(TextBox1.Text) Then Beep MsgBox ""Numerik olmayan bir değer girdiniz"" End If End Sub" Textboxa numerik ve backspace e izin verir "Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If IsNumeric(Chr(KeyAscii)) = False And KeyAscii <> 8 Then KeyAscii = 0 End If End Sub" Textboxa rakam gir sonucu labelde gör "Private Sub txtkalper_Change() labtopkalper = Val(txtsevper) * 0.4 + Val(txtkalper) * 0.6 End Sub" Textboxa rakam girmeye zorlamak "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" Textboxa sadece harf girilmesi "Private Sub TextBox1_Change() If TextBox1 = """" Then Exit Sub deg = Mid(TextBox1.Value, Len(TextBox1.Value), 1) If IsNumeric(deg) = True Then MsgBox ""SADECE HARF GİRİNİZ"" TextBox1 = Mid(TextBox1.Value, 1, Len(TextBox1.Value) - 1) TextBox1.SetFocus End If End Sub" Textboxa sadece nokta veya virgül girmek "Private Sub Text2_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 190 Then MsgBox (""Nokta yerine (.) Virgül (,) kullanın"") End If End Sub" Textboxa sadece numara If Not IsNumeric(TextBox1) Then SendKeys "{BS}" Textboxa sadece rakam girme "Userformun code bölümüne yapıştır,textbox'ları çoğaltabilirsin kopyala yapıştır,makrodaki textbox1'i 2,3,4 gibi değiştir(userformdaki textbox sayısına göre) Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0: MsgBox "" Harf girilmeyecek,Sadece Rakam Giriniz .."" End Sub " Textboxa sadece rakam girme-karakter sınırlı-boş geçemez "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) 'Girilen değer numerik değilse Textboxten çıkışı engelliyor, bu durumda boşta olamıyor. If IsNumeric(TextBox1.Value) Then Cancel = False Else Cancel = True Beep ' 'beep' sesi üretiyor MsgBox (""Sadece sayı girin!"") ' Uyarı penceresi açıyor. End If End Sub Private Sub UserForm_Initialize() TextBox1.MaxLength = 8 End Sub" Textboxa sadece rakam ve virgül "Private Sub TextBox1_Change() If Not IsNumeric(TextBox1) Then SendKeys ""{BS}"" End Sub" Textboxa sadece rakam ve virgül "Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0 End Sub" Textboxa Şarta baĞli verİ gİrİŞİ "Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean) If TextBox3 <> """" Then If Val(TextBox3) > Val(TextBox2) Then Select Case MsgBox(""Textbox 2 den büyük veri girişine izin verilsin mi !"", vbYesNo Or vbInformation Or vbSystemModal Or vbMsgBoxRight Or vbDefaultButton2, ""yüksek rakamlı veri girişi"") Case vbYes TextBox3.Value = Format(TextBox3.Value, ""#,##0.00"") TextBox2.Value = Format(TextBox2.Value, ""#,##0.00"") TextBox4.SetFocus Case vbNo Cancel = True TextBox3.Value = """" End Select End If End If End Sub" Textboxa tarİh yazdirma TextBox1.Text = Format(DTPicker1, "dd.mm.yyyy") Textboxa tıklandığında içeriğin tümünü seçmek "Private Sub Text1_GotFocus() ' textbox aktif olduğunda Screen.ActiveControl.SelStart = 0 ' başlangıcı 0 olarak ata Screen.ActiveControl.SelLength = Len(Screen.ActiveControl.Text) ' uzunluğu textboxınkine eşitle End Sub" Textboxa veri girmeye zorlamak "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If TextBox1.Value < 1 Or TextBox1.Value > 12 Then MsgBox ""Hata oldu n'apcaz şimdi. Elbette Exit olayının Cancel argümanını kullanacaz"" Cancel = True End If TextBox1 = """" End Sub" Textboxa veri kopyalama "TEK BOK 1'İ KESER (BAŞKA YERE YAPIŞTIRMAK İÇİN) Private Sub CommandButton2_Click() TextBox1.Cut End Sub 'TEK BOKA VERİ YAPIŞTIRIR Private Sub CommandButton7_Click() TextBox11.Paste End Sub " Textboxa yazılan verinin hücreye aktarılması "Private Sub TextBox1_Change() [a2] = TextBox1.Text End Sub" Textboxa yazıyı yazar yazmaz hesaplama "Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Label2.Caption = KeyCode TextBox1.Value = """" End Sub" Textbox'a(metin kutusuna) girlilen yazının para birimi Şeklinde olması "TextBox nesnesinden ""cursor - imleç"" çıktığında bu işin yapılmasını istersen; Kod: Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""#,### TL"") End Sub Private Sub TextBox1_Change() RefreshTxtBx End Sub veya şöyle olabilir. Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""#,### TL"") End Sub ' Private Sub TextBox2_Change() RefreshTxtBx End Sub ' Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox2 = Format(TextBox2, ""#,### TL"") End Sub ' Private Sub RefreshTxtBx() Dim Val1 As Double, Val2 As Double On Error Resume Next Val1 = TextBox1 Val2 = TextBox2 On Error GoTo 0 TextBox3 = Format(Val1 + Val2, ""#,### TL"") End Sub " Textboxlar boş geçilmesin "Private Sub CommandButton1_Click() if Textbox1.value="""" then MsgBox(""Textbox1'i Boş Geçemessiniz"") Exit sub End if if Textbox2.value="""" then MsgBox(""Textbox2'i Boş Geçemessiniz"") Exit sub End if if Textbox3.value="""" then MsgBox(""Textbox3'i Boş Geçemessiniz"") Exit sub End if if Textbox4.value="""" then MsgBox(""Textbox4'i Boş Geçemessiniz"") Exit sub End if End Sub" Textboxlara veri girmeyi zorlamak "1. Userform oluşturun 2. İçine iki tane textbox oluşturun 3. Textbox1 nesnesinin Exit olayına Cancel = True yazdığınızda kullanıcı bu nesneyi boş geçemez " Textboxlarda tarih toplama "Private Sub CommandButton1_Click() Dim t1 As Date Dim t2 As Long t1 = TextBox1.Value t2 = TextBox2.Value TextBox3 = Format(t1 + t2, ""dd.mm.yyyy"") End Sub" Textboxlarda toplama "Private Sub CommandButton1_Click() TextBox1 = Val(TextBox2.Value) + Val(TextBox3.Value) End Sub" Textboxlarda yazanları tek textboxta alt alta birleştirmek "TextBox isimlerini kendinize göre değiştiriniz Private Sub ekle_Click() UserForm2.TextBox1.Value = UserForm2.TextBox1.Value & vbcrlf & TextBox2.Value & vbcrlf & TextBox3.Value End Sub" Textboxları hücreye aktarırken arada boşluk bırakmak Range("a1").value= Textbox1.value & " " & Textbox2.value Textboxların boş geçilmemesi "Private Sub CommandButton1_Click() If TextBox1.Value = """" And TextBox2.Value = """" Then MsgBox ""Lütfen Boş Olan Alanları doldurun. Boş olan nesne adı: "" & Chr(13) & TextBox1.Name & "" "" & TextBox2.Name, vbQuestion, ""UYARI"" Exit Sub End If For x = 1 To 2 If Controls(""TextBox"" & x).Value = """" Then MsgBox ""Lütfen Boş Olan Alanları doldurun. Boş olan nesne adı: "" & Chr(13) & Controls(""TextBox"" & x).Name, vbQuestion, ""UYARI"" Exit Sub End If Next x End Sub" Textboxların boş geçilmemesi "Private Sub CommandButton1_Click() If TextBox1 = """" Then BosOge = BosOge & vbLf & TextBox1.Name If TextBox2 = """" Then BosOge = BosOge & vbLf & TextBox2.Name If BosOge <> """" Then MsgBox ""Aşağıdaki alanlar boş:"" & BosOge End If End Sub" Textboxların tümüne format tanımlamak "1. Bir adet Class Module açın. ve aşağıdaki kodları yapıştırın. Public WithEvents txt As MSForms.TextBox Private Sub txt_Change() txt = Format(txt, ""###,###"") End Sub '2.UserForm'un kod sayfasına Dim txtler() As New Class1 Private Sub UserForm_Initialize() Dim kontrol As Control, i As Integer i = 1 For Each kontrol In UserForm1.Controls If Left(kontrol.Name, 7) = ""TextBox"" Then ReDim Preserve txtler(i) Set txtler(i).txt = kontrol i = i + 1 End If Next End Sub " Textboxlarla sayfaya kayıt "Private Sub CommandButton1_Click() z = Range(""A1"").End(xlDown).Row + 1 If z > 65000 Then z = 2 Cells(z, 1) = TextBox1 Cells(z, 2) = TextBox2 Cells(z, 3) = TextBox3 Cells(z, 4) = TextBox4 Cells(z, 5) = TextBox5 End Sub" Textboxlarla toplama "Private Sub CommandButton1_Click() Dim toplam For i = 1 To 47 Step 3 toplam = toplam + Val(Controls(""TextBox"" & i)) Next TextBox50.Value = Format(toplam, ""###,###"") End Sub" Textboxlarla toplama 2 TextBox1= Val(TextBox2.Value) + Val(TextBox3.Value) Textboxta başa 0 sıfır eklemek "Private Sub TextBox1_Change() TextBox1.Text = Format(TextBox1.Text, ""0000"") End Sub" Textboxta binlik ayıracı 1 "Private Sub TextBox1_Change() Me.TextBox1.Value = Format(Me.TextBox1.Value, ""###,###"") End Sub" Textboxta binlik ayıracı 2 "Private Sub TextBox1_Change() TextBox1 = Format(TextBox1, ""###,0"") End Sub" Textboxta binlik ayıraclı toplama "Bir UserForm üzerine 3 adet TextBox nesnesi ve 1 adet CommandButton nesnesi yerleştirin. Aşağıdaki kodları UserForm'unuzua kopyalayın. Private Sub CommandButton1_Click() Dim t1 As Double Dim t2 As Double t1 = TextBox1.Value t2 = TextBox2.Value TextBox3 = t1 + t2 End Sub Private Sub TextBox1_Change() TextBox1 = Format(TextBox1, ""###,0"") End Sub Private Sub TextBox2_Change() TextBox2 = Format(TextBox2, ""###,0"") End Sub" Textboxta email sorgulama "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If st = EmailType Then If RTrim(TextBox1.Text) <> """" Then If InStr(TextBox1.Text, "" "") <> 0 Or InStr(TextBox1.Text, ""@"") = 0 Or InStr(TextBox1.Text, ""."") = 0 Then MsgBox ""Geçersiz email adresi !!!"", vbInformation ', 'App.Title Exit Sub TextBox1.SetFocus 'Cancel = False 'End If End If End If End If End Sub" Textboxt'a formatlanan sayi hÜcrede ayni formatta gÖzÜk "Textbox a bir format tanımlamayın ve command butona aşağıdaki kodu yazarak deneyin. visual basic kodu: Private Sub CommandButton1_Click() a = TextBox7.Value * 1000 [a1] = a / 1000 [a1].NumberFormat = ""General"" End Sub" Textboxta girişte otomatik büyük harf "Private Sub TextBox1_Change() TextBox1 = StrConv(TextBox1, vbUpperCase) End Sub " Textboxta girişte otomatik büyük harf 2 "Private Sub TextBox1_Change() TextBox1.Value = UCase(TextBox1.Value) [A1]=TextBox1.value End Sub " Textboxta girişte otomatik büyük harf 3 (türkçe karakter sorunu için) "Private Sub TextBox1_Change() On Error Resume Next [aa1] = ""=büyükharf("""""" & TextBox1 & """""")"" [aa1] = ""=upper("""""" & TextBox1 & """""")"" TextBox1 = [aa1] End Sub" Textboxta girişte otomatik büyük harf 4 (türkçe karakter sorunu için) "Private Sub TextBox1_Change() On Error Resume Next TextBox1 = Evaluate(""=büyükharf("""""" & TextBox1 & """""")"") TextBox1 = Evaluate(""=upper("""""" & TextBox1 & """""")"") End Sub" Textboxta kuruŞ "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""###,###.00"") End Sub " Textbox'ta kuruş 1 "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""###,###.00"") End Sub" Textbox'ta kuruş 2 "Private Sub TextBox1_LostFocus() TextBox1 = Format(TextBox1, "".##"") End Sub" Textbox'ta metnİ İkİ yana yaslama ve tab ÖzellİĞİ "ekli dosyamda textboxa metin girişi yaptığımda 1. satırının x ten başlaması ve birde textboxta yazılan metni exceldeki gibi nasıl iki yana yaslayabilirim. yardımcı olacak üstadlara şimdiden teşekkür ederim .( Birinci sorunuz için textboxa aşağıdaki kodu yazın. Bu arada properties penceresinde yazmış olduğunuz x i silin.) visual basic kodu: Private Sub TextBox1_Change() If Len(TextBox1) = 1 Then TextBox1 = "" "" & TextBox1 End Sub" Textboxta ondalıklı sayıları toplama "Private Sub TextBox3_Enter() TextBox3 = Ccur(TextBox1) + Ccur(TextBox2) End Sub" Textbox'ta para birimi "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""#,### TL"") End Sub " Textbox'ta para birimi 2 "Private Sub TextBox1_Change() RefreshTxtBx End Sub Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""#,### TL"") End Sub ' Private Sub TextBox2_Change() RefreshTxtBx End Sub ' Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox2 = Format(TextBox2, ""#,### TL"") End Sub ' Private Sub RefreshTxtBx() Dim Val1 As Double, Val2 As Double On Error Resume Next Val1 = TextBox1 Val2 = TextBox2 On Error GoTo 0 TextBox3 = Format(Val1 + Val2, ""#,### TL"") End Sub" Textboxta para formatı-birimi "TextBox1 = Format(TextBox1, ""###,0"") parasal olarak bunu kullanın Private Sub CommandButton1_Click() Range(""a1"").Select ActiveCell.Formula = TextBox1 End Sub" Textboxta rakamın başına 0 sıfır ekleme "Excele kayderkenKod: Cells(1,1) = ""'"" & textbox1.text Private Sub TextBox1_Change() TextBox1 = ""0"" & Format(TextBox1, ""###,###"") End Sub " Textboxta sağa yanaşık yazma TextBox1.TextAlign = fmTextAlignRight Textboxta seslileri sayma "Option Explicit Private Sub Command1_Click() Text2.Text = Seslisay(Text1.Text) End Sub Function Seslisay(Metin As String) As Integer Dim sayac, i As Integer Const Harfler = ""aeıioöuü"" For i = 1 To Len(Metin) If InStr(Harfler, LCase(Mid(Metin, i, 1))) <> 0 Then sayac = sayac + 1 End If Next i Seslisay = sayac End Function" Textbox'ta tam sayi ÖrneĞİ "TextBox2 = cint(Sheets(""9b"").Cells(x, 7)) TextBox3 = cint(Sheets(""9b"").Cells(x, 8)). " Textboxta tarih formatı "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""dd""""/""""mm""""/""""yyyy"") End Sub " Textboxta tarih formatı 2 "Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If TextBox1.Text > """" Then If Not IsDate(TextBox1.Text) Then MsgBox ""Tarih geçerli değil"", vbInformation TextBox1.SetFocus Exit Sub End If End If End Sub" Textboxta tarih toplama "Private Sub TextBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean) tarih = Calendar2.Value TextBox6 = DateSerial(Year(tarih), Month(tarih) + 6, Day(tarih)) End Sub" Textboxta tarih toplama çıkarma hatasız "Dim Date1 As Date, Date2 As Date Dim yil As Integer, ay As Integer, gun As Integer Date1 = DateSerial(Year(Text1), Month(Text1), Day(Text1)) Date2 = DateSerial(Year(Text2), Month(Text2), Day(Text2)) Date2 = DateAdd(""d"", 1, Date2) 'BENİM EKLEDİĞİM SATIR yil = DateDiff(""yyyy"", Date1, Date2) ay = DateDiff(""m"", Date1, Date2) + (Day(Date1) > Day(Date2)) yil = yil + ((ay - yil * 12) < 0) ay = ay Mod 12 gun = DateDiff(""d"", Date1, Date2) - DateDiff(""d"", Date1, DateAdd(""yyyy"", yil, DateAdd(""m"", ay, Date1))) Text3 = yil & "" yıl, "" & ay & "" ay ve "" & gun & "" gün.""" Textboxta telefon formatı "Private Sub TextBox1_Change() If Len(TextBox1.Text) < 10 Then TextBox1 = Replace(TextBox1, "" "", """") Else TextBox1.Text = Format(TextBox1, ""0(###) ### ## ##"") End If End Sub" Textboxta telefon formatı 2 "Private Sub TextBox1_Change() If Len(TextBox1.Text) >= 16 Then TextBox1 = Left(TextBox1, 16) If Len(TextBox1.Text) < 10 Then TextBox1 = Replace(TextBox1, "" "", """") Else TextBox1.Text = Format(TextBox1, ""0(###) ### ## ##"") End If End Sub" Textboxta telefon formatı 3 "Private Sub TextBox1_Change() If Len(TextBox1.Text) >= 15 Then TextBox1 = Left(TextBox1, 15) If Len(TextBox1.Text) < 10 Then TextBox1 = Replace(TextBox1, "" "", """") Else TextBox1.Text = Format(TextBox1, ""(###) ### ## ##"") End If End Sub" Textboxta telefon numarası formatı "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""(###)"""".""""###"""".""""##"""".""""##"") End Sub" Textboxta toplama "Private Sub TextBox3_Enter() TextBox3 = CInt(TextBox1) + CInt(TextBox2) End Sub veya Private Sub TextBox3_Enter() TextBox3 = Val(TextBox1) + Val(TextBox2) End Sub " Textboxta veri sınırlaması (max karakter) "Private Sub CommandButton1_Click() TextBox1.MaxLength = 7 End Sub" Textboxta virgülden sonra 2 haneden fazla veya eksik veri girişini engelleme "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, ""###,###.00"") End Sub" Textboxta yazanı sayfada buldurma (tamamını yazmak şart) "Private Sub CommandButton1_Click() Dim i As Byte If Len(TextBox1) > 0 Then For i = 1 To Worksheets.Count Call Myxxrt(Worksheets(i).Name) Next End If End Sub Private Function Myxxrt(ShName As String) Dim MyRng As Range On Error Resume Next Set MyRng = Range(Sheets(ShName).Cells.Find(TextBox1, LookAt:=xlWhole).Address) MsgBox ""Aranılan değer "" & ShName & "" sayfasında "" & MyRng.Address(False, False) & "" hücresinde bulundu !"" Set MyRng = Nothing End Function" Textboxta yazanların ilk harfleri büyük olur "Public Function AutoType(c As Control, KeyAscii As Integer) As Integer AutoType = KeyAscii If KeyAscii > 95 And KeyAscii < 123 Then If c.SelStart = 0 Then AutoType = AutoType - 32 ElseIf Mid$(c.Text, c.SelStart, 1) < ""!"" Then AutoType = AutoType - 32 End If End If End Function Private Sub Text1_KeyPress(KeyAscii As Integer) KeyAscii = AutoType(Screen.ActiveControl, KeyAscii) End Sub" Textboxta ytl "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = Format(TextBox1, (""##,###.## Ytl"")) End Sub" Textboxtakİ 1/1 excelde 1 "Hiçbir değişiklik yapmadan göstermesi lazım mesela A1 hücrenizde gözükecekse bu veri (A1 hücreniz genel olsun) aşağıdaki gibi yazabilirsiniz Private Sub TextBox6_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If TextBox6 Like ""#"" Then TextBox6 = TextBox6 & ""/"" Range(""a1"") = TextBox6 End Sub" Textboxtaki karakterleri seçme ok işaretiyle "Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) On Error GoTo ErrHand: With TextBox1 If KeyCode = vbKeyLeft Or KeyCode = vbKeyBack Then KeyCode = vbKeySelect .SelStart = .SelStart - 1 .SelLength = 1 ElseIf KeyCode = vbKeyRight Then KeyCode = vbKeySelect .SelStart = .SelStart + 1 .SelLength = 1 ElseIf KeyCode = vbKeyDelete Then KeyCode = vbKeySelect If .SelText = ""."" Then .SelText = ""."" Else .SelText = ""#"" End If .SelStart = .SelStart - 1 .SelLength = 1 ElseIf KeyCode = vbKeyHome Then KeyCode = vbKeySelect .SelStart = 0 .SelLength = 1 ElseIf KeyCode = vbKeyEnd Then KeyCode = vbKeySelect .SelStart = Len(TextBox1) - 1 .SelLength = 1 End If End With Exit Sub ErrHand: KeyCode = vbKeySelect TextBox1.SelStart = 0 TextBox1.SelLength = 1 End Sub" Textboxtakİ verİye gÖre sÜzme İŞlemİ "UserFormda TextBoxları açıyorsun.Diyelimki 5 tane.TextBox1,2 .5.UserFormun Initialize kısmına Kod: Private Sub UserForm_Initialize() TextBox1.Text = Range(""d5"").Text TextBox2.Text = Range(""d6"").Text TextBox3.Text = Range(""d7"").Text TextBox4.Text = Range(""d8"").Text TextBox5.Text = Range(""d9"").Text End Sub " Textboxtaki yazının mesaj olarak bildirilmesi MsgBox TextBox1.Text & " İSİMLİ ŞAHISIN KAYDI GÜNCELLENMİŞTİR.", vbInformation + vbOKOnly, "KAYIT GÜNCELLENDİ" Textboxtan çıkarken msgbox "Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If IsNumeric(TextBox1) Then MsgBox ""KAYDETMEKTE OLDUĞUNUZ KART BÖLÜM KARTIDIR. PERSONEL İÇİN BU KART KODUNUN ALTINDA PERSONEL KARTLARI AÇINIZ, DEVAM ETMEK İSTEDİĞİNİZDEN EMİN MİSİNİZ?"", vbQuestion + vbYesNo End Sub " Textbox'u sesli okuma "Tools>References bölümünden microsoft speech object library'i ekleyin 1 adet UserForm oluşturun 1 adet TextBox 1 adet CommanButton Dim konus As New SpeechLib.SpVoice Private Sub UserForm_Activate() TextBox1.Text = ""buraya istediğini yaz"" End Sub Private Sub CommandButton1_Click() konus.Speak TextBox1.Text End Sub" Textbox'un aktifleştirilmesi TextBox1.SetFocus Timer mesaj örneği "Sub timerMsg() Dim alertTime MsgBox ""The alarm will go off in 3 seconds!"" alertTime = Now + TimeValue(""00:00:03"") Application.OnTime alertTime, ""msg"" End Sub Sub msg() MsgBox ""Three Seconds is up!"" End Sub" Tl ve ytl "Kod: Private Sub CommandButton1_Click() Unload Me End Sub Private Sub TextBox1_Change() On Error Resume Next TextBox1 = Format(TextBox1.Value, ""#,##0"") TextBox2.Value = Format(TextBox1.Value / 1000000, ""#,##0.00"") End Sub " Toggle button oluşturma ve komut "Denetim Araç Kutusu (Control Toolbox) Araç Çubuğundan ToggleButton Private Sub ToggleButton1_Click() If ToggleButton1.Value = True Then ToggleButton1.Caption = ""SİL"" Range(""A3"") = Range(""A1"") + Range(""A2"") Else ToggleButton1.Caption = ""TOPLA"" Range(""A3"").ClearContents End If End Sub" Toolbar oluŞturma "Private Sub CommandButton1_Click() For i = 1 To 5 Toolbar1.Buttons.Add.Caption = i For x = 1 To 5 Toolbar1.Buttons(i).ButtonMenus.Add.Text = x Toolbar1.Buttons(i).Style = tbrDropdown Next x Next i End Sub" Topla formülünü yazar "Option Explicit Sub AutoSum1() CommandBars.FindControl(ID:=226).Execute Application.SendKeys ""~"" End Sub Sub AutoSum2() With Application.CommandBars.FindControl(ID:=226) .Execute .Execute End With End Sub" Topla.ÇArpım worksheet.Function karşılığ Bul = Evaluate("=SumProduct((B2:B65536 = ""A"") * (D2:D65536=""P""))") Toplama formülü makro örnekleri "‘1. MySum = WorksheetFunction.Sum(Range(""A1:A20"")) MsgBox MySum ‘2. Range(""a21"") = WorksheetFunction.Sum(Range(""a1:a20"")) ‘3.. Range(""A21"").Formula = ""=Sum(A1:A20)"" ’4. Range(""A21"").Formula = ""=topla(A1:A20)+S("" & Chr(34) & ""Bu formül makro ile yazılmıştır"" & Chr(34) & "")"" " Toplamları sıfıra eşit olan satırları gizler "Sub sıfırgizle() For Each rngRow In ActiveSheet.UsedRange.Rows If Application.Sum(rngRow) = 0 Then rngRow.EntireRow.Hidden = True End If Next rngRow End Sub " Treevİew "Private Sub TreeView1_Click() On Error GoTo son Dim bak As Range Dim a As String a = UserForm1.TreeView1.SelectedItem.Text If a <> """" Then Sayfa2.Select For Each bak In Sayfa2.Range(""B2:B"" & WorksheetFunction.CountA(Sayfa2.Range(""B1:B65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(a, vbUpperCase) Then ' .ComboBox1.Value, vbUpperCase) Then bak.Select With UserForm1 .TextBox1.Value = bak.Offset(0, 0) 'adı soyadı .TextBox4.Value = bak.Offset(0, 1) 'görevi .TextBox2.Value = bak.Offset(0, 3) 'tc kimlik no .TextBox3.Value = bak.Offset(0, 2) 'sicil no End With Exit Sub End If Next bak Else Exit Sub End If son: MsgBox ""Aradığınız isimde bir kayıt bulunamadı"" End Sub" Treeview a eklediğimiz bir veriyi seçerek bunu çift tıklamayla aktif hücreye yazdır "Private Sub TreeView1_DblClick() ActiveCell = TreeView1.SelectedItem.Text End Sub" Tuşa aktarılır gelen kutucuktaki değeri "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 " TuŞa aktarilir gelen kutucuktakİ "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 " Tuşların ascii değerleri ve vba karşılıkları "Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) MsgBox ""Basılan Tuşun Ascii Değeri :"" & KeyAscii End Sub" Tuşların keycode ları "Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) MsgBox KeyCode End Sub" Tüm açıklamaları gizle göster "Sub MsqXP() Application.DisplayCommentIndicator = xlCommentIndicatorOnly End Sub Sub AffXP() Application.DisplayCommentIndicator = xlCommentAndIndicator End Sub" Tüm araç çubuklarını listele "Sub LstBO() 'Worksheets(""LstBO"").Select For Each cbar In CommandBars x = x + 1 [A1] = ""Nom de la barre d'outils"" [A1].Offset(x, 0) = cbar.Name [B1] = ""Nom local de la barre d'outils"" [B1].Offset(x, 0) = cbar.NameLocal [C1] = ""Visible"" [C1].Offset(x, 0) = cbar.Visible Next End Sub" Tüm checkbutton ları sıfırlar "Sub ResetAllCheckBoxesInUserForm() Dim ctrl As Control For Each ctrl In UserForm1.Controls If TypeName(ctrl) = ""CheckBox"" Then ctrl.Value = False End If Next ctrl End Sub" Tüm dosya ve klasörlerde ara bul penceresini çağırma "Private Declare Function ShellExecute Lib ""shell32.dll"" _ Alias ""ShellExecuteA"" ( _ ByVal hwnd As Long, _ ByVal lpOperation As String, _ ByVal lpFile As String, _ ByVal lpParameters As String, _ ByVal lpDirectory As String, _ ByVal nShowCmd As Long) As Long Private Const SW_SHOWNORMAL = 1 Sub FindAllFiles() Dim strPathToSearch As String strPathToSearch = ""C:\"" ShellExecute _ 0, _ ""find"", _ strPathToSearch, _ vbNullString, _ vbNullString, _ SW_SHOWNORMAL End Sub" Tüm excel dosyalarını açma "Sub ShowFileOpenDialog() Dim i As Integer i = Workbooks.Count ' count of open workbooks Application.Dialogs(xlDialogOpen).Show ' displays the Open-dialog Select Case Workbooks.Count - i Case Is <= 0 ' no new workbooks opened MsgBox ""You did not open any new workbooks!"" Exit Sub Case 1 ' add your own code to work on the opened workbook MsgBox ""You opened this workbook: "" & ActiveWorkbook.Name Case Else ' add your own code to work on the opened workbooks MsgBox ""You have opened "" & Workbooks.Count - i & "" workbooks."" End Select End Sub" Tüm excel dosyasında yazdığımız tüm kodların silinmesini "Sub hepsini_sil() If MsgBox(""Projedeki bütün kodları siliyor dikkat etmek lazım."" & vbCrLf & ""Bütün kodlar silinsin mi?"", vbYesNo, ""AMAN DİKKAT!!!"") = vbNo Then Exit Sub For Each modul In ThisWorkbook.VBProject.VBComponents With modul.codemodule .deletelines 1, .countoflines End With Next End Sub" Tüm formları kapatmak showmodal false olanları 1 "Sub Test() For i = UserForms.Count - 1 To 0 Step -1 Unload UserForms(i) Next End Sub" Tüm formları kapatmak showmodal false olanları 2 "Sub Test2() For Each MyForm In UserForms Unload MyForm Next MyForm End Sub" Tüm gizli satır ve sütunları gösterme "Sub MasqueColonneLigne() On Error Resume Next Application.ScreenUpdating = False Numligne = InputBox(Prompt:=""Taper les numéros de lignes. ( Ex. 8:12 - Maxi = 65536)"") NumColonne = InputBox(Prompt:=""Taper les numéros de colonnes. ( Ex. J:D - Maxi = IV )"") Rows(Numligne).Select Selection.EntireRow.Hidden = True Columns(NumColonne).Select Selection.EntireColumn.Hidden = True End Sub" Tüm gizli sayfaları göster "Sub Un_Hide_All() Dim sh As Worksheet For Each sh In Worksheets sh.Visible = True Next End Sub" Tüm gizli sayfaları göster "Sub UnhideAllSheets() Dim wsSheet As Worksheet For Each wsSheet In ActiveWorkbook.Worksheets wsSheet.Visible = xlSheetVisible Next wsSheet End Sub" Tüm gizli sayfaları sırayla gösterir, mesaj verir göstereyim mi diye? "Sub UnhideSomeSheets() Dim sSheetName As String Dim sMessage As String Dim Msgres As VbMsgBoxResult For Each wsSheet In ActiveWorkbook.Worksheets If wsSheet.Visible = xlSheetHidden Then sSheetName = wsSheet.Name sMessage = ""Unhide the following sheet?"" _ & vbNewLine & sSheetName Msgres = MsgBox(sMessage, vbYesNo) If Msgres = vbYes Then wsSheet.Visible = xlSheetVisible End If Next wsSheet End Sub" Tüm harfler büyük (yazım düzeni) "Sub InGross() For Each c In Selection.Cells c.Value = UCase$(c.Value) Next c End Sub" Tüm harfler büyük yazım düzeni "Sub UpperCase() Dim cell As Range For Each cell In Selection.Cells If cell.HasFormula = False Then cell = UCase(cell) End If Next End Sub" Tüm harfler küçük (yazım düzeni) "Sub InKlein() For Each c In Selection.Cells c.Value = LCase$(c.Value) Next c End Sub" Tüm kitabı şifreleleme-Şifreyi siz verin "Sub ProtectAllSheets() Dim ws As Worksheet Dim sOrigSheet As String Dim sOrigCell As String Dim J As Integer Dim sPWord As String Application.ScreenUpdating = False sOrigSheet = ActiveSheet.Name sOrigCell = ActiveCell.Address sPWord = InputBox(""What password?"", ""Protect All"") If sPWord > """" Then For Each ws In Worksheets ws.Select ws.Protect Password:=sPWord Next ws End If Application.GoTo Reference:=Worksheets("""" & sOrigSheet & """").Range("""" & sOrigCell & """") Application.ScreenUpdating = True End Sub" Tüm kitabı ve sayfalarını şifreleme "Sub ChartUnProtect() Dim wks As Worksheet Dim cht As Chart Dim chtObj As ChartObject Dim PW As String PW = ""mypass"" 'Unprotect all Chart sheets For Each cht In ActiveWorkbook.Charts Sheets(cht.Name).Unprotect password:=PW Next 'Unlock all Chart objects on each worksheet For Each wks In ActiveWorkbook.Worksheets wks.Unprotect password:=PW For Each chtObj In wks.ChartObjects wks.DrawingObjects(chtObj.Name).Locked = False Next wks.Protect password:=PW Next End Sub" Tüm kitabı ve sayfalarını şifreleme 2 "Sub ProtectAllSheets() Dim ws As Worksheet Dim sOrigSheet As String Dim sOrigCell As String Dim J As Integer Application.ScreenUpdating = False sOrigSheet = ActiveSheet.Name sOrigCell = ActiveCell.Address For Each ws In Worksheets ws.Select ws.Protect Password:=""Password"" Next ws Application.GoTo Reference:=Worksheets("""" & sOrigSheet & """").Range("""" & sOrigCell & """") Application.ScreenUpdating = True End Sub" Tüm kitapta istenilen sayfada sütunlardaki en son dolu hücreleri bildirir "Thisworkbook'a Option Explicit Sub Zeilen_pro_Spalte_zaehlen() Dim x As Integer, y As Long For x = 1 To ActiveSheet.UsedRange.Columns.Count y = Cells(65536, x).End(xlUp).Row MsgBox ""Sütun "" & x & "", Satır "" & y & "" dolu hücredir"" Next End Sub" Tüm kitapta seçili hücre sarı renkli "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range) Static OldIndex As Integer Static OldCell As Range On Error Resume Next OldCell.Interior.ColorIndex = OldIndex If Not OldCell Is Nothing Then OldIndex = Target.Interior.ColorIndex End If Target.Interior.ColorIndex = 6 Set OldCell = Target End Sub" Tüm klasör kopyalanıyor "Sub Klasör_Kopyala() Dim ds Set ds = CreateObject(""Scripting.FileSystemObject"") ds.CopyFolder ""D:\ExcelÖrnekleri"", ""C:\SXS"" End Sub" Tüm makroları seçtiğiniz bir klasördeki excel dosyalarının içindeki makroları listeler "Sub sirala() Dim sd As VBComponent Dim kodlar As CodeModule Dim Dosya Dim wb As Workbook i = 2 On Error Resume Next Application.DisplayAlerts = False Set ObjFolder = CreateObject(""Shell.Application"").BrowseForFolder(0, ""Klasör Seçiniz "", &H4, """") pth = ObjFolder.items.Item.Path ChDir (pth) Dosya = Dir(""*.xls"") While Dosya <> """" Set wb = Workbooks.Open(pth & ""\"" & Dosya) Windows(wb.Name).Visible = False For Each sd In wb.VBProject.VBComponents Set kodlar = sd.CodeModule basla = kodlar.CountOfDeclarationLines + 1 If Err.Number = 0 Then Do Until basla >= kodlar.CountOfLines If Err.Number <> 0 Then Err.Clear: Exit Do ThisWorkbook.Sheets(1).Cells(i, ""A"") = pth & ""\"" & Dosya ThisWorkbook.Sheets(1).Cells(i, ""B"") = kodlar.ProcOfLine(basla, vbext_pk_Proc) ThisWorkbook.Sheets(1).Cells(i, ""C"") = sd.Name basla = basla + kodlar.ProcCountLines(kodlar.ProcOfLine(basla, vbext_pk_Proc), vbext_pk_Proc) i = i + 1 Loop Else Err.Clear End If Next Dosya = Dir wb.Close False Wend End Sub" Tüm makroların listesi "‘Referanslardan Microsoft visual Basic for Applications Extensibility x.x seçin ’Aktif kitaptaki makroları, A sütununa makronun adını, B sütununu da yerini belirtecek şekilde listeler. Sub sirala() Dim sd As VBComponent Dim kodlar As CodeModule i = 1 For Each sd In ActiveWorkbook.VBProject.VBComponents Set kodlar = sd.CodeModule basla = kodlar.CountOfDeclarationLines + 1 Do Until basla >= kodlar.CountOfLines Cells(i, ""A"") = kodlar.ProcOfLine(basla, vbext_pk_Proc) Cells(i, ""B"") = sd.Name basla = basla + kodlar.ProcCountLines(kodlar.ProcOfLine(basla, vbext_pk_Proc), vbext_pk_Proc) i = i + 1 Loop Next End Sub" Tüm oppitobuttonları sıfırlar "Sub ResetAllOptionButtonsInUserForm() Dim ctrl As Control For Each ctrl In UserForm1.Controls If TypeName(ctrl) = ""OptionButton"" Then ctrl.Value = False End If Next ctrl End Sub " Tüm resimleri silmek "Sub Ekle_Nesne_TumSil() ActiveSheet.DrawingObjects.Delete End Sub Sub Ekle_Nesne_IstedigimiSil() Dim Picture As Object Dim Bak As String Dim Uzunluk As Byte Bak = InputBox(""Hangi Türdeki Resim Silinecek?"", ""S. UZUNKÖPRÜ"", ""WordArt"") Uzunluk = Len(Bak) For Each Picture In ActiveSheet.shapes If Mid(Picture.Name, 1, Uzunluk) = Bak Then Picture.Delete End If Next Picture End Sub" Tüm satır sütunları gizle "Sub sat_sut_giz() If TypeName(ActiveSheet) <> ""Worksheet"" Then Exit Sub If Rows(Rows.Count).Hidden = False And _ Columns(Columns.Count).Hidden = False Then Columns.Hidden = True Rows.Hidden = True With ActiveSheet.UsedRange .Columns.Hidden = False .Rows.Hidden = False End With Else Columns.Hidden = False Rows.Hidden = False End If End Sub" Tüm satır sütunları göster "Sub sat_sut_gos() If TypeName(ActiveSheet) <> ""Worksheet"" Then Exit Sub If Rows(Rows.Count).Hidden = True And _ Columns(Columns.Count).Hidden = True Then Columns.Hidden = False Rows.Hidden = False With ActiveSheet.UsedRange .Columns.Hidden = True .Rows.Hidden = True End With Else Columns.Hidden = True Rows.Hidden = True End If End Sub" Tüm satır ve sütunları gizler "Sub Blenden() If TypeName(ActiveSheet) <> ""Worksheet"" Then Exit Sub If Rows(Rows.Count).Hidden = False And _ Columns(Columns.Count).Hidden = False Then Columns.Hidden = True Rows.Hidden = True With ActiveSheet.UsedRange .Columns.Hidden = False .Rows.Hidden = False End With Else Columns.Hidden = False Rows.Hidden = False End If End Sub" Tüm sayfada tek ve fazla seçimde renklendirme "Thisworkbooka Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range) Static OldIndex As Integer Static OldCell As Range On Error Resume Next OldCell.Interior.ColorIndex = OldIndex If Not OldCell Is Nothing Then OldIndex = Target.Interior.ColorIndex End If Target.Interior.ColorIndex = 6 Set OldCell = Target End Sub" Tüm sayfalarda a1:a5, b6:b10,c1:c5, d4:d10 hücrelerinde veri var ise 0 yapar "Sub Reset_Values_All_WSheets() Dim wSht As Worksheet Dim myRng As Range Dim allwShts As Sheets Dim cel As Range Set allwShts = Worksheets For Each wSht In allwShts Set myRng = wSht.Range(""A1:A5, B6:B10, C1:C5, D4:D10"") For Each cel In myRng If Not cel.HasFormula And cel.Value <> 0 Then cel.Value = 0 End If Next cel Next wSht End Sub" Tüm sayfalarda resim (image) silme "For Each sht In Worksheets sht.DrawingObjects.Delete Next" Tüm sayfalarda zoom ayarı "Thisworkbook a Private Sub Workbook_SheetActivate(ByVal Sh As Object) ActiveWindow.Zoom = 80 End Sub" Tüm sayfaları gizle 1 sayfa mutlaka gözükür "Sub a() ‘On Error Resume Next ‘Application.DisplayAlerts = False For Each Sh In Sheets Sh.Visible = False Next Sh End Sub" Tüm sayfaları gizler ve istediğiniz sayfayı gösterir ve tersini yapar "Public bIsClosing As Boolean Dim wsSheet As Worksheet Sub HideAll() Application.ScreenUpdating = False For Each wsSheet In ThisWorkbook.Worksheets If wsSheet.CodeName = ""Sheet1"" Then wsSheet.Visible = xlSheetVisible Else wsSheet.Visible = xlSheetVeryHidden End If Next wsSheet Application.ScreenUpdating = True End Sub Sub ShowAll() bIsClosing = False For Each wsSheet In ThisWorkbook.Worksheets If wsSheet.CodeName <> ""Sheet1"" Then wsSheet.Visible = xlSheetVisible End If Next wsSheet Sheet1.Visible = xlSheetVeryHidden End Sub" Tüm sayfaları koruma altına alır, kilitler "Sub protectAll() Dim myCount Dim i myCount = Application.Sheets.Count Sheets(1).Select For i = 1 To myCount ActiveSheet.Protect If i = myCount Then End End If ActiveSheet.Next.Select Next i End Sub" Tüm sayfaları seçip alfabetik olarak son sayfayı aktif kılma "Sub SelectSheets1() Dim mySheet As Object For Each mySheet In Sheets With mySheet If .Visible = True Then .Select Replace:=False End With Next mySheet End Sub" Tüm sayfaları seçme "Sub SelectSheets() Dim myArray() As Variant Dim i As Integer For i = 1 To Sheets.Count ReDim Preserve myArray(i - 1) myArray(i - 1) = i Next i Sheets(myArray).Select End Sub" Tüm sayfaları seçme 2 "Sub SelectSheets() Dim myArray() As Variant Dim i As Integer Dim j As Integer j = 0 For i = 1 To Sheets.Count If Sheets(i).Visible = True Then ReDim Preserve myArray(j) myArray(j) = i j = j + 1 End If Next i Sheets(myArray).Select End Sub" Tüm sayfaların a1 değerlerini toplar mesajla bildirir "Sub Addieren() Dim Summen! Summen = 0 For i = 1 To Worksheets.Count Summen = Summen + Worksheets(i).[A1] Next MsgBox Summen End Sub" Tüm sürücüleri gösterir "Sub Show_all_Drives() Dim myFSO As Object, myDrv As Object, drvCount, drvStr As String, vName As String, drvTyp As String Set myFSO = CreateObject(""Scripting.FileSystemObject"") Set drvCount = myFSO.Drives On Error Resume Next drvStr = """" For Each myDrv In drvCount Select Case myDrv.DriveType Case 0: drvTyp = ""Unknown"" Case 1: drvTyp = ""Removable"" Case 2: drvTyp = ""Fixed"" Case 3: drvTyp = ""Network"" Case 4: drvTyp = ""CD-ROM"" Case 5: drvTyp = ""RAM Disk"" End Select drvStr = drvStr & drvTyp & "": "" & myDrv.DriveLetter & "" - "" '3 = Netzlaufwerk If myDrv.DriveType = 3 Then vName = myDrv.ShareName Else vName = myDrv.VolumeName End If drvStr = drvStr & vName & vbCrLf Next MsgBox drvStr End Sub" Tüm şifreli sayfaları geri açma "Sub UnProtectAllSheets() Dim ws As Worksheet Dim sOrigSheet As String Dim sOrigCell As String Dim J As Integer Application.ScreenUpdating = False sOrigSheet = ActiveSheet.Name sOrigCell = ActiveCell.Address For Each ws In Worksheets ws.Select ws.Unprotect Password:=""Password"" Next ws Application.GoTo Reference:=Worksheets("""" & sOrigSheet & """").Range("""" & sOrigCell & """") Application.ScreenUpdating = True End Sub" Tüm textboxların içeriğini temizler "Private Sub CommandButton1_Click() Dim ctrl As Control For Each ctrl In UserForm1.Controls If TypeName(ctrl) = ""TextBox"" Then ctrl.Text = """" End If Next ctrl End Sub" Txt dosyası açma "Sub OuvreTXT() lanceur = Shell(""C:\windows\notepad.exe c:\ali.txt"", 1) End Sub" Txt dosyasına a1 de değeri yazdırma "Sub a1txt() Var = [A1] FichierTXT = ""C:\a\a.txt"" 'à modifier If Len(Dir(FichierTXT)) > 1 Then Kill FichierTXT Open FichierTXT For Output As 1 Print #1, Var Close End Sub" Txt dosyasını sayfada açıp içeriğini alma, txt dosyasının adı sayfa adı olur "Sub txt_import() pir = Application.GetOpenFilename(""Txt-Dosyası , *.TXT"") Workbooks.OpenText Filename:=pir, Origin:=xlWindows _ , StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon _ :=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(1, 1) End Sub" Txt dosyasını seç yeni excel sayfasına yazsın "Sub Read_Large_File_2() Dim FileName As String Dim FileNum As Integer Dim ResultStr As String Dim wsSheet As Worksheet Dim strValues() As String Dim lngRows As Long Dim lngRow As Long Dim intSheet As Integer Dim intCounter As Integer FileName = Application.GetOpenFilename(""Textdateien "" & _ ""(*.txt; *.csv),*.txt; *.csv"") If FileName = """" Or FileName = ""Falsch"" Then Exit Sub FileNum = FreeFile() Open FileName For Input As #FileNum Application.ScreenUpdating = False Workbooks.Add template:=xlWorksheet lngRows = ActiveSheet.Rows.Count lngRow = 1 intSheet = 1 ReDim strValues(lngRows, 1) Application.StatusBar = ""Blatt "" & intSheet & "" wird eingelesen"" Do While Seek(FileNum) <= LOF(FileNum) Line Input #FileNum, ResultStr If Left(ResultStr, 1) = ""="" Then strValues(lngRow, 1) = ""'"" & ResultStr Else strValues(lngRow, 1) = ResultStr End If If lngRow < lngRows Then lngRow = lngRow + 1 Else ActiveSheet.Range(""A1:A"" & lngRows) = strValues ActiveWorkbook.Worksheets.Add after:=Worksheets(Worksheets.Count) ReDim strValues(lngRows, 1) lngRow = 1 intSheet = intSheet + 1 Application.StatusBar = ""Blatt "" & intSheet & "" wird eingelesen"" End If Loop Close ActiveSheet.Range(""A1:A"" & lngRows) = strValues If MsgBox(""Sollen die eingelesenen Daten auf Spalten verteilt werden?"", _ vbYesNo, ""Text in Spalten"") = vbNo Then Application.ScreenUpdating = True Application.StatusBar = ""Fertig"" Exit Sub End If intSheet = 0 For Each wsSheet In ActiveWorkbook.Worksheets intSheet = intSheet + 1 Application.StatusBar = ""Daten von Blatt "" & intSheet _ & "" werden bearbeitet"" With wsSheet .Range(""A:A"").TextToColumns Destination:=.Range(""A1""), _ DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, _ Tab:=False, _ Semicolon:=True, _ Comma:=False, _ Space:=False, _ Other:=False End With Next wsSheet Application.ScreenUpdating = True Application.StatusBar = ""Fertig"" End Sub" Txt dosyasını silme "Sub DelFile() If Len(Dir(""c:\metin.txt"")) > 0 Then Kill ""c:\metin.txt"" MsgBox ""Dosya silinmiştir."" Else MsgBox ""böyle bir dosya yok"" End If End Sub" Txt dosyasi aÇma "Örneğin C altındaki bir txt dosyasını açmak için; visual basic kodu: Shell ""notepad.exe "" & ""c:\deneme.txt"" Kendi klasöründeki bir txt dosyasını açmak içi; visual basic kodu: Shell ""notepad.exe "" & ActiveWorkbook.Path & ""\deneme.txt""" Txtbox a İkİ krİtere gÖre verİ getİrme "Şartı seçtiğiniz comboboxa aşağıdaki kodu kopyalayın. visual basic kodu: Private Sub CmbSart_Change() For a = 2 To [a65536].End(3).Row If CmbUrun = Cells(a, ""a"") And CmbSart = Cells(a, ""b"") Then TxtFiyat = Cells(a, ""c"") Exit Sub End If Next End Sub Ürün comboboxuna da aşağıdaki kodu kopyalayın. visual basic kodu: Private Sub CmbUrun_Click() CmbSart_Change End Sub" Undo---geri al "Option Explicit '// This Sub creates a registry key for '// HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Excel\Options '// Creates Ref to Windows Script Host Object Model '// C:\WINDOWS\SYSTEM\WSHOM.OCX Const strKey As String = ""HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Excel\Options\UndoHistory"" Const strType As String = ""REG_DWORD"" Const dVal = 16 ' Change this NB: > 100 Not recomended by Microsoft Sub ChangeXlUndoHistory() Dim objWSH As Object Set objWSH = CreateObject(""WScript.Shell"") objWSH.RegWrite strKey, dVal, strType Set objWSH = Nothing MsgBox ReadRegEdit(strKey) End Sub '// To Read a Key Function ReadRegEdit(key) Dim Ws, Tmp Set Ws = CreateObject(""WScript.Shell"") Tmp = Ws.RegRead(key) If Tmp = """" Then ReadRegEdit = """" Else ReadRegEdit = Tmp End If Set Ws = Nothing End Function " Userform 1) userform başlığı "Private Sub UserForm_Initialize() UserForm1.Caption = ""pir"" End Sub" Userform 2) userforma alt simge durumunu küçültme ve ekranı kapla butonu ekleme "Private Declare Function FindWindowA Lib ""User32"" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function EnableWindow Lib ""User32"" _ (ByVal hWnd As Long, ByVal bEnable As Long) As Long Private Declare Function GetWindowLongA Lib ""User32"" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLongA Lib ""User32"" _ (ByVal hWnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Sub UserForm_Activate() EnableWindow FindWindowA(""XLMAIN"", Application.Caption), 1 End Sub Private Sub UserForm_Initialize() Dim hWnd As Long hWnd = FindWindowA(vbNullString, Me.Caption) SetWindowLongA hWnd, -16, GetWindowLongA(hWnd, -16) Or &H20000 End Sub" Userform 3) userformun üst sağdaki kapat butonunu gizler "Private Declare Function GetWindowLongA Lib ""User32"" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLongA Lib ""User32"" _ (ByVal hwnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function FindWindowA Lib ""User32"" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Sub UserForm_Initialize() Dim hwnd As Long hwnd = FindWindowA(""Thunder"" & IIf(Application.Version Like ""8*"", _ ""X"", ""D"") & ""Frame"", Me.Caption) SetWindowLongA hwnd, -16, GetWindowLongA(hwnd, -16) And &HFFF7FFFF End Sub" Userform 4) belirli bir süre ekranda bekleyen ve daha sonra kapan user form. "Private Sub UserForm_Activate() ' Récupération de l'heure d'affichage de la BdD TimeDebut = Timer ' Donne la main à excel pour facilité l'affichage de la BdD DoEvents ' Boucle tant que 2 secondes ne se sont pas écoulé While Timer < TimeDebut + 10 Wend ' Fermeture de la BdD Unload Me End Sub" Userform 5) süreli userform-2 "Private Sub UserForm_Activate() Application.Wait Now + TimeSerial(0, 0, 3) Unload Me End Sub" Userform 6) userformun başındaki kapat butonunu pasif yapar (çarpıya basınca userform kapanmaz "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then Cancel = True End Sub" Userform 7) userformun çarpı işaretine tıklayınca mesaj kutusuyla uyarı veriyor "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then MsgBox ""çarpıdan kapatmak yasaktır!"" Cancel = True End If End Sub" Userform bekletmeli açılış "Private Sub UserForm_Activate() Application.Wait Now + TimeValue(""00:00:02"") Call kaydet Unload Me End Sub Sub kaydet() Sheets(""sayfa1"").Select End Sub" Userform bekletmeli açılış 2 "Private Sub UserForm_activate() Dim T Me.Repaint T = Timer + 10 Do While Timer < T Loop Me.Hide End Sub" Userform çıkış iptali mesaj ile "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = 0 Then Cancel = 1 MsgBox ""Lütfen butonu kullanınız"", _ vbOKOnly + vbInformation, ""Çıkış İptali"" End If End Sub" Userform da thundername alma "Private Declare Function FindWindow Lib ""user32"" _ Alias ""FindWindowA"" (ByVal ClassName As String, _ ByVal WindowName As String) As Long Private Sub UserForm_Click() MsgBox FindWindow(""ThunderDFrame"", ""UserForm1"") End Sub" Userform da x tiklayinca excel kapansin "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Application.Quit End Sub" Userform en Üstte "Private Sub UserForm_Activate() UserForm1.Top = True End Sub" Userform full ekran "Private Sub UserForm_Initialize() With UserForm1 .Height = Application.Height .Width = Application.Width End With End Sub" Userform içerisindeki nesnelerin tamamının sayısı MsgBox UserForm1.Controls.Count Userform kapanış örneği ***** yıldız "Private Sub CommandButton3_Click() TextBox1.SetFocus OLDH = UserForm1.Height OLDW = UserForm1.Width Me.Caption = ""SAYMANLIK İŞLEM FİŞİ K A P A N I Y O R "" PauseTime = 1 Start = Timer Do While Timer < Start + PauseTime DoEvents Loop Dim i As Integer For i = 1 To 220 With UserForm1 .Top = UserForm1.Top + 0.7 .Left = UserForm1.Left + 0.51 .Height = UserForm1.Height - 1.3 .Width = UserForm1.Width - 1 End With UserForm1.Repaint Next i With UserForm1 .Height = OLDH .Width = OLDW .StartUpPosition = 2 End With Unload Me Dim rectangle As RECT fen = GetActiveWindow() Call GetWindowRect(fen, rectangle) For num = 1 To 1750 Call MoveWindow(fen, 250 + 200 * Sin(num * 16.28 / 500), 200 + 200 * Cos(num * 2.28 / 500), 500, 500, True) Next Call MoveWindow(fen, rectangle.Left, rectangle.Top, rectangle.Right - rectangle.Left, rectangle.Bottom - rectangle.Top, True) Unload UserForm1 Application.Quit ActiveWorkbook.Close False End Sub" UserForm mükemmel bir açılış efekti "Option Explicit Private Declare Sub Sleep Lib ""Kernel32"" (ByVal Zeit As Long) Dim pir As Boolean Private Declare Function ShellExecute Lib ""Shell32.dll"" Alias ""ShellExecuteA"" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Function CallWebSite(ByVal URL As String) As Long CallWebSite = ShellExecute(0&, vbNullString, URL, vbNullString, vbNullString, vbMaximizedFocus) End Function Private Sub CommandButton1_Click() Unload Me End Sub Private Sub Label1_Click() CallWebSite (Label1.Caption) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, _ CloseMode As Integer) If CloseMode = vbFormControlMenu Then MsgBox ""Bu şekilde çıkmak yasak !"", 64, ""Information"" Cancel = True End If End Sub Private Sub UserForm_Activate() Me.Width = 40 Me.Height = 180 While Me.Width < 255 Me.Width = Me.Width + 1 Me.Height = Me.Height + 1 Me.StartUpPosition = 1 DoEvents Sleep 5 If pir = True Then Exit Sub Wend End Sub Private Sub UserForm_Click() Me.Width = 120 Me.Height = 180 pir = True End Sub" Userform otomatik boyutlandırma "Bu kodları kod sayfanın en başına yazarsan 3 Düğme oluşur.Kullanıcı istediği gibi büyütür küçültür. Private Declare Function FindWindow Lib ""user32"" Alias ""FindWindowA"" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib ""user32"" Alias ""GetWindowLongA"" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib ""user32"" Alias ""SetWindowLongA"" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function ShowWindow Lib ""user32"" _ (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function DrawMenuBar Lib ""user32"" (ByVal hwnd As Long) As Long Private Sub UserForm_Activate() Dim hWndForm As Long, frmStyle As Long hWndForm = FindWindow(vbNullString, Me.Caption) frmStyle = GetWindowLong(hWndForm, (-16)) frmStyle = frmStyle Or &H80000 Or &H20000 Or &H10000 SetWindowLong hWndForm, (-16), frmStyle ShowWindow hWndForm, 5 DrawMenuBar hWndForm End Sub 'Ayrı bir kod ise Userformun açılışında tam ekran olarak gelmesi. Private Sub UserForm_Initialize() With Application Me.Top = .Top Me.Left = .Left Me.Height = .Height Me.Width = .Width End With End Sub " Userform otomatik boyutlandırma 2 "Private Sub UserForm_Initialize() With Application .WindowState = xlMaximized Zoom = Int(.Width / Me.Width * 100) Width = .Width Height = .Height End With End Sub" Userform sağ altta "Private Sub UserForm_Activate() UserForm1.Left = 600 UserForm1.Top = 425 End Sub" Userform sağ üstte "Private Declare Function GetSystemMetrics Lib _ ""user32"" (ByVal nIndex As Long) As Long Private Const SM_CYSCREEN As Long = 1 Private Const SM_CXSCREEN As Long = 0 'Position Private Declare Function FindWindow Lib ""user32"" Alias _ ""FindWindowA"" (ByVal lpClassName As String, ByVal _ lpWindowName As String) As Long Private Declare Function MoveWindow Lib ""user32"" (ByVal hwnd _ As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _ ByVal nHeight As Long, ByVal bRepaint As Long) As Long Private Sub UserForm_Activate() BildschirmBreite = GetSystemMetrics(SM_CXSCREEN) BildschirmHöhe = GetSystemMetrics(SM_CYSCREEN) UserformBreite = 350 UserformHöhe = 450 wHandle = FindWindow(vbNullString, Me.Caption) MoveWindow wHandle, BildschirmBreite - UserformBreite, _ 0, UserformBreite, UserformHöhe, 1 End Sub" Userform sayfa1'den alsın sayfa2'ye kayıt etsin "Private Sub CommandButton1_Click() Application.ScreenUpdating = False dolusay = WorksheetFunction.CountA(Worksheets(""1"").[a1:a65000]) + 1 Worksheets(""1"").Cells(dolusay, ""a"").Value = dolusay - 1 dolusay = WorksheetFunction.CountA(Worksheets(""1"").[a1:a65000]) Worksheets(""1"").Cells(dolusay, ""b"").Value = cbAd.Value dolusay = WorksheetFunction.CountA(Worksheets(""1"").[a1:a65000]) Worksheets(""1"").Cells(dolusay, ""c"").Value = TextBox1.Value End Sub Sheets(""Formunuzun Bulunmasını istediğiz sayfa"").Select Application.ScreenUpdating = True End Sub" Userform tam ekran "Private Sub UserForm_Initialize() With Application Me.Top = .Top Me.Left = .Left Me.Height = .Height Me.Width = .Width End With End Sub" Userform tam ekran2 "Private Declare Function GetSystemMetrics Lib _ ""user32"" (ByVal nIndex As Long) As Long Private Const SM_CYSCREEN As Long = 1 Private Const SM_CXSCREEN As Long = 0 'Position Private Declare Function FindWindow Lib ""user32"" Alias _ ""FindWindowA"" (ByVal lpClassName As String, ByVal _ lpWindowName As String) As Long Private Declare Function MoveWindow Lib ""user32"" (ByVal hwnd _ As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _ ByVal nHeight As Long, ByVal bRepaint As Long) As Long Private Sub UserForm_Activate() BildschirmBreite = GetSystemMetrics(SM_CXSCREEN) BildschirmHöhe = GetSystemMetrics(SM_CYSCREEN) wHandle = FindWindow(vbNullString, Me.Caption) MoveWindow wHandle, 0, 0, BildschirmBreite, BildschirmHöhe, 1 End Sub" Userform un başlığı haraket ediyor "Bir adet Userform oluşturun ve caption a uzun birşeyler yazın. Tabiiki birde CommandButton koyacaksınız Sub HarfHarf (ref As UserForm1) baslik = ref.Caption ref.Caption = """" For i = 0 To Len(baslik) If i = 0 Then ref.Caption = """" current = Timer Do While Timer - current < 0.1 DoEvents Loop GoTo Son Else End If ref.Caption = Left(baslik, i) current = Timer Do While Timer - current < 0.01 DoEvents Loop Son: Next i End Sub Private Sub CommandButton1_Click() HarfHarf Me End Sub " Userform un baŞliĞi haraket edİyor "Bir adet Userform oluşturun ve caption a uzun birşeyler yazın. Bir de CommandButton Sub HarfHarf (ref As UserForm1) baslik = ref.Caption ref.Caption = """" For i = 0 To Len(baslik) If i = 0 Then ref.Caption = """" current = Timer Do While Timer - current < 0.1 DoEvents Loop GoTo Son Else End If ref.Caption = Left(baslik, i) current = Timer Do While Timer - current < 0.01 DoEvents Loop Son: Next i End Sub Private Sub CommandButton1_Click() HarfHarf Me End Sub " Userform Üzerİnden excel sayfasini otomatİk sÜz "Private Sub CommandButton7_Click() Selection.AutoFilter Columns(""B:B"").Select Selection.AutoFilter Selection.Sort Key1:=Range(""B1""), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Range(""E6"").Select End Sub" Userform ve verİ seÇİmİne gÖre bİlgİ alma "Userforma aşağıdaki kodu; Private Sub UserForm_Initialize() For a = 2 To [c65536].End(3).Row If WorksheetFunction.CountIf(Range(""c2:c"" & a), Cells(a, ""c"")) = 1 Then ComboBox1.AddItem Cells(a, ""c"") Next ListBox1.ColumnCount = 9 ListBox1.ColumnWidths = ""50;50;50;50;50;50;50;50;50"" End Sub comboboxada aşağıdaki kodu kopyalayarak deneyin. visual basic kodu: Private Sub ComboBox1_Click() TextBox1 = WorksheetFunction.SumIf([c:c], ComboBox1, [d:d]) TextBox2 = WorksheetFunction.SumIf([c:c], ComboBox1, [g:g]) TextBox3 = WorksheetFunction.SumIf([c:c], ComboBox1, [i:i]) For sat = 2 To [c65536].End(3).Row If Cells(sat, ""c"") = ComboBox1 Then c = c + 1 For sut = 1 To 9 ListBox1.AddItem ListBox1.List(c - 1, sut - 1) = Cells(sat, sut) Next End If Next End Sub " Userform x işaretini kaldırmak "Bu bir API'dir Private Declare Function GetWindowLongA Lib ""User32"" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLongA Lib ""User32"" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function FindWindowA Lib ""User32"" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Sub UserForm_Initialize() Dim hwnd As Long hwnd = FindWindowA(""Thunder"" & IIf(Application.Version Like ""8*"", ""X"", ""D"") & ""Frame"", Me.Caption) SetWindowLongA hwnd, -16, GetWindowLongA(hwnd, -16) And &HFFF7FFFF End Sub" Userform x yok "Private Const WS_CAPTION As Long = &HC00000 Private Const WS_SYSMENU As Long = &H80000 Private Const WS_THICKFRAME As Long = &H40000 Private Const WS_MINIMIZEBOX As Long = &H20000 Private Const WS_MAXIMIZEBOX As Long = &H10000 Private Const WS_POPUP As Long = &H80000000 Private Const WS_VISIBLE As Long = &H10000000 Private Const WS_EX_DLGMODALFRAME As Long = &H1 Private Const WS_EX_APPWINDOW As Long = &H40000 Private Const WS_EX_TOOLWINDOW As Long = &H80 Private Declare Function FindWindow Lib ""user32"" _ Alias ""FindWindowA"" ( _ ByVal ClassName As String, _ ByVal WindowName As String) As Long Private Declare Function GetWindowLong Lib ""user32"" _ Alias ""GetWindowLongA"" ( _ ByVal hWnd As Long, _ ByVal Index As Long) As Long Private Declare Function SetWindowLong Lib ""user32"" _ Alias ""SetWindowLongA"" ( _ ByVal hWnd As Long, _ ByVal Index As Long, _ ByVal NewLong As Long) As Long Const GWL_STYLE = -16 Private Sub UserForm_Initialize() Dim hWnd As Long Dim Style As Long If Val(Application.Version) >= 9 Then hWnd = FindWindow(""ThunderDFrame"", Me.Caption) Else hWnd = FindWindow(""ThunderXFrame"", Me.Caption) End If Style = GetWindowLong(hWnd, GWL_STYLE) Style = (Style And Not WS_SYSMENU) SetWindowLong hWnd, GWL_STYLE, Style End Sub" Userform1'İn otomatİk aÇilmasi "Sub Auto_Open () Userform1.Show End Sub" Userforma alt simge durumunu küçültme ve ekranı kapla butonu ekler "Private Declare Function FindWindowA Lib ""User32"" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function EnableWindow Lib ""User32"" _ (ByVal hWnd As Long, ByVal bEnable As Long) As Long Private Declare Function GetWindowLongA Lib ""User32"" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLongA Lib ""User32"" _ (ByVal hWnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Sub UserForm_Activate() EnableWindow FindWindowA(""XLMAIN"", Application.Caption), 1 End Sub Private Sub UserForm_Initialize() Dim hWnd As Long hWnd = FindWindowA(vbNullString, Me.Caption) SetWindowLongA hWnd, -16, GetWindowLongA(hWnd, -16) Or &H20000 End Sub" Userforma alt sİmge durumunu kÜÇÜltme ve ekrani kapla butonu ekler "Private Declare Function FindWindowA Lib ""User32"" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function EnableWindow Lib ""User32"" _ (ByVal hWnd As Long, ByVal bEnable As Long) As Long Private Declare Function GetWindowLongA Lib ""User32"" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLongA Lib ""User32"" _ (ByVal hWnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Sub UserForm_Activate() EnableWindow FindWindowA(""XLMAIN"", Application.Caption), 1 End Sub Private Sub UserForm_Initialize() Dim hWnd As Long hWnd = FindWindowA(vbNullString, Me.Caption) SetWindowLongA hWnd, -16, GetWindowLongA(hWnd, -16) Or &H20000 End Sub" Userforma farklı kaydet tuşu eklemek "Userformunuza atayacağınız bir command button'a yazacağınız; Kod: Dim iChartType As Long Private Sub UserForm_Activate() 'Initialise the selections cb3D = True obColumn = True obBitmap = True End Sub Private Sub btnOK_Click() Unload Me End Sub Private Sub cb3D_Click() Select Case True Case obColumn obColumn_Click Case obLine obLine_Click Case obArea obArea_Click End Select End Sub Private Sub obColumn_Click() iChartType = IIf(cb3D, xl3DColumn, xlColumnClustered) UpdateChart End Sub Private Sub obLine_Click() iChartType = IIf(cb3D, xl3DLine, xlLine) UpdateChart End Sub Private Sub obArea_Click() iChartType = IIf(cb3D, xl3DArea, xlArea) UpdateChart End Sub Private Sub obBitmap_Click() UpdateChart End Sub Private Sub obMetafile_Click() UpdateChart End Sub Private Sub UpdateChart() Dim oCht As Chart, lPicType As Long 'Find the chart object on the sheet Set oCht = Sheet1.ChartObjects(1).Chart 'Recalculate the sheet to give us a new set of random points Sheet1.Calculate 'Do we want a metafile or a bitmap? 'If doing a 1 to 1 copy, xlBitmap will give a 'truer' rendition. 'If scaling the image, xlPicture will give better results lPicType = IIf(obMetafile, xlPicture, xlBitmap) 'Update the chart type and copy it to the clipboard, as seen on screen With oCht .ChartType = iChartType .CopyPicture xlScreen, lPicType, xlScreen End With 'Paste the picture from the clipboard into our image control Set imgChtPic.Picture = PastePicture(lPicType) End Sub Private Sub btnSave_Click() Dim vFile As Variant, sFilter As String, lPicType As Long, oPic As IPictureDisp 'Create an appropriate filter, based on the bitmap/picture option in the dialog sFilter = IIf(obMetafile, ""Windows Metafile (*.emf),*.emf"", ""Windows Bitmap (*.bmp),*.bmp"") 'Get the filename to save the bitmap to vFile = Application.GetSaveAsFilename(initialfilename:="""", filefilter:=sFilter) If vFile <> False Then 'Get the type of bitmap lPicType = IIf(obMetafile, xlPicture, xlBitmap) 'Copy a picture on the chart with the correct format to the clipboard Sheet1.ChartObjects(1).Chart.CopyPicture xlScreen, lPicType, xlScreen 'Retrieve the picture from the clipboard Set oPic = PastePicture(lPicType) ' and save it to the file SavePicture oPic, vFile End If End Sub " Userforma farkli kaydet tuŞu "Userformunuza atayacağınız bir command button'a yazacağınız; Kod: Dim iChartType As Long Private Sub UserForm_Activate() 'Initialise the selections cb3D = True obColumn = True obBitmap = True End Sub Private Sub btnOK_Click() Unload Me End Sub Private Sub cb3D_Click() Select Case True Case obColumn obColumn_Click Case obLine obLine_Click Case obArea obArea_Click End Select End Sub Private Sub obColumn_Click() iChartType = IIf(cb3D, xl3DColumn, xlColumnClustered) UpdateChart End Sub Private Sub obLine_Click() iChartType = IIf(cb3D, xl3DLine, xlLine) UpdateChart End Sub Private Sub obArea_Click() iChartType = IIf(cb3D, xl3DArea, xlArea) UpdateChart End Sub Private Sub obBitmap_Click() UpdateChart End Sub Private Sub obMetafile_Click() UpdateChart End Sub Private Sub UpdateChart() Dim oCht As Chart, lPicType As Long 'Find the chart object on the sheet Set oCht = Sheet1.ChartObjects(1).Chart 'Recalculate the sheet to give us a new set of random points Sheet1.Calculate 'Do we want a metafile or a bitmap? 'If doing a 1 to 1 copy, xlBitmap will give a 'truer' rendition. 'If scaling the image, xlPicture will give better results lPicType = IIf(obMetafile, xlPicture, xlBitmap) 'Update the chart type and copy it to the clipboard, as seen on screen With oCht .ChartType = iChartType .CopyPicture xlScreen, lPicType, xlScreen End With 'Paste the picture from the clipboard into our image control Set imgChtPic.Picture = PastePicture(lPicType) End Sub Private Sub btnSave_Click() Dim vFile As Variant, sFilter As String, lPicType As Long, oPic As IPictureDisp 'Create an appropriate filter, based on the bitmap/picture option in the dialog sFilter = IIf(obMetafile, ""Windows Metafile (*.emf),*.emf"", ""Windows Bitmap (*.bmp),*.bmp"") 'Get the filename to save the bitmap to vFile = Application.GetSaveAsFilename(initialfilename:="""", filefilter:=sFilter) If vFile <> False Then 'Get the type of bitmap lPicType = IIf(obMetafile, xlPicture, xlBitmap) 'Copy a picture on the chart with the correct format to the clipboard Sheet1.ChartObjects(1).Chart.CopyPicture xlScreen, lPicType, xlScreen 'Retrieve the picture from the clipboard Set oPic = PastePicture(lPicType) ' and save it to the file SavePicture oPic, vFile End If End Sub " Userforma kalan sÜre yazdir "Private Sub Worksheet_Activate() bitis = 65000 baslangic = Now() For n = 2 To bitis Cells(n, 1).Value = n Cells(1, 1).Value = ""İşleminiz yapılıyor. %"" & Int(n * 100 / bitis) & "" Tamamlandı !"" Next Cells(1, 1).Value = ""İşleminiz yapıldı. "" & Int(((Now() - baslangic) * 24 * 60 * 60)) & "" sn.de Tamamlandı !"" End Sub" Userforma x ya basınca mesaj gelir kapatmaz "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then MsgBox ""Diese UserForm kann nur über den Button 'Beenden' geschlossen werden!"", vbOKOnly, ""Schliessen der UserForm erfolglos !!!"" Cancel = True End If End Sub" Userformda aktİf sayfa adi "Private Sub UserForm_Initialize() TextBox1.Value = ActiveSheet.Name Label1.Caption = ActiveSheet.Name End Sub Diğer nesneleride aynen uygulanabilir. Private Sub UserForm_Click() MsgBox ActiveSheet.Name End Sub " Userform'da çalışan saat-takvimle birlikte "Private Sub UserForm_Activate() Do Label1.Caption = Format(Now, ""dd.mm.yyyy - hh:mm:ss"") DoEvents Loop End Sub Private Sub UserForm_DeActivate() UserForm_Activate False End Sub" Userform'da ÇaliŞan saat-takvİmle "Kod: Private Sub UserForm_Activate() Do Label1.Caption = Format(Now, ""dd.mm.yyyy - hh:mm:ss"") DoEvents Loop End Sub Private Sub UserForm_DeActivate() UserForm_Activate False End Sub " Userformda hareketlİ gİf "Private Sub UserForm_Initialize() WebBrowser1.Navigate ""C:\Documents and Settings\xp\Belgelerim\Resimlerim\Resimlerim\Hareketli_resimler\0kop1.gif"" WebBrowser2.Navigate ""http://www.excel.web.tr/images/smiles/icon_hihoho.gif"" End Sub" Userform'da iskonto " Private Sub TextBox7_Exit(ByVal Cancel As MSForms.ReturnBoolean) TextBox7 = Format(TextBox7.Value, ""#,##0.00"") If IsNumeric(TextBox7) And IsNumeric(TextBox6) Then If TextBox11 <> """" Then TextBox8 = (CCur(TextBox7) - CCur(TextBox7) * CCur(TextBox11) / 100) * CCur(TextBox6) Exit Sub End If TextBox8 = CCur(TextBox7) * CCur(TextBox6) End If End Sub" Userform'da kapat butonu "Private Sub CommandButton1_Click() Application.ScreenUpdating = False Unload Me ThisWorkbook.Save ThisWorkbook.Close End Sub " Userformda resim önzileme "UserForm'a 1 adet Image ve 1 adet ComboBox ekleyip aşağıdaki kodları kopyalayıp yapıştırın. Resim seçmek için ComboBox'a çift tıklayıp çoklu seçim yapmanız ve Aç'a tıklamak yeterlidir. ComboBox'tan seçilen resim Image'de görünür. Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim FD As FileDialog Dim FFs As FileDialogFilters Dim stFileName As String Dim vaItem On Error GoTo Problem Set FD = Application.FileDialog(msoFileDialogOpen) With FD Set FFs = .Filters With FFs .Clear .Add ""Pictures"", ""*.jpg"" End With .AllowMultiSelect = True If .Show = False Then Exit Sub ComboBox1.Clear For Each vaItem In .SelectedItems ComboBox1.AddItem vaItem Next vaItem ComboBox1.ListIndex = 0 End With Exit Sub Problem: MsgBox ""Geçerli bir resim dosyası değil."" End Sub Private Sub ComboBox1_Change() Image1.Picture = LoadPicture(ComboBox1.Text) End Sub " Userformda resİm Önzİleme "UserForm'a 1 adet Image ve 1 adet ComboBox ekleyip aşağıdaki kodları kopyalayıp yapıştırın. Resim seçmek için ComboBox'a çift tıklayıp çoklu seçim yapmanız ve Aç'a tıklamak yeterlidir. ComboBox'tan seçilen resim Image'de görünür. Kod: Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim FD As FileDialog Dim FFs As FileDialogFilters Dim stFileName As String Dim vaItem On Error GoTo Problem Set FD = Application.FileDialog(msoFileDialogOpen) With FD Set FFs = .Filters With FFs .Clear .Add ""Pictures"", ""*.jpg"" End With .AllowMultiSelect = True If .Show = False Then Exit Sub ComboBox1.Clear For Each vaItem In .SelectedItems ComboBox1.AddItem vaItem Next vaItem ComboBox1.ListIndex = 0 End With Exit Sub Problem: MsgBox ""Geçerli bir resim dosyası değil."" End Sub Private Sub ComboBox1_Change() Image1.Picture = LoadPicture(ComboBox1.Text) End Sub " Userformda saat "Private Sub UserForm_Activate() SAAT.Caption = Format(Time, ""hh:mm:ss"") End Sub" Userformda saat "Sub saat() UserForm1.Label1 = Format(Now(), ""dd/mm/yyyy - hh:mm"") zaman = TimeValue(DateAdd(""s"", 60 - Second(Now()), Now())) Application.OnTime zaman, ""saat"", , True End Sub Private Sub UserForm_Activate() Module1.saat End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Application.OnTime zaman, ""saat"", , False End Sub" Userformda saat, işlemci yormaması için 1dk bir kendini yeniler "Module Global zaman Sub saat() UserForm1.Label1 = Format(Now(), ""dd/mm/yyyy - hh:mm"") zaman = TimeValue(DateAdd(""s"", 60 - Second(Now()), Now())) Application.OnTime zaman, ""saat"", , True End Sub 'Userform kısmına Private Sub UserForm_Activate() Module1.saat End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Application.OnTime zaman, ""saat"", , False End Sub" Userformda takvim "Userformun ilk açılışda takvimin bugünkü ayı göstermesi için Private Sub UserForm_Initialize() Calendar1.Year = Year(Now) Calendar1.Month = Month(Now) End Sub 'bir önceki ayı gösterecek commandbutton için; Private Sub CommandButton1_Click() If Month(Now) = 1 Then Calendar1.Year = Year(Now) - 1 Calendar1.Month = Month(Now) + 11 Exit Sub End If Calendar1.Year = Year(Now) Calendar1.Month = Month(Now) - 1 End Sub 'Şimdiye geri dönecek commandbutton için; Private Sub CommandButton2_Click() Calendar1.Year = Year(Now) Calendar1.Month = Month(Now) End Sub 'Bir sonraki ayı gösterecek commandbutton için; Private Sub CommandButton3_Click() If Month(Now) = 12 Then Calendar1.Year = Year(Now) + 1 Calendar1.Month = Month(Now) - 11 Exit Sub End If Calendar1.Year = Year(Now) Calendar1.Month = Month(Now) + 1 End Sub" Userformda tarİh "combo1 de yıllar combo2 de aylar (1,2, 12) 31 tanede textbox oldugunu varsaydim. Kod: Private Sub ComboBox2_Change() If ComboBox2 = 12 Then x = DateDiff(""d"", ""1"" & ""."" & ComboBox2 & ""."" & ComboBox1, ""1"" & ""."" & ""1"" & ""."" & ComboBox1 + 1) Else x = DateDiff(""d"", ""1"" & ""."" & ComboBox2 & ""."" & ComboBox1, ""1"" & ""."" & ComboBox2 + 1 & ""."" & ComboBox1) End If z = 1 Dim ctrl As Control For Each ctrl In UserForm1.Controls If TypeName(ctrl) = ""TextBox"" Then ctrl.Text = """" End If Next ctrl For Each ctrl In UserForm1.Controls If TypeName(ctrl) = ""TextBox"" Then ctrl.Text = z If z = x Then Exit For z = z + 1 End If Next ctrl End Sub " Userformda toplama "Private Sub CommandButton1_Click() TextBox1 = Val(TextBox2.Value) + Val(TextBox3.Value) End Sub" Userformda x basınca çalışma kitabından çıkma "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Workbooks(""nomduclasseur.xls"").Close False End Sub" Userformda x işareti yok "Private Const WS_CAPTION As Long = &HC00000 Private Const WS_SYSMENU As Long = &H80000 Private Const WS_THICKFRAME As Long = &H40000 Private Const WS_MINIMIZEBOX As Long = &H20000 Private Const WS_MAXIMIZEBOX As Long = &H10000 Private Const WS_POPUP As Long = &H80000000 Private Const WS_VISIBLE As Long = &H10000000 Private Const WS_EX_DLGMODALFRAME As Long = &H1 Private Const WS_EX_APPWINDOW As Long = &H40000 Private Const WS_EX_TOOLWINDOW As Long = &H80 Private Declare Function FindWindow Lib ""user32"" _ Alias ""FindWindowA"" ( _ ByVal ClassName As String, _ ByVal WindowName As String) As Long Private Declare Function GetWindowLong Lib ""user32"" _ Alias ""GetWindowLongA"" ( _ ByVal hWnd As Long, _ ByVal Index As Long) As Long Private Declare Function SetWindowLong Lib ""user32"" _ Alias ""SetWindowLongA"" ( _ ByVal hWnd As Long, _ ByVal Index As Long, _ ByVal NewLong As Long) As Long Const GWL_STYLE = -16 Private Sub UserForm_Initialize() Dim hWnd As Long Dim Style As Long If Val(Application.Version) >= 9 Then hWnd = FindWindow(""ThunderDFrame"", Me.Caption) Else hWnd = FindWindow(""ThunderXFrame"", Me.Caption) End If Style = GetWindowLong(hWnd, GWL_STYLE) Style = (Style And Not WS_SYSMENU) SetWindowLong hWnd, GWL_STYLE, Style End Sub" Userformdaki checkboxları sıfırlamak "Sub ResetAllCheckBoxesInUserForm() Dim ctrl As Control For Each ctrl In UserForm1.Controls If TypeName(ctrl) = ""CheckBox"" Then ctrl.Value = False End If Next ctrl End Sub" Userformdaki commandbotton'a bul eklemek "sub dosyabul() dim a as string a = application.findfile msgbox a end sub " Userformdaki optionbuttonları sıfırlamak "Sub ResetAllOptionButtonsInUserForm() Dim ctrl As Control For Each ctrl In UserForm1.Controls If TypeName(ctrl) = ""OptionButton"" Then ctrl.Value = False End If Next ctrl End Sub" Userformdaki textboxları sıfırlamak "Sub ResetAllTextBoxesInUserForm() Dim ctrl As Control For Each ctrl In UserForm1.Controls If TypeName(ctrl) = ""TextBox"" Then ctrl.Text = """" End If Next ctrl End Sub" Userformdan hücreye "Private Sub TextBox1_Change() [a2] = TextBox1.Text End Sub" Userformdan önizleme kapanınca forma dönme "Private Sub CommandButton1_Click() UserForm1.Hide Worksheets(""sayfa1"").PrintPreview Worksheets(""sayfa1"").PageSetup.PrintArea = """" Application.Visible = False UserForm1.Show End Sub" Userform'dan sayfaya bİlgİ gİrİŞİ "UserForm kod modulüne: Kod: Private Sub CommandButton1_Click() Sheets(""Sayfa1"").Range(""B"" & ComboBox1.ListIndex + 2) = TextBox1 End Sub " Userformdan userforma "C:\Den altında A ve B xls dosyalarım var. A userform1 de 5 tane commandbutton var B de de 5 tane userform var. Yapmak istediğim şu; A.xls Userform1 deki Commandbutton1 e tıklandığında B.xls deki userform1 açılsın Commandbutton2 e tıklandığında B.xls deki userform2 açılsın Commandbutton3 e tıklandığında B.xls deki userform3 açılsın Commandbutton4 e tıklandığında B.xls deki userform4 açılsın Commandbutton5 e tıklandığında B.xls deki userform5 açılsın ' Merhaba her iki dosyanın açık olması koşulu ile; Aşağıdaki kodu B.xls de bir Modüle yazın. Kod: Sub ac() UserForm1.Show End Sub Aşağıdaki koduda Butonunuzun olduğu sayfanın Kod bölümüne yazınız. Kod: Private Sub CommandButton1_Click() Application.Run ""B.xls!ac"" End Sub " Userformdan x ile çıkma geçersiz uyarı mesajı "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then MsgBox ""UserForm kann nur mit Klick auf 'Beenden' geschlossen werden !"" Cancel = True End If End Sub" Userformdan x ile excel çıkış "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Application.ScreenUpdating = False Workbooks(""Combo örnekleri.xls"").Close True End Sub" Userformsuz combobox tryit e makro yolu verin "Option Base 1 Option Explicit Dim EB As Object, LB As Object Dim vaList As Variant Dim oldText As String Sub TryIt() Sheets(""Dialog1"").Show End Sub Sub SetEditBox() With ActiveDialog Set EB = .EditBoxes(1) Set LB = .ListBoxes(1) .Focus = EB.Name End With EB.Text = """" LB.ListIndex = 0 vaList = LB.List End Sub Sub EditBoxAction() Dim i As Variant Dim ebText As String, lbText As String Dim iNums As Integer Static fSendKeys As Boolean If fSendKeys = True Then fSendKeys = False Exit Sub End If fSendKeys = False ebText = EB.Text If ebText = """" Then LB.ListIndex = 0 Else i = Application.Match(ebText & ""*"", vaList, 0) If IsError(i) = False Then LB.ListIndex = i lbText = LB.List(i) If Len(ebText) > Len(oldText) Or Left(ebText, Len(oldText)) <> ebText Then iNums = Len(lbText) - Len(ebText) If iNums > 0 Then SendKeys Right(lbText, iNums) & ""+{LEFT "" & iNums & ""}"" fSendKeys = True End If End If Else LB.ListIndex = 0 End If End If oldText = ebText End Sub Sub ListBoxAction() With LB EB.Text = LB.List(LB.ListIndex) End With oldText = EB.Text ActiveDialog.Focus = ""ebMonth"" SendKeys ""{RIGHT}"" End Sub" Userformsuz diyalog kutusu "Option Base 1 Option Explicit '* Declare Windows API calls and data types - 16 Bit for Windows 3.x * 'Define a variable type to store the window coordinates Type typRect16 Left As Integer Top As Integer Right As Integer Bottom As Integer End Type 'Get the dimensions of the screen Declare Function GetSystemMetrics16 Lib ""User"" Alias ""GetSystemMetrics"" (ByVal nIndex As Integer) As Integer 'Get the handle for a window Declare Function FindWindow16 Lib ""User"" Alias ""FindWindow"" (ByVal szClass$, ByVal szTitle$) As Integer 'Get the dimensions of the window Declare Sub GetWindowRect16 Lib ""User"" Alias ""GetWindowRect"" (ByVal hWnd As Integer, lpRect As typRect16) 'Set the dimensions of the window Declare Sub Movewindow16 Lib ""User"" Alias ""Movewindow"" (ByVal hWnd As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal bRepaint As Integer) '* Declare Windows API calls and data types - 32 bit for Windows 95 and NT * 'Define a variable type to store the window coordinates Type typRect32 Left As Long Top As Long Right As Long Bottom As Long End Type 'Get the dimensions of the screen Declare Function GetSystemMetrics32 Lib ""user32"" Alias ""GetSystemMetrics"" (ByVal nIndex As Long) As Long 'Get the handle for a window Declare Function FindWindow32 Lib ""user32"" Alias ""FindWindowA"" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 'Get the dimensions of the window Declare Function GetWindowRect32 Lib ""user32"" Alias ""GetWindowRect"" (ByVal hWnd As Long, lpRect As typRect32) As Long 'Set the dimensions of the window Declare Function Movewindow32 Lib ""user32"" Alias ""MoveWindow"" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long Sub CentreDialog() If InStr(1, Application.OperatingSystem, ""32"") = 0 Then CentreDialog16 Else CentreDialog32 End If End Sub Sub CentreDialog16() On Error Resume Next '*** DIMENSION VARIABLES *** Dim tRect As typRect16 'Variables to retrieve the screen dimensions with GetSystemMetrics API. Dim iScreenWidth As Integer Dim iScreenHeight As Integer 'Variable to store the window handle with FindWindow API. Dim ihWnd As Integer 'Variables to calculate the new dimensions for the window. Dim iWidth As Integer Dim iHeight As Integer Dim iLeft As Integer Dim iTop As Integer 'Get the handle of the dialog box window - 'bosa_sdm_XL' is the class name 'for an Excel 5 dialog box. ihWnd = FindWindow16(""bosa_sdm_XL"", ActiveDialog.DialogFrame.Text) 'Only continue if a valid handle is returned If ihWnd <> 0 Then 'Get the width and height of the screen in pixels iScreenWidth = GetSystemMetrics16(0) iScreenHeight = GetSystemMetrics16(1) 'Get the dimensions of the dialog box window in pixels GetWindowRect16 ihWnd, tRect 'Calculate the width and height of the dialog box iWidth = Abs(tRect.Right - tRect.Left) iHeight = Abs(tRect.Top - tRect.Bottom) 'Calculate the new position of the dialog box in pixels iLeft = (iScreenWidth - iWidth) / 2 iTop = (iScreenHeight - iHeight) / 2 'Move the dialog box to the centre of the screen Movewindow16 ihWnd, iLeft, iTop, iWidth, iHeight, True End If End Sub Sub CentreDialog32() On Error Resume Next '*** DIMENSION VARIABLES *** Dim tRect As typRect32 'Variables to retrieve the screen dimensions with GetSystemMetrics API. Dim iScreenWidth As Long Dim iScreenHeight As Long 'Variable to store the window handle with FindWindow API. Dim ihWnd As Long 'Variables to calculate the new dimensions for the window. Dim iWidth As Long Dim iHeight As Long Dim iLeft As Long Dim iTop As Long 'Get the handle of the dialog box window - 'bosa_sdm_XL' is the class name 'for an Excel dialog box. ihWnd = FindWindow32(""bosa_sdm_XL"", ActiveDialog.DialogFrame.Text) 'If not found, it could be a later version of Excel, so try again If ihWnd = 0 Then ihWnd = FindWindow32(""bosa_sdm_XL8"", ActiveDialog.DialogFrame.Text) End If 'Only continue if a valid handle is returned If ihWnd <> 0 Then 'Get the width and height of the screen in pixels iScreenWidth = GetSystemMetrics32(0) iScreenHeight = GetSystemMetrics32(1) 'Get the dimensions of the dialog box window in pixels GetWindowRect32 ihWnd, tRect 'Calculate the width and height of the dialog box iWidth = Abs(tRect.Right - tRect.Left) iHeight = Abs(tRect.Top - tRect.Bottom) 'Calculate the new position of the dialog box in pixels iLeft = (iScreenWidth - iWidth) / 2 iTop = (iScreenHeight - iHeight) / 2 'Move the dialog box to the centre of the screen Movewindow32 ihWnd, iLeft, iTop, iWidth, iHeight, True End If End Sub Sub ShowDialog() ThisWorkbook.DialogSheets(""Dialog1"").Show End Sub" Userformsuz form menü sayfa seçme "Option Explicit Dim dlg As DialogSheet ' global variable Sub SheetNavigation() Dim ws As Worksheet Application.ScreenUpdating = False Set dlg = ActiveWorkbook.DialogSheets.Add With dlg.DialogFrame .Left = 0 .Top = 0 .Height = 300 ' dialog height .Width = 300 ' dialog width End With dlg.Buttons(1).Left = 245 ' position of button1 dlg.Buttons(2).Left = 245 ' position of button2 With dlg.ListBoxes.Add(10, 15, 230, 275) ' size of listbox For Each ws In ActiveWorkbook.Worksheets If ws.Visible Then .AddItem ws.Name Next ws .ListIndex = 0 .OnAction = ""DisplaySheet"" End With dlg.DialogFrame.Text = ""Select the worksheet you want to activate"" dlg.Visible = False Application.ScreenUpdating = True If dlg.Show Then Worksheets(dlg.ListBoxes(1).List(dlg.ListBoxes(1).ListIndex)).Activate End If Application.DisplayAlerts = False dlg.Delete Application.DisplayAlerts = True Set ws = Nothing Set dlg = Nothing End Sub Private Sub DisplaySheet() Sheets(dlg.ListBoxes(1).List(dlg.ListBoxes(1).ListIndex)).Activate End Sub" Userformu alt+f4 ile kapatmak yasak "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then MsgBox ""Bitte mit dem Button 'Beenden' schließen!"", vbOKOnly, ""Websuche bei kmbuss.de"" Cancel = True End If End Sub" Userformu daraltma "Private Sub cmdStopAlarm_Click() Me.Height = 55 End Sub 'Userformu açma (daraltılanı) Private Sub cmdStopAlarm_Click() Me.Height = 185 End Sub" Userformu kilitlemek 1 "Private Sub UserForm_Activate() If InputBox(""şifreyi giriniz"") <> ""pir"" Then MsgBox (""Şifreyi bilemediniz.Bilgiler üzerinde degişiklik yapamazsınız ..!"") TextBox1.Locked = True End If End Sub" Userformu kilitlemek 2 "Private Sub UserForm_Activate() If InputBox(""şifreyi giriniz"") <> ""pir"" Then MsgBox (""Şifreyi bilemediniz:Form Kapatılacak..!"") Unload Me End If End Sub" Userformu kilitlemek 3 "Private Sub UserForm_Activate() ' Forma şifre koyma (şifre bilgisayarın saati) örnek (10:02) If InputBox(""şifreyi giriniz"") <> Mid(Time, 1, 5) Then MsgBox (""şifreyi bilemediniz.bilgiler üzerinde degişiklik yapamazsınız."") Text1.Locked = True End If End Sub" Userformu maksİmİze yapmak İÇİn "Private Sub UserForm_Activate() Application.WindowState = xlMaximized Me.Left = Application.Width - Me.Width Me.Top = 0 End Sub" Userformu otomatİk boyutlandirma "Private Sub UserForm_Initialize() With Application .WindowState = xlMaximized Zoom = Int(.Width / Me.Width * 100) Width = .Width Height = .Height End With End Sub Fullscren ile ama bu seferde userin üzerindeki nesneler farklılık gösterecek.Çözümü yok.VB Kullanırsan olur.. Bu kodları kod sayfanın en başına yazarsan 3 Düğme oluşur.Kullanıcı istediği gibi büyütür küçültür. Kod: Private Declare Function FindWindow Lib ""user32"" Alias ""FindWindowA"" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib ""user32"" Alias ""GetWindowLongA"" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib ""user32"" Alias ""SetWindowLongA"" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function ShowWindow Lib ""user32"" _ (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function DrawMenuBar Lib ""user32"" (ByVal hwnd As Long) As Long ' Private Sub UserForm_Activate() Dim hWndForm As Long, frmStyle As Long hWndForm = FindWindow(vbNullString, Me.Caption) frmStyle = GetWindowLong(hWndForm, (-16)) frmStyle = frmStyle Or &H80000 Or &H20000 Or &H10000 SetWindowLong hWndForm, (-16), frmStyle ShowWindow hWndForm, 5 DrawMenuBar hWndForm End Sub Ayrı bir kod ise Userformun açılışında tam ekran olarak gelmesi. Kod: Private Sub UserForm_Initialize() With Application Me.Top = .Top Me.Left = .Left Me.Height = .Height Me.Width = .Width End With End Sub " Userformu tam ekran yapan kodlar "Private Sub UserForm_Initialize() With UserForm1 .Height = Application.Height .Width = Application.Width End With End Sub" Userformu tam ekran yapan kodlar "Private Sub UserForm_Initialize() With UserForm1 .Height = Application.Height .Width = Application.Width End With End Sub" Userformu tam ekran yapan kodlar 2 "Private Sub UserForm_Initialize() UserForm1.Height = Application.Height UserForm1.Width = Application.Width End Sub" Userform'un açılış sayısını sınırlamak (demo yapmak) "1 adet UserForm '1 adet Label 'Aşağıdaki kodları UserForm'un kod bölümüne yapıştırınız. Dim webtr Private Sub UserForm_Activate() webtr = GetSetting(""sınır"", ""sınırla"", ""webtr"", 0) If webtr >= 5 Then 'burdaki 5 rakamı userformun kaç kere açılacağını belirtiyor. SaveSetting ""sınır"", ""sınırla"", ""webtr"", 111111 MsgBox ""Üzgünüm UserForm 5 kere açılmış."" & Chr(10) _ & ""Aslanım herşeyin fazlası HARAM"", vbOKOnly, ""Uyarı"" Unload Me End Else webtr = webtr + 1 SaveSetting ""sınır"", ""sınırla"", ""webtr"", webtr Label1.Caption = webtr & "" oldu."" End If End Sub" Userformun başındaki kapat butonunu pasif yapar (çarpıya basınca userform kapanmaz) "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then Cancel = True End Sub" Userformun baŞindakİ kapat butonunu pasİf yapar (Çarpiya basinca userform kapanmaz) "Açıklama: UserFormun başındaki kapat butonunu pasif yapar (çarpıya basınca userform kapanmaz) Kod: Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then Cancel = True End Sub Bu da UserFormun çarpı işaretine tıklayınca Mesaj kutusuyla uyarı veriyor Kod: Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then MsgBox ""çarpıdan kapatmak yasaktır!"" Cancel = True End If End Sub " Userformun code bÖlÜmÜne yapiŞtir,textbox'lari ÇoĞaltabİlİrsİn "Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0: MsgBox "" Harf girilmeyecek,Sadece Rakam Giriniz .."" End Sub " Userformun çarpı işaretine tıklayınca mesaj kutusuyla uyarı veriyor "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then MsgBox ""çarpıdan kapatmak yasaktır!"" Cancel = True 'Bu satır MsgBox tan önce de yazabilirsiniz End If End Sub" Userformun esc ile kapanması, butonla da "Private Sub CommandButton2_Click() Unload Me End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode <> 1 Then Cancel = True End Sub Private Sub UserForm_Initialize() CommandButton2.Cancel = True End Sub" Userformun esc ile kapatılması "Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 27 Then Unload Me End Sub" Userformun genişliği zaman ayarlı "Userformdaki optionbuttona aşağıdaki kodları Private Sub OptionButton1_Click() Me.Height = 153 zaman = Now + TimeValue(""00:00:05"") Application.OnTime zaman, ""boyut"" End Sub 'Bir module de aşağıdaki kodları yazın Sub boyut() UserForm4.Width = 320 End Sub " Userformun kapandığı haliyle açılması "Private Sub UserForm_Initialize() TextBox1.Value = Range(""A1"").Value TextBox2.Value = Range(""A2"").Value TextBox3.Value = Range(""A3"").Value End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Range(""A1"").Value = TextBox1.Value Range(""A2"").Value = TextBox2.Value Range(""A3"").Value = TextBox3.Value End Sub " Userformun kod bölümüne "Private Declare Function FindWindow Lib ""user32"" Alias _ ""FindWindowA"" (ByVal lpClassName As String, ByVal _ lpWindowName As String) As Long Private Declare Function GetWindowLong Lib ""user32"" Alias _ ""GetWindowLongA"" (ByVal hWnd As Long, ByVal nIndex _ As Long) As Long Private Declare Function SetWindowLong Lib ""user32"" Alias _ ""SetWindowLongA"" (ByVal hWnd As Long, ByVal nIndex _ As Long, ByVal dwNewLong As Long) As Long Private Declare Function SendMessage Lib ""user32"" Alias _ ""SendMessageA"" (ByVal hWnd As Long, ByVal wMsg As Long, _ ByVal wParam As Integer, ByVal lParam As Long) As Long Private Declare Function DrawMenuBar Lib ""user32"" (ByVal _ hWnd As Long) As Long Private wHandle As Long Private Sub UserForm_Initialize() On Error Resume Next Me.Caption = ""pir"" Image1.Visible = False If Val(Application.Version) >= 9 Then wHandle = FindWindow(""ThunderDFrame"", Me.Caption) Else wHandle = FindWindow(""ThunderXFrame"", Me.Caption) End If If wHandle = 0 Then Exit Sub hIcon = Image1.Picture SendMessage wHandle, &H80, True, hIcon SendMessage wHandle, &H80, False, hIcon frm = GetWindowLong(wHandle, -20) frm = frm And Not &H1 SetWindowLong wHandle, -20, frm DrawMenuBar wHandle End Sub" Userformun pasif olması UserForm'un Properties lerinden ShowModal kısmını False yaparsanız UserForm aktif iken hücrelerde gezebilirsiniz Userformun Üst saĞdakİ kapat butonunu gİzler "Private Declare Function GetWindowLongA Lib ""User32"" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLongA Lib ""User32"" _ (ByVal hwnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function FindWindowA Lib ""User32"" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Sub UserForm_Initialize() Dim hwnd As Long hwnd = FindWindowA(""Thunder"" & IIf(Application.Version Like ""8*"", _ ""X"", ""D"") & ""Frame"", Me.Caption) SetWindowLongA hwnd, -16, GetWindowLongA(hwnd, -16) And &HFFF7FFFF End Sub" Userformun üst sağdaki kapat butonunu gizler "Private Declare Function GetWindowLongA Lib ""User32"" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLongA Lib ""User32"" _ (ByVal hwnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function FindWindowA Lib ""User32"" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Sub UserForm_Initialize() Dim hwnd As Long hwnd = FindWindowA(""Thunder"" & IIf(Application.Version Like ""8*"", _ ""X"", ""D"") & ""Frame"", Me.Caption) SetWindowLongA hwnd, -16, GetWindowLongA(hwnd, -16) And &HFFF7FFFF End Sub" Userformun Üzerİnde 3 adet text box var ve textbox1 deĞerİmİz 2. Ve 3.NÜn toplmi olsun İstİyoruz "Private Sub CommandButton1_Click() TextBox1 = Val(TextBox2.Value) + Val(TextBox3.Value) End Sub " Userform'un yerİ. "maximize yapmak içinde Kod: Private Sub UserForm_Activate() Application.WindowState = xlMaximized Me.Left = Application.Width - Me.Width Me.Top = 0 End Sub " Userformunuza ekleyeceğiniz bir adet combobox'a ayları yazar "Private Sub UserForm_Initialize() Dim i% Dim TMP$ ComboBox1.Clear For i = 1 To 12 TMP = Format(DateSerial(2004, i, 1), ""mmmm"") ComboBox1.AddItem TMP Next i ComboBox1.ListIndex = 0 End Sub" Userformunuza ekleyeceĞİnİz bİr adet combobox'a aylari yazar "Private Sub UserForm_Initialize() Dim i% Dim TMP$ ComboBox1.Clear For i = 1 To 12 TMP = Format(DateSerial(2004, i, 1), ""mmmm"") ComboBox1.AddItem TMP Next i ComboBox1.ListIndex = 0 End Sub" Userformunuzdadakİ texbox'a yazdiĞiniz verİler ayni anda excel ÇaliŞma sayfanizdakİ a2 hÜcresİne yazdirilir "Private Sub TextBox1_Change() [a2] = TextBox1.Text End Sub" Userformunuzu yazdırmak "Private Sub CommandButton1_Click() UserForm1.PrintForm End Sub" Userformunuzu yazdirmak "Gerekli olanlar 1 adet userform üzerine commanbutton, Commandbutton'a yazacağınız kod: Kod: Private Sub CommandButton1_Click() UserForm1.PrintForm End Sub " Userformunuzun başlığı '+' şeklinde "Private Declare Function FindWindow Lib ""user32"" Alias _ ""FindWindowA"" (ByVal lpClassName As String, ByVal _ lpWindowName As String) As Long Private Declare Function GetWindowLong Lib ""user32"" Alias _ ""GetWindowLongA"" (ByVal hWnd As Long, ByVal nIndex _ As Long) As Long Private Declare Function SetWindowLong Lib ""user32"" Alias _ ""SetWindowLongA"" (ByVal hWnd As Long, ByVal nIndex _ As Long, ByVal dwNewLong As Long) As Long Private Declare Function SendMessage Lib ""user32"" Alias _ ""SendMessageA"" (ByVal hWnd As Long, ByVal wMsg As Long, _ ByVal wParam As Integer, ByVal lParam As Long) As Long Private Declare Function DrawMenuBar Lib ""user32"" (ByVal _ hWnd As Long) As Long Private wHandle As Long Private Sub UserForm_Initialize() On Error Resume Next Me.Caption = ""pir"" Image1.Visible = False If Val(Application.Version) >= 9 Then wHandle = FindWindow(""ThunderDFrame"", Me.Caption) Else wHandle = FindWindow(""ThunderXFrame"", Me.Caption) End If If wHandle = 0 Then Exit Sub hIcon = Image1.Picture SendMessage wHandle, &H80, True, hIcon SendMessage wHandle, &H80, False, hIcon frm = GetWindowLong(wHandle, -20) frm = frm And Not &H1 SetWindowLong wHandle, -20, frm DrawMenuBar wHandle End Sub" Userformunuzun başlığını kodlarla istediğinizi şekilde ayarlayabilirsiniz "Private Sub UserForm_Initialize() UserForm1.Caption = ""pir"" End Sub" Userformunuzun baŞliĞi '+' Şeklİnde "Userformun code bölümüne; Private Declare Function FindWindow Lib ""user32"" Alias _ ""FindWindowA"" (ByVal lpClassName As String, ByVal _ lpWindowName As String) As Long Private Declare Function GetWindowLong Lib ""user32"" Alias _ ""GetWindowLongA"" (ByVal hWnd As Long, ByVal nIndex _ As Long) As Long Private Declare Function SetWindowLong Lib ""user32"" Alias _ ""SetWindowLongA"" (ByVal hWnd As Long, ByVal nIndex _ As Long, ByVal dwNewLong As Long) As Long Private Declare Function SendMessage Lib ""user32"" Alias _ ""SendMessageA"" (ByVal hWnd As Long, ByVal wMsg As Long, _ ByVal wParam As Integer, ByVal lParam As Long) As Long Private Declare Function DrawMenuBar Lib ""user32"" (ByVal _ hWnd As Long) As Long Private wHandle As Long Private Sub UserForm_Initialize() On Error Resume Next Me.Caption = ""www.excel.web.tr"" Image1.Visible = False If Val(Application.Version) >= 9 Then wHandle = FindWindow(""ThunderDFrame"", Me.Caption) Else wHandle = FindWindow(""ThunderXFrame"", Me.Caption) End If If wHandle = 0 Then Exit Sub hIcon = Image1.Picture SendMessage wHandle, &H80, True, hIcon SendMessage wHandle, &H80, False, hIcon frm = GetWindowLong(wHandle, -20) frm = frm And Not &H1 SetWindowLong wHandle, -20, frm DrawMenuBar wHandle End Sub" Userin baŞliĞi hareket eder "Sub HarfHarf(ref As UserForm1) baslik = ref.Caption ref.Caption = """" For i = 0 To Len(baslik) If i = 0 Then ref.Caption = """" current = Timer Do While Timer - current < 0.1 DoEvents Loop GoTo Son Else End If ref.Caption = Left(baslik, i) current = Timer Do While Timer - current < 0.01 DoEvents Loop Son: Next i End Sub Private Sub CommandButton1_Click() HarfHarf Me End Sub " Uyan Şartlara gÖre userform3'tekİ commandbutton gİzlensİn. "Bu CommandButton3 butonu UserForm6'daki mi?Yoksa UserForm3'de ayrı bir CommandButton3'mi Var. Eğer UserForm3'de ayrı bir CommandButton3 var ise; UserForm''ün Initialize olayına visual basic kodu: Private Sub UserForm_Initialize() CommandButton1.Visible = False End Sub Yazmanız gerek ..AKsi halde UserForm6 Unload Me ile kapanacağından dediğiniz (UserForm6 Üzerindeyse CommandButton3) yapamazsınız.(*) Prensip olarak .Visible =True ve False ile gizlemeleri yapabilirsiniz. Gizlemeyipte Aktif veya Aktif olmamasını isterseniz .Enabled =True veya False yazmanız gerek. Kolay Gelsin. " Uyarı mesajı (istediğin zaman, istediğin yerde) "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" Uyarı mesajı 4 x şeklinde uyarı penceresi "Sub auto_open() Beep MsgBox ""Mesaj Buraya!!"", vbCritical, ""Önemli"" End Sub" Uyarı mesajları 1 "Sub Dene() MsgBox ""aa"", 16, ""hata"" End Sub" Uyarı mesajları 2 "Sub Denee() MsgBox ""aa"", 64, ""hata"" End Sub" Uyarı mesajları 3 x şeklinde "Sub auto_open() Beep MsgBox ""Mesaj Buraya!!"", vbCritical, ""Önemli"" End Sub" Uyarılı mesaj---100 tane beep ten sonra mesaj "Sub Meldung() For i = 1 To 100 Beep Next i Meld = MsgBox(""Termin nicht vergessen!"", 0, ""A c h t u n g"") End Sub" Uyari kutucuĞu!! "Sayfa koruması olan hücreler seçildiğinde uyarı mesajı veren bir kod oluşturulabilir. Aşağıdaki kodu sayfanın kod sayfasına kopyalayarak deneyin. Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveCell.AllowEdit = False Then MsgBox ""BU HÜCRE KORUMA ALTINDADIR"" End Sub" Uygulama başlığı "Sub Title_Caption() Application.Caption = ""Mahmut_Bayram"" End Sub" Uygulama ve kitap başlığı ayarlama "sayfa kod bölümüne Option Explicit Public AppCap$ Public ActWinCap$ Private Sub Worksheet_Activate() Application.Caption = Worksheets(1).Range(""A1"").Value ActiveWindow.Caption = Worksheets(1).Range(""B1"").Value & "" / "" & _ Worksheets(1).Range(""C1"").Value & "" / "" & _ Worksheets(1).Range(""D1"").Value & "" / "" & _ Worksheets(1).Range(""E1"").Value End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.Caption = Worksheets(1).Range(""A1"").Value ActiveWindow.Caption = Worksheets(1).Range(""B1"").Value & "" / "" & _ Worksheets(1).Range(""C1"").Value & "" / "" & _ Worksheets(1).Range(""D1"").Value & "" / "" & _ Worksheets(1).Range(""E1"").Value End Sub 'ThisWorkbook a Option Explicit Public AppCap$ Public ActWinCap$ Private Sub Workbook_Activate() Application.Caption = Worksheets(1).Range(""A1"").Value ActiveWindow.Caption = Worksheets(1).Range(""B1"").Value & "" / "" & _ Worksheets(1).Range(""C1"").Value & "" / "" & _ Worksheets(1).Range(""D1"").Value & "" / "" & _ Worksheets(1).Range(""E1"").Value End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.Caption = AppCap ActiveWindow.Caption = ActWinCap End Sub Private Sub Workbook_Deactivate() Application.Caption = AppCap ActiveWindow.Caption = ActWinCap End Sub Private Sub Workbook_Open() Application.Caption = Worksheets(1).Range(""A1"").Value ActiveWindow.Caption = Worksheets(1).Range(""B1"").Value & "" / "" & _ Worksheets(1).Range(""C1"").Value & "" / "" & _ Worksheets(1).Range(""D1"").Value & "" / "" & _ Worksheets(1).Range(""E1"").Value End Sub" Var olan menü çubuğuna buton ekleme "Private Sub Workbook_Open() Dim cmb As CommandBar Set cmb = Application.CommandBars(""Standard"") With cmb.Controls.Add(Type:=msoControlButton, _ Temporary:=True) .Caption = ""Meine 1. Prozedur"" .BeginGroup = True .FaceId = 59 .OnAction = ""MeineProzedur1"" End With With cmb.Controls.Add(Type:=msoControlButton, _ Temporary:=True) .Caption = ""Meine 2. Prozedur"" .FaceId = 49 .OnAction = ""MeineProzedur2"" End With Set cmb = Nothing End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim cmb As CommandBar Set cmb = Application.CommandBars(""Standard"") With cmb .Controls(""Meine 1. Prozedur"").Delete .Controls(""Meine 2. Prozedur"").Delete End With Set cmb = Nothing End Sub Sub MeineProzedur1() MsgBox Application.UserName End Sub Sub MeineProzedur2() MsgBox Now() End Sub" Varolan kitabın içine kayıt "Sub test() GetValuesFromAClosedWorkbook ""C:"", ""Book1.xls"", _ ""Sheet1"", ""A1:K30"" End Sub Sub GetValuesFromAClosedWorkbook(fPath As String, _ fName As String, sName, cellRange As String) With ActiveSheet.Range(cellRange) .FormulaArray = ""='"" & fPath & ""\["" & fName & ""]"" _ & sName & ""'!"" & cellRange .Value = .Value End With End Sub" Varolan sayfaları a1 itibaren alt alta yazar "Sub GetSheets() Dim j As Integer Dim NumSheets As Integer NumSheets = Sheets.Count For j = 1 To NumSheets Cells(j, 1) = Sheets(j).Name Next j End Sub" VB kodlari ile bir excel dosyasi aciyorum fakat bu Excel dosyasindaki makroyu çalıştırma "Run işlem yapabilmesi için çalıştırmak istediğiniz makronun bulunduğu Excel dosyasını daha önceden açmış olmalısınız Sub ExcelMakrosunuCalistir() Dim xlApp As Object Set xlApp = CreateObject(""Excel.Application"") xlApp.Run (FormAc) End Sub" VB kodlari ile bir excel dosyasi aciyorum fakat bu Excel dosyasindaki makroyu çalıştırma2 Appication.Run(varsa argümanlar1, varsa argümanlar2) Vba da açalıştırırsan vba kitaplığını açar, sayfada kullanırsan 7 şer kolon atlar "Sub DatenUmwandeln() Dim MyRange As Range Dim Cell As Range Application.ScreenUpdating = False Set MyRange = ActiveCell.CurrentRegion.Columns(7) For Each Cell In MyRange Cell.Select Application.SendKeys ""{F2}+{ENTER}"", True Next Cell End Sub" Vba daki sırayı takip ederek sayfa isimlerini otomatik sıralar "Sub Auto_Open() Dim i As Integer Dim j As Integer If Worksheets.Count = 1 Then Exit Sub For i = 1 To Worksheets.Count - 1 For j = i + 1 To Worksheets.Count If Worksheets(j).Name < Worksheets(i).Name Then Worksheets(j).Move before:=Worksheets(i) End If Next j Next i End Sub" Vba kodlarını görme makrosu "Sub ViewCode() Application.Goto Reference:=""Makro1"" End Sub" Vba kodunu görmek için butonla Bu kodu bir butona atayınız: Application.GoTo Reference:="test" Vba penceresİnİn aÇilmasini ve kodlara ulaŞilmasini engelleyen ve aÇan kodlar "vba penceresinin açılmasını ve kodlara ulaşılmasını engelleyen ve açan kodlar Kod: Private Sub Workbook_Open() Application.VBE.MainWindow.Visible = False '// Close ALL windows 1st! CmdControl 1695, False '// Visual basics Editor CmdControl 186, False '// Macros CmdControl 184, False '// Record New Macro CmdControl 1561, False '// View Code CmdControl 1605, False '// Design Mode Application.OnDoubleClick = ""Dummy"" Application.CommandBars(""ToolBar List"").Enabled = False Application.OnKey ""%{F11}"", ""Dummy"" 'Workbooks.Open ""C:\"" 'add your stuff here ActiveWorkbook.RunAutoMacros xlAutoOpen End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) CmdControl 1695, True '// Visual basics Editor CmdControl 186, True '// Macros CmdControl 184, True '// Record New Macro CmdControl 1561, True '// View Code CmdControl 1605, True '// Design Mode Application.OnDoubleClick = """" Application.CommandBars(""ToolBar List"").Enabled = True 'thisone Application.OnKey ""%{F11}"", """" End Sub Sub CmdControl(Id As Integer, TF As Boolean) Dim CBar As CommandBar Dim C As CommandBarControl On Error Resume Next For Each CBar In Application.CommandBars Set C = CBar.FindControl(Id:=Id, recursive:=True) If Not C Is Nothing Then C.Enabled = TF Next End Sub Sub Dummy() MsgBox ""Kısıtlı Menü"" End Sub " Vbs İle klasÖr İŞlemlerİ "1-Klasör Oluşturma Kod: Sub Klasor_olustur() Set objFSO = CreateObject(""Scripting.FileSystemObject"") Set objFolder = objFSO.CreateFolder(""C:\YeniKlasor"") End Sub 2-Klasör Adı Değiştirme Kod: Sub Klasor_ad_degistir() Set objFSO = CreateObject(""Scripting.FileSystemObject"") objFSO.MoveFolder ""C:\YeniKlasor\eski_adi"", ""C:\YeniKlasor\yeni_adi"" End Sub 3-Klasör Silme Kod: Sub Klasor_sil() Set objFSO = CreateObject(""Scripting.FileSystemObject"") objFSO.DeleteFolder (""C:\YeniKlasor"") End Sub 4-Klasör Taşıma Kod: Sub Klasor_tasi() Set objFSO = CreateObject(""Scripting.FileSystemObject"") objFSO.MoveFolder ""C:\YeniKlasor"", ""D:\YeniKlasor"" End Sub 5-Klasör Kopyalama Kod: Sub Klasor_kopyala() Const OverWriteFiles = True Set objFSO = CreateObject(""Scripting.FileSystemObject"") objFSO.CopyFolder ""C:\YeniKlasor"", ""C:\EskiKlasor"", OverWriteFiles End Sub 6-Alt Klasör Listesi Kod: Sub Klasor_altklasor_listesi() Set objFSO = CreateObject(""Scripting.FileSystemObject"") Set objFolder = objFSO.GetFolder(""C:\YeniKlasor"") Set colSubfolders = objFolder.Subfolders For Each objSubfolder In colSubfolders MsgBox objSubfolder.Name, objSubfolder.Size Next End Sub " Vergi iadesi hesaplama "Private Sub CommandButton1_Click() If TextBox1 > 1 And TextBox1 <= 3600# Then iade = TextBox1 * 0.08 If TextBox1 >= 3601# And TextBox1 <= 7200# Then iade = (((TextBox1 - 3600#) * 0.06) + (3600# * 0.08)) If TextBox1 >= 7201# And TextBox1 >= 7201# Then iade = (((TextBox1 - 7200#) * 0.04) + (7200# * 0.07)) MsgBox iade End Sub" Verİ aktarma "Private Sub CommandButton1_Click() Application.ScreenUpdating = False Dim r As Integer r = Cells(65536, 2).End(xlUp).Row Cells(r + 1, 2) = Range(""a1"") Application.ScreenUpdating = True End Sub " Veri bulur "VERİLERİ BULUR Private Sub CommandButton6_Click() Dim bak As Range For Each bak In Range(""B1:B"" & WorksheetFunction.CountA(Range(""B1:B65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then bak.Select TextBox1.Value = ActiveCell.Offset(0, -1).Value TextBox2.Value = ActiveCell.Offset(0, 1).Value TextBox3.Value = ActiveCell.Offset(0, 2).Value Exit Sub End If Next bak MsgBox ""Aradığınız isimde bir kayıt bulunamadı"" End Sub 'VERİ ARATIRKEN SÜTUN SEÇİMİNİ GENİŞ TUTARSAK BÜTÜN SAYFADA VERİ ARATABİLİRİZ. Private Sub CommandButton1_Click() Dim bak As Range For Each bak In Range(""a1:ıv"" & WorksheetFunction.CountA(Range(""a1:ıv65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then bak.Select Exit Sub End If Next bak MsgBox ""Aradığınız isimde bir kayıt bulunamadı"" End Sub" Verİ bulur "VERİLERİ BULUR Private Sub CommandButton6_Click() Dim bak As Range For Each bak In Range(""B1:B"" & WorksheetFunction.CountA(Range(""B1:B65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then bak.Select TextBox1.Value = ActiveCell.Offset(0, -1).Value TextBox2.Value = ActiveCell.Offset(0, 1).Value TextBox3.Value = ActiveCell.Offset(0, 2).Value Exit Sub End If Next bak MsgBox ""Aradığınız isimde bir kayıt bulunamadı"" End Sub 'VERİ ARATIRKEN SÜTUN SEÇİMİNİ GENİŞ TUTARSAK BÜTÜN SAYFADA VERİ ARATABİLİRİZ. Private Sub CommandButton1_Click() Dim bak As Range For Each bak In Range(""a1:ıv"" & WorksheetFunction.CountA(Range(""a1:ıv65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then bak.Select Exit Sub End If Next bak MsgBox ""Aradığınız isimde bir kayıt bulunamadı"" End Sub " Veri değiştirir "VERİLERİ DEĞİŞTİRİR (DÜZENLEME YAPILANLARI KAYDEDER) Private Sub CommandButton8_Click() Dim bak As Range For Each bak In Range(""b1:b"" & WorksheetFunction.CountA(Range(""b1:b65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then bak.Select ActiveCell.Value = ComboBox1.Value ActiveCell.Offset(0, 1).Value = TextBox2.Value ActiveCell.Offset(0, 2).Value = TextBox3.Value Workbooks(""KİTAP2.XLS"").Save MsgBox ""Verileriniz Başarıyla Değiştirildi"", , ""KAYIT"" ComboBox1.Value = WorksheetFunction.Count(Range(""A1:A65000"")) + 1 Unload UserForm1 UserForm1.Show Exit Sub End If Next bak End Sub" Verİ deĞİŞtİrİr "VERİLERİ DEĞİŞTİRİR (DÜZENLEME YAPILANLARI KAYDEDER) Private Sub CommandButton8_Click() Dim bak As Range For Each bak In Range(""b1:b"" & WorksheetFunction.CountA(Range(""b1:b65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then bak.Select ActiveCell.Value = ComboBox1.Value ActiveCell.Offset(0, 1).Value = TextBox2.Value ActiveCell.Offset(0, 2).Value = TextBox3.Value Workbooks(""KİTAP2.XLS"").Save MsgBox ""Verileriniz Başarıyla Değiştirildi"", , ""KAYIT"" ComboBox1.Value = WorksheetFunction.Count(Range(""A1:A65000"")) + 1 Unload UserForm1 UserForm1.Show Exit Sub End If Next bak End Sub " Verİ deĞİŞtİrİrken uyari alma "Eğer Sizin çalışma kitabınızı sizden başkasının değiştirip kaydetmesini istemiyorsanız ki sorunuzdan bunu anladım şöyle bir koruma altına alabilirsiniz.Kodları ThisWorkbooka yazın.Kayıt şifresi:xxrt Kod: Private Sub Workbook_BeforeSave _ (ByVal SaveAsUI As Boolean, Cancel As Boolean) sifre = InputBox(""Kayıt için şifreyi girmelisiniz"", _ ""KAYIT"", ""şifre girin"") If sifre = ""xxrt"" Then MsgBox ""Kayıt işlemi tamamlandı"", vbInformation, _ ""KAYIT BAÃARILI"" Else MsgBox ""Yanlış şifre girdiniz."" & Chr(13) & _ ""Dosya kaydedilemedi"", vbCritical, ""HATALI ÃİFRE"" Cancel = True End If End Sub " Veri girme görme "VERİ GÖRME LİSTE KUTUSU Private Sub ListBox1_Click() TextBox1.Value = ListBox1.Value End Sub VERİ GİRME LİSTE KUTUSU Private Sub TextBox1_Change() End Sub VERİ GİRME LİSTE KUTUSU Private Sub TextBox2_Change() End Sub VERİ GİRME LİSTE KUTUSU Private Sub TextBox3_Change() End Sub " Verİ gİrme gÖrme "VERİ GÖRME LİSTE KUTUSU Private Sub ListBox1_Click() TextBox1.Value = ListBox1.Value End Sub VERİ GİRME LİSTE KUTUSU Private Sub TextBox1_Change() End Sub VERİ GİRME LİSTE KUTUSU Private Sub TextBox2_Change() End Sub VERİ GİRME LİSTE KUTUSU Private Sub TextBox3_Change() End Sub " Veri kaydırır "DEĞER DEĞİŞTİRİCİ BUTONU İŞLEVİ Private Sub SpinButton1_Change() TextBox1 = SpinButton1 'DEĞERİN DEĞİŞTİRİLECEĞİ TextBox%SpinButton End Sub 'COMBOBOX&TEXTBOX'DAKİ VERİLERİ AŞŞAĞI DOĞRU KAYDIRIR. Private Sub SpinButton2_Change() TextBox1.Value = ActiveCell.Offset(0, 0).Value ComboBox1.Value = ActiveCell.Offset(0, 1).Value TextBox3.Value = ActiveCell.Offset(0, 2).Value TextBox4.Value = ActiveCell.Offset(0, 3).Value TextBox5.Value = ActiveCell.Offset(0, 4).Value TextBox6.Value = ActiveCell.Offset(0, 5).Value ActiveCell.Offset(1, 0).Select 'BİRER BİRER HÜC.AŞŞAĞI KAYDIRIR. End Sub " Verİ kaydirir "DEĞER DEĞİŞTİRİCİ BUTONU İŞLEVİ Private Sub SpinButton1_Change() TextBox1 = SpinButton1 'DEĞERİN DEĞİŞTİRİLECEĞİ TextBox%SpinButton End Sub 'COMBOBOX&TEXTBOX'DAKİ VERİLERİ AŞŞAĞI DOĞRU KAYDIRIR. Private Sub SpinButton2_Change() TextBox1.Value = ActiveCell.Offset(0, 0).Value ComboBox1.Value = ActiveCell.Offset(0, 1).Value TextBox3.Value = ActiveCell.Offset(0, 2).Value TextBox4.Value = ActiveCell.Offset(0, 3).Value TextBox5.Value = ActiveCell.Offset(0, 4).Value TextBox6.Value = ActiveCell.Offset(0, 5).Value ActiveCell.Offset(1, 0).Select 'BİRER BİRER HÜC.AŞŞAĞI KAYDIRIR. End Sub " Veri olan hücreleri yazdırır "Sub imprSansLigneVide() For Each Ligne In ActiveSheet.UsedRange.Rows If Ligne.Cells(1, 1).Value = Empty Then 'si la cellule de la colonne A est vide, la ligne est masquée Ligne.EntireRow.Hidden = True End If Next 'Recherche de la derniere cellule ActiveCell.SpecialCells(xlLastCell).Select dercell = ActiveCell.Address 'definition de la zone d'impression zoneIMP = Range(""A1"", dercell).Address ActiveSheet.PageSetup.PrintArea = zoneIMP ActiveWindow.SelectedSheets.PrintOut Copies:=1 End Sub" Veri olan iki ayrı sütunu birleştirme "Excel de iki ayrı sütuna girilen verileri bir sütün içine veri kaybı olmadan toplamak. 'Bir adet modul oluşturun ve içindeki kodları modeülün içine kopyalayın. Dim Sh_Src As String, Sh_Tgt As String Dim Sh_Src_Row As Integer, Sh_Src_Bas_Row As Integer, Sh_Src_Son_Row As Integer Sayfa = ""sayfa1"" Sh_Src_Bas_Row = 1 Sh_Src_Son_Row = 10 On Error GoTo Hata For Sh_Src_Row = Sh_Src_Bas_Row To Sh_Src_Son_Row If Trim(Sheets(Sayfa).Cells(Sh_Src_Row, ""A"")) = """" Then MsgBox ""(Boş Veri)"" & vbCrLf & ""Hata Yeri!"" & vbCrLf & ""Sayfa Adı : "" & Safya & vbCrLf & ""Sütün Adı : A"" & Sh_Tgt_Row & """", vbCritical, ""Hata "" Exit Sub Else Selection.Cells(C).Value = Selection.Cells(A).Value & "" "" & Selection.Cells(B).Value End If Next MsgBox ""Aktarım İşlemi Bitti!"", vbInformation, ""BİLGİ"" Exit Sub Hata: MsgBox ""Hata oluştu!"" & vbCrLf & Err.Number & "" : "" & Err.Description, vbCritical, ""HATA OLUŞTU!"" " Veri olan satırlardan yukarısını gizler "Sub HideRows() For Each rngRow In ActiveSheet.UsedRange.Rows If Application.Sum(rngRow) = 0 Then rngRow.EntireRow.Hidden = True End If Next rngRow End Sub" Veri olan sayfaları yazdırma "Sub verili_yaz() Dim wc As Integer For wc = 1 To ThisWorkbook.Worksheets.Count ThisWorkbook.Worksheets(wc).PrintOut Next wc End Sub" Veri olan tüm sayfaları yazdırır yoksa tarar ama yazdırmaz "Option Explicit Sub PrintAllSheets() Dim First As Integer, Last As Integer '// Assumning Sheet1 is 1st sheet Sheets(""Sheet1"").Activate Last = Sheets.Count For First = 1 To Last With ActiveSheet.PageSetup .PrintTitleRows = """" .PrintTitleColumns = """" End With ActiveSheet.PageSetup.PrintArea = """" '// set up the way you want here, this is just an example! With ActiveSheet.PageSetup .CenterHeader = ""&F!&A"" .RightHeader = """" .LeftFooter = """" .CenterFooter = ""Page "" & First & "" of "" & Last .RightFooter = ""©"" & Application.Text(Now(), ""yyyy"") .PrintHeadings = False .PrintGridlines = False .PrintNotes = False .CenterHorizontally = True .CenterVertically = False .Orientation = xlPortrait .Draft = False .PaperSize = xlPaperLetter .FirstPageNumber = xlAutomatic .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True If First <> Last Then ActiveSheet.Next.Select Next First End Sub " Veri sıralar ve isim bulur "VERİLERİ A'DAN Z'YE SIRALAR YAZILAN İLKHARFE ENYAKIN İSMİ BULUR Private Sub ComboBox1_Change() 'ListFillRange A2:A64997(vba özellikler menüsüne girilecek hüc. Adreside buradan verilir.) ActiveWindow.ScrollRow = ComboBox1.ListIndex + 2 End Sub Private Sub ComboBox1_GotFocus() ActiveSheet.ComboBox1.ListIndex = -1 Rows(""2:65000"").Sort Key1:=Range(""A2""), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Dim no no = ActiveWindow.ScrollRow If KeyCode = 13 Then Cells(no, 1).Activate End Sub" Veri siler "VERİLERİ SİLER Private Sub CommandButton7_Click() Dim say As Integer Dim i As Integer Dim bos As Range For Each bos In Range(""B1:B"" & WorksheetFunction.CountA(Range(""B1:B65000""))) If ComboBox1.Value = """" Or bos = """" Or ActiveCell = """" Then MsgBox ""Önce aradığınız veriyi BUL ile bulmalısınız"" Exit Sub End If Next bos Range(ActiveCell.Offset(0, -1).Address(False, False) & "":"" & ActiveCell.Offset(0, 2).Address(False, False)).Delete Shift:=xlUp say = WorksheetFunction.CountA(Range(""A2:A65000"")) For i = 1 To say Cells(i + 1, 1) = i Next i Workbooks(""kitap2.XLS"").Save MsgBox ""Veriniz Silindi"", , ""KAYIT"" ComboBox1.RowSource = ""Veri!B1:B"" & say + 1 TextBox1.Value = WorksheetFunction.Count(Range(""A1:A65000"")) + 1 Unload UserForm1 UserForm1.Show End Sub " Verİ sİler "VERİLERİ SİLER Private Sub CommandButton7_Click() Dim say As Integer Dim i As Integer Dim bos As Range For Each bos In Range(""B1:B"" & WorksheetFunction.CountA(Range(""B1:B65000""))) If ComboBox1.Value = """" Or bos = """" Or ActiveCell = """" Then MsgBox ""Önce aradığınız veriyi BUL ile bulmalısınız"" Exit Sub End If Next bos Range(ActiveCell.Offset(0, -1).Address(False, False) & "":"" & ActiveCell.Offset(0, 2).Address(False, False)).Delete Shift:=xlUp say = WorksheetFunction.CountA(Range(""A2:A65000"")) For i = 1 To say Cells(i + 1, 1) = i Next i Workbooks(""kitap2.XLS"").Save MsgBox ""Veriniz Silindi"", , ""KAYIT"" ComboBox1.RowSource = ""Veri!B1:B"" & say + 1 TextBox1.Value = WorksheetFunction.Count(Range(""A1:A65000"")) + 1 Unload UserForm1 UserForm1.Show End Sub " Verİ siralar ve İsİm bulur "VERİLERİ A'DAN Z'YE SIRALAR YAZILAN İLKHARFE ENYAKIN İSMİ BULUR Private Sub ComboBox1_Change() 'ListFillRange A2:A64997(vba özellikler menüsüne girilecek hüc. Adreside buradan verilir.) ActiveWindow.ScrollRow = ComboBox1.ListIndex + 2 End Sub Private Sub ComboBox1_GotFocus() ActiveSheet.ComboBox1.ListIndex = -1 Rows(""2:65000"").Sort Key1:=Range(""A2""), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Dim no no = ActiveWindow.ScrollRow If KeyCode = 13 Then Cells(no, 1).Activate End Sub " Verilen degeri bul yanindakilari kopyala yapistir. "Sub ara() On Error Resume Next Application.ScreenUpdating = False sat = Sayfa1.Columns(1).Find(Sayfa2.[A1].Value).Row Sayfa1.Range(""A"" & sat, ""F"" & sat).Copy s = WorksheetFunction.CountA(Sayfa2.[B1:B65536]) Sayfa2.Range(""B"" & s + 1).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False End Sub " Verİlen deĞere gÖre farkli hÜcreye bİlgİ veren bİr macro "Sayfa1 Kod sayfasına;Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = ""$a$1"" Then Range(""D54"").Select End Sub Kodu yazdıktan sonra A1 Hücresine geldiğinizde D54 Hücresine gelecektir.Gerisini siz yaparsınız.Seçilen Hücreyi renk vermek istersenizKod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = ""$F$10"" Then Range(""d54"").Select Range(""d54"").Interior.ColorIndex = 6 End Sub Seçilen Hücreye Formul yazdırmak istersenizKod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = ""$F$10"" Then Range(""d4"").Select Range(""d54"").Formula = ""=A1+A3"" End Sub " Verİlen sayiyi gruplara bÖlme İŞlemİ "Sub deneme() qc = WorksheetFunction.Ceiling([e5], 0.5) sat = 9 ' **** 3 kademe bol = 3: GoSub dagit ' **** 5 kademe bol = 5: GoSub dagit ' **** 7 kademe bol = 7: GoSub dagit ' **** 12 kademe bol = 12: GoSub dagit Exit Sub dagit: sat = sat + 1 st = WorksheetFunction.RoundUp(qc / bol, 0.5) par1 = qc - ((bol - 1) * st) par: If par1 < 0.5 Then st = st - 0.5 par1 = qc - ((bol - 1) * st) End If If par1 < 0.5 Then GoTo par If par1 < st Then Cells(sat, 6) = par1 Cells(sat, 6 + (bol - 1) * 2) = st Else Cells(sat, 6) = st Cells(sat, 6 + (bol - 1) * 2) = par1 End If For x = 8 To 6 + ((bol - 2) * 2) Step 2 Cells(sat, x) = st Next x Return End Sub" Verileri formülü bozmadan siler "KİTAPTAKİ VERİLERİ FORMÜLLERİ BOZMADAN SİLER Sub ResetModel() Range(""A1"").SpecialCells(xlCellTypeConstants, xlNumbers).ClearContents End Sub " Verİlerİ formÜlÜ bozmadan sİler "KİTAPTAKİ VERİLERİ FORMÜLLERİ BOZMADAN SİLER Sub ResetModel() Range(""A1"").SpecialCells(xlCellTypeConstants, xlNumbers).ClearContents End Sub " Verileri hücreye otomatik sığdırma "Sub Optimale_Breite() Columns(""A:IV"").Select Range(Selection, Selection.End(xlToRight)).Select Cells.EntireColumn.AutoFit End Sub" Verileri isim sırasına göre dizer "FORMDAN COMBOBOX KUTUSUNA KOMUT BU KOMUT İSİMLERİ SIRAYA SOKAR MODÜLE YAZILAN KOMUT İLE BİRLİKTE. Private Sub UserForm_Initialize() MyForm = Me.Name ComboBox1.RowSource = ""sayfa1!b1:b1000"" OrganizeComboBox End Sub BU BÖLÜM MODÜL KISMINA YAZILACAK. Dim MyForm As Variant Option Base 1 ' Sub OrganizeComboBox() Dim noData, i, j, k, m As Integer Dim MyComboArray() Dim MyRevizedComboArray() Dim MyData As Range Dim SortedColl As New Collection Dim Swap1, Swap2 As Variant ' For Each MyControl In UserForms(MyForm).Controls ' i = 0 j = 0 k = 0 ' If TypeName(MyControl) = ""ComboBox"" Then noData = MyControl.ListCount ReDim MyComboArray(noData) For Each MyData In Range(MyControl.RowSource) i = i + 1 MyComboArray(i) = MyData Next For m = 1 To UBound(MyComboArray) If Not WorksheetFunction.IsNumber(MyComboArray(m)) Then MyComboArray(m) = UCase(MyComboArray(m)) MyComboArray(m) = Replace(MyComboArray(m), ""Ç"", ""Ç"") MyComboArray(m) = Replace(MyComboArray(m), ""İ"", ""İ"") MyComboArray(m) = Replace(MyComboArray(m), ""Ğ"", ""Ğ"") MyComboArray(m) = Replace(MyComboArray(m), ""Ş"", ""Ş"") MyComboArray(m) = Replace(MyComboArray(m), ""Ü"", ""Ü"") MyComboArray(m) = Replace(MyComboArray(m), ""Ö"", ""Ö"") End If Next For i = 1 To UBound(MyComboArray) For j = i + 1 To UBound(MyComboArray) - 1 If MyComboArray(i) = MyComboArray(j) Then MyComboArray(i) = """" End If Next Next ' MyControl.RowSource = """" ' For i = 1 To UBound(MyComboArray) If MyComboArray(i) <> """" Then k = k + 1 ReDim Preserve MyRevizedComboArray(k) MyRevizedComboArray(k) = MyComboArray(i) End If Next ' i = 0 j = 0 For i = 1 To UBound(MyRevizedComboArray) SortedColl.Add MyRevizedComboArray(i) Next ' 'On Error Resume Next 'For i = 1 To UBound(MyRevizedComboArray) 'MyRevizedComboArray(i) = WorksheetFunction.Small(MyRevizedComboArray, i) 'Next For i = 1 To SortedColl.Count - 1 For j = i + 1 To SortedColl.Count If SortedColl(i) > SortedColl(j) Then Swap1 = SortedColl(i) Swap2 = SortedColl(j) SortedColl.Add Swap1, before:=j SortedColl.Add Swap2, before:=i SortedColl.Remove i + 1 SortedColl.Remove j + 1 End If Next j Next i ' For i = 1 To SortedColl.Count MyControl.AddItem SortedColl(i) Next ' For i = SortedColl.Count To 1 Step -1 SortedColl.Remove i Next ' End If Erase MyComboArray Erase MyRevizedComboArray ' Next End Sub " Verİlerİ İsİm sirasina gÖre dİzer "FORMDAN COMBOBOX KUTUSUNA KOMUT BU KOMUT İSİMLERİ SIRAYA SOKAR MODÜLE YAZILAN KOMUT İLE BİRLİKTE. Private Sub UserForm_Initialize() MyForm = Me.Name ComboBox1.RowSource = ""sayfa1!b1:b1000"" OrganizeComboBox End Sub BU BÖLÜM MODÜL KISMINA YAZILACAK. Dim MyForm As Variant Option Base 1 ' Sub OrganizeComboBox() Dim noData, i, j, k, m As Integer Dim MyComboArray() Dim MyRevizedComboArray() Dim MyData As Range Dim SortedColl As New Collection Dim Swap1, Swap2 As Variant ' For Each MyControl In UserForms(MyForm).Controls ' i = 0 j = 0 k = 0 ' If TypeName(MyControl) = ""ComboBox"" Then noData = MyControl.ListCount ReDim MyComboArray(noData) For Each MyData In Range(MyControl.RowSource) i = i + 1 MyComboArray(i) = MyData Next For m = 1 To UBound(MyComboArray) If Not WorksheetFunction.IsNumber(MyComboArray(m)) Then MyComboArray(m) = UCase(MyComboArray(m)) MyComboArray(m) = Replace(MyComboArray(m), ""Ç"", ""Ç"") MyComboArray(m) = Replace(MyComboArray(m), ""İ"", ""İ"") MyComboArray(m) = Replace(MyComboArray(m), ""Ğ"", ""Ğ"") MyComboArray(m) = Replace(MyComboArray(m), ""Ş"", ""Ş"") MyComboArray(m) = Replace(MyComboArray(m), ""Ü"", ""Ü"") MyComboArray(m) = Replace(MyComboArray(m), ""Ö"", ""Ö"") End If Next For i = 1 To UBound(MyComboArray) For j = i + 1 To UBound(MyComboArray) - 1 If MyComboArray(i) = MyComboArray(j) Then MyComboArray(i) = """" End If Next Next ' MyControl.RowSource = """" ' For i = 1 To UBound(MyComboArray) If MyComboArray(i) <> """" Then k = k + 1 ReDim Preserve MyRevizedComboArray(k) MyRevizedComboArray(k) = MyComboArray(i) End If Next ' i = 0 j = 0 For i = 1 To UBound(MyRevizedComboArray) SortedColl.Add MyRevizedComboArray(i) Next ' 'On Error Resume Next 'For i = 1 To UBound(MyRevizedComboArray) 'MyRevizedComboArray(i) = WorksheetFunction.Small(MyRevizedComboArray, i) 'Next For i = 1 To SortedColl.Count - 1 For j = i + 1 To SortedColl.Count If SortedColl(i) > SortedColl(j) Then Swap1 = SortedColl(i) Swap2 = SortedColl(j) SortedColl.Add Swap1, before:=j SortedColl.Add Swap2, before:=i SortedColl.Remove i + 1 SortedColl.Remove j + 1 End If Next j Next i ' For i = 1 To SortedColl.Count MyControl.AddItem SortedColl(i) Next ' For i = SortedColl.Count To 1 Step -1 SortedColl.Remove i Next ' End If Erase MyComboArray Erase MyRevizedComboArray ' Next End Sub " Verileri kaydeder "VERİLERİ KAYDEDER Private Sub CommandButton5_Click() Dim bak As Range Dim say As Integer For Each bak In Range(""A1:A"" & WorksheetFunction.CountA(Range(""A1:A65000""))) If bak.Value = ComboBox1.Value Then MsgBox ""Bu Kayıt numarası bulundu."" Exit Sub End If Next bak For Each bak In Range(""B1:B"" & WorksheetFunction.CountA(Range(""B1:B65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then MsgBox ""Bu isimde bir kaydınız bulundu"" Exit Sub End If Next bak say = WorksheetFunction.CountA(Range(""B1:B65000"")) TextBox1.Value = say Cells(say + 1, 1).Value = TextBox1.Value Cells(say + 1, 2).Value = ComboBox1.Value Cells(say + 1, 3).Value = TextBox2.Value Cells(say + 1, 4).Value = TextBox3.Value Workbooks(""kitap2.XLS"").Save MsgBox ""Verileriniz Kaydedildi"", , ""KAYIT"" ComboBox1.RowSource = ""Veri!B2:B"" & say + 1 TextBox1.Value = WorksheetFunction.Count(Range(""A1:A65000"")) + 1 Unload UserForm1 UserForm1.Show End Sub 'BU KOD FORMA YAZILIR Private Sub UserForm_Initialize() Dim say As Integer Sheets(""Veri"").Select TextBox1.Locked = True If Range(""B2"") = """" Then say = WorksheetFunction.CountA(Range(""B1:B65000"")) ComboBox1.RowSource = ""Veri!B2:B"" & say + 1 Else say = WorksheetFunction.CountA(Range(""B1:B65000"")) ComboBox1.RowSource = ""Veri!B2:B"" & say End If TextBox1.Value = say ComboBox1.SetFocus End Sub " Verİlerİ kaydeder "VERİLERİ KAYDEDER Private Sub CommandButton5_Click() Dim bak As Range Dim say As Integer For Each bak In Range(""A1:A"" & WorksheetFunction.CountA(Range(""A1:A65000""))) If bak.Value = ComboBox1.Value Then MsgBox ""Bu Kayıt numarası bulundu."" Exit Sub End If Next bak For Each bak In Range(""B1:B"" & WorksheetFunction.CountA(Range(""B1:B65000""))) If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then MsgBox ""Bu isimde bir kaydınız bulundu"" Exit Sub End If Next bak say = WorksheetFunction.CountA(Range(""B1:B65000"")) TextBox1.Value = say Cells(say + 1, 1).Value = TextBox1.Value Cells(say + 1, 2).Value = ComboBox1.Value Cells(say + 1, 3).Value = TextBox2.Value Cells(say + 1, 4).Value = TextBox3.Value Workbooks(""kitap2.XLS"").Save MsgBox ""Verileriniz Kaydedildi"", , ""KAYIT"" ComboBox1.RowSource = ""Veri!B2:B"" & say + 1 TextBox1.Value = WorksheetFunction.Count(Range(""A1:A65000"")) + 1 Unload UserForm1 UserForm1.Show End Sub 'BU KOD FORMA YAZILIR Private Sub UserForm_Initialize() Dim say As Integer Sheets(""Veri"").Select TextBox1.Locked = True If Range(""B2"") = """" Then say = WorksheetFunction.CountA(Range(""B1:B65000"")) ComboBox1.RowSource = ""Veri!B2:B"" & say + 1 Else say = WorksheetFunction.CountA(Range(""B1:B65000"")) ComboBox1.RowSource = ""Veri!B2:B"" & say End If TextBox1.Value = say ComboBox1.SetFocus End Sub " Verİlerİn rapor olarak saklanmasi "Sub veriaktar() Sheets(""sayfa1"").Range(""D3:D12"").Copy sat = Sheets(""sayfa2"").Cells(65536, 2).End(xlUp).Row Sheets(""sayfa2"").Cells(sat + 1, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True Application.CutCopyMode = False End Sub " Verinin bittiği İlk boş satira yapiştirmak "Sub Düğme1_Tıklat() Selection.Copy 'seçili alanı kopyala Range(""A:A"").End(xlDown).Offset(1, 0).Select 'en son satıra git ActiveSheet.Paste 'yapıştır Application.CutCopyMode = False 'kopyalanları iptal et End Sub " Verisiz son satıra götürür "SON SATIRA GÖTÜRÜR Private Sub CommandButton1_Click() Dim alan, satırsayısı, sonsatır Set alan = Cells(1, 1).CurrentRegion satırsayısı = alan.Rows.Count sonsatır = satırsayısı + 1 Cells(sonsatır, 1).Select End Sub SON HÜCREYE GÖTÜRÜR Sub ActivateNextBlankDown() Range(""A1"").Select ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop End Sub 'LABELDEN SAYFANIN VERİLEN ADRESİNE VERİSİZ SON HÜCREYE YAZDIRIR Private Sub Label1_Click() Range(""A1"").Select ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop ActiveCell.FormulaR1C1 = ""ZIMPARALI VALYAN PROBLEMİ"" End End Sub " Verİsİz son satira gÖtÜrÜr "SON SATIRA GÖTÜRÜR Private Sub CommandButton1_Click() Dim alan, satırsayısı, sonsatır Set alan = Cells(1, 1).CurrentRegion satırsayısı = alan.Rows.Count sonsatır = satırsayısı + 1 Cells(sonsatır, 1).Select End Sub SON HÜCREYE GÖTÜRÜR Sub ActivateNextBlankDown() Range(""A1"").Select ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop End Sub 'LABELDEN SAYFANIN VERİLEN ADRESİNE VERİSİZ SON HÜCREYE YAZDIRIR Private Sub Label1_Click() Range(""A1"").Select ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop ActiveCell.FormulaR1C1 = ""ZIMPARALI VALYAN PROBLEMİ"" End End Sub " Verİye gÖre sayfa oluŞturmak ve satirlari kopyalamak "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) For Each linkler In ActiveWorkbook.ActiveSheet.Hyperlinks linkler.SubAddress = Right(linkler.SubAddress, Len(linkler.SubAddress) - InStr(linkler.SubAddress, ""!"")) Next End Sub" Versiyon numaralarını öğrenme "Sub version_number() Dim mtext mtext = ""Programın Adı: "" & Application.Name _ & Chr(13) & ""İşletim Sistemi: "" & _ Application.OperatingSystem & Chr(13) & _ ""Version Numarası: "" & Application.Version _ & Chr(13) & ""Yapım Numarası: "" & Application.Build MsgBox mtext End Sub" Virgülden sonra sıfır ekleme "Sub SetFigures() Dim iDecimals As Integer Dim bCommas As Boolean Dim sFormat As String Dim CellRange As Range Dim TestCell As Range bCommas = False 'Change as desired Set CellRange = Selection For Each TestCell In CellRange If Abs(TestCell.Value) < 1 Then iDecimals = 5 Else iDecimals = 5 - Int(Log(Abs(TestCell.Value)) / Log(10#)) End If sFormat = ""0"" If bCommas Then sFormat = ""#,##0"" If iDecimals < 0 Then sFormat = ""General"" If iDecimals > 0 Then sFormat = sFormat & _ ""."" & String(iDecimals, ""0"") TestCell.NumberFormat = sFormat Next TestCell End Sub" Virgüllü kelimeleri alt alta sıralar "Sub SplitCells() Tstring = Selection.Value For i = 1 To Len(Tstring) If Mid(Tstring, i, 1) = "","" Then z = z + 1 Next i ReDim y(z + 1) For i = 1 To Len(Tstring) If Mid(Tstring, i, 1) <> "","" Then x = x & Mid(Tstring, i, 1) End If If Mid(Tstring, i, 1) = "","" Then y(c) = x c = c + 1 x = """" End If Next i y(z) = x For i = 0 To UBound(y) Selection.Offset(i + 1, 0).Value = y(i) Next i End Sub" Vİsual basİc project erİŞİmİne gÜven Çekbox'ini true yapmak. "Sub Test3() Dim WSH_Shell As Object Dim MyVer As String, RegKey As String Dim MySetting As Integer MyVer = Application.Version RegKey = ""HKLM\Software\Microsoft\Office\"" & MyVer & ""\Excel\Security\AccessVBOM"" Set WSH_Shell = CreateObject(""WScript.Shell"") WSH_Shell.RegWrite RegKey, 1, ""REG_DWORD"" End Sub Durumu düzeltmek için aşağıdaki kodu kullanın. Kod: Sub PanZehir() Dim WSH_Shell As Object Dim MyVer As String, RegKey As String Dim MySetting As Integer MyVer = Application.Version RegKey = ""HKLM\Software\Microsoft\Office\"" & MyVer & ""\Excel\Security\AccessVBOM"" Set WSH_Shell = CreateObject(""WScript.Shell"") WSH_Shell.RegDelete RegKey End Sub " Wait" yerine başka bir komut "[i]30 Basla = Timer 40 Cells(satır, 5) = Now() Cells(satır, 6).Value = Cells(2, 4).Value Application.Wait (Now + TimeSerial(0, 0, 5)) 'Do While Timer < Basla + 2 'Daha evvel bunu kullanmayı denedim. 'DoEvents ama işlemciyi fazla kullanıyor diye 'Loop kullanmaktan vazgeçtim. satır = satır + 1 Simdi2 = Now() If DateDiff(""n"", Simdi, Simdi2) <= 4 Then GoTo 30[/i]" Wav çaldırma "Declare Function sndPlaySound32 Lib ""winmm.dll"" Alias _ ""sndPlaySoundA"" (ByVal lpszSoundName As String, _ ByVal uFlags As Long) As Long Sub Klang() Call sndPlaySound32(""D:\Programme\ICQ\Connect.wav"", 0) End Sub" Wav çalma "Declare Function sndPlaySound32 Lib ""winmm.dll"" _ Alias ""sndPlaySoundA"" (ByVal lpszSoundName _ As String, ByVal uFlags As Long) As Long Sub wav_cal() On Error Resume Next ChDir ""a"" If Err = 76 Then GoTo pir End pir: Call sndPlaySound32(""C:\excel\warning.wav"", 1) End Sub" Wav dosyası çalma 1 "Declare Function sndPlaySound32 Lib ""winmm.dll"" Alias ""sndPlaySoundA"" _ (ByVal lpzSoundName As String, ByVal uFlags As Long) As Long Sub Musique() If Application.CanPlaySounds Then Call sndPlaySound32(""D:\creedenc.wav"", 0) 'Changer le chemin (""D:\ .."", 0) End If End Sub" Wav dosyası çalma 2 "Sub Auto_Open() Worksheets(""Sheet1"").OnCalculate = ""PlayIt"" End Sub Sub PlayIt() If Range(""A1"").Value > 5 Then ExecuteExcel4Macro (""SOUND.PLAY(, """"C:\Windows\Media\Tada.wav"""")"") End If End Sub" Wav dosyası çalma 3 "Declare Function sndPlaySound32 Lib ""winmm.dll"" Alias _ ""sndPlaySoundA"" (ByVal lpszSoundName As String, _ ByVal uFlags As Long) As Long Sub Klang() Call sndPlaySound32(""D:\Programme\ICQ\Connect.wav"", 0) End Sub" Wav dosyası çalma 4 "Sub PlayIt() ExecuteExcel4Macro (""SOUND.PLAY(, """"C:\Windows\Media\Tada.wav"""")"") End Sub" Wav dosyası çalma 5 "Declare Function sndPlaySound32 Lib ""winmm.dll"" Alias ""sndPlaySoundA"" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Sub Klang() Call sndPlaySound32(""D:\Programme\ICQ\Connect.wav"", 0) End Sub" Web sayfası açma "Public Sub gotoTMWebSite() On Error Resume Next ShellExecute 0&, vbNullString, ""www.pirsa.com"", vbNullString, _ vbNullString, vbNormalFocus On Error GoTo 0 End Sub" Windows arama penceresi "Option Explicit Private Declare Function ShellExecute Lib ""shell32.dll"" _ Alias ""ShellExecuteA"" ( _ ByVal hwnd As Long, _ ByVal lpOperation As String, _ ByVal lpFile As String, _ ByVal lpParameters As String, _ ByVal lpDirectory As String, _ ByVal nShowCmd As Long) As Long Private Const SW_SHOWNORMAL = 1 Sub FindAllFiles() Dim strPathToSearch As String strPathToSearch = ""C:\"" ShellExecute _ 0, _ ""find"", _ strPathToSearch, _ vbNullString, _ vbNullString, _ SW_SHOWNORMAL End Sub" Windows help açma "Sub ShowVBEHelp() Shell ""c:\windows\winhelp.exe veenob3.hlp"", vbNormalFocus End Sub" Windows kapatma penceresini çağırma "Sub WinExit() 'marche bien sous XP With CreateObject(""Shell.Application"") .ShutdownWindows End With End Sub Sub ExitWindows9598() ValRetour = Shell(""C:\WINDOWS\rundll32.exe user.exe,exitwindows"") End Sub Sub RedemarWindows98() ValRetour = Shell(""C:\WINDOWS\Rundll32.exe shell32,SHExitWindowsEx"") End Sub" Windowsu kapatma "Declare Function ExitWindowsEx& Lib ""user32"" (ByVal uFlags&, ByVal wReserved&) Global Const EWX_FORCE = 8 Global Const EWX_LOGOFF = 0 Global Const EWX_REBOOT = 2 Global Const EWX_SHUTDOWN = 1 Sub Tschuess() Dim LResult LResult = ExitWindowsEx(EWX_SHUTDOWN, 0&) End Sub" Wmi anakart "Sub MotherBoardInfo() Dim strComputerName As String Dim strNameSpace As String Dim strClassName As String Dim objWMIMboard As Object Dim objWMIService As Object Dim objWMI_Mboards As Object Dim strRet As String strComputerName = ""."" strNameSpace = ""root\cimv2"" strClassName = ""Win32_BaseBoard"" On Error Resume Next If Err.Number <> 0 Then MsgBox ""WMI yüklenmemiş! Programdan çıkılacak "", vbExclamation, _ ""Windows Management Instrumentation"" Exit Sub On Error GoTo 0 End If Set objWMIService = GetObject(""winmgmts:\\"" & strComputerName & _ ""\"" & strNameSpace) Set objWMI_Mboards = objWMIService.ExecQuery _ (""Select * from "" & strClassName) For Each objWMIMboard In objWMI_Mboards strRet = ""Üretici Firma = "" & objWMIMboard.Manufacturer & vbCrLf strRet = strRet & ""Seri Numarası = "" & objWMIMboard.SerialNumber MsgBox strRet, vbInformation, ""Ana Kart Bilgileri (Raider ®)"" Next End Sub" Wmi bilgi "Sub InstalledProgsByMSI() Dim MyOBJ As Object Dim MyProg As Variant Dim MyMsg As String On Error Resume Next If Err.Number <> 0 Then MsgBox ""WMI yüklenmemiş! Programdan çıkılacak "", vbExclamation, _ ""Windows Management Instrumentation"" Exit Sub On Error GoTo 0 End If strComputer = ""."" Set MyOBJ = GetObject(""winmgmts:"" _ & ""{impersonationLevel=impersonate}!\\"" _ & strComputer & ""\root\cimv2"") Set MSISoftware = MyOBJ.ExecQuery _ (""Select * from Win32_Product"") MyMsg = MyMsg & ""MSI ile yüklenen programlar hakkında:"" & vbCrLf For Each MyProg In MSISoftware MyMsg = MyMsg & String(50, ""-"") & vbCrLf MyMsg = MyMsg & ""Program: "" & MyProg.Name & vbCrLf MyMsg = MyMsg & ""Versiyon: "" & MyProg.Version & vbCrLf MyMsg = MyMsg & ""Üretici: "" & MyProg.Vendor & vbCrLf MyMsg = MyMsg & ""Kurulum: "" & Left(MyProg.InstallDate, 4) & ""/"" & _ Mid(MyProg.InstallDate, 5, 2) & ""/"" & _ Mid(MyProg.InstallDate, 7, 2) & vbCrLf Next MsgBox MyMsg, vbInformation, ""Programlar hakkında (Raider ®)"" End Sub" Wmi bios "Sub InfoBIOS() Dim MyOBJ As Object Dim MyBios As Variant Dim MyMsg As String On Error Resume Next Set MyOBJ = GetObject(""WinMgmts:"").instancesOf _ (""Win32_Bios"") If Err.Number <> 0 Then MsgBox ""WMI yüklenmemiş! Programdan çıkılacak "", vbExclamation, _ ""Windows Management Instrumentation"" Exit Sub On Error GoTo 0 End If For Each MyBios In MyOBJ MyMsg = String(50, ""-"") & vbCrLf MyMsg = MyMsg & ""Üretici Firma : "" & MyBios.Manufacturer & vbCrLf MyMsg = MyMsg & ""BIOS Seri Numarası : "" & MyBios.SerialNumber & vbCrLf Next MsgBox MyMsg, vbInformation, ""BIOS Bilgileri (Raider ®)"" End Sub" Wmi ekran kartı "Sub InfoVideoController() Dim MyOBJ As Object Dim MyVideoController As Variant Dim MyMsg As String On Error Resume Next Set MyOBJ = GetObject(""WinMgmts:"").instancesOf _ (""Win32_VideoController"") If Err.Number <> 0 Then MsgBox ""WMI yüklenmemiş! Programdan çıkılacak "", vbExclamation, _ ""Windows Management Instrumentation"" Exit Sub On Error GoTo 0 End If For Each MyVideoController In MyOBJ MyMsg = MyMsg & ""Ekran Kartı bilgileri :"" & vbCrLf MyMsg = MyMsg & String(50, ""-"") & vbCrLf MyMsg = MyMsg & ""Üretici Firma : "" & MyVideoController.AdapterCompatibility & _ "" ("" & MyVideoController.Caption & "")"" & vbCrLf MyMsg = MyMsg & ""Yatay çözünürlük : "" & MyVideoController.CurrentHorizontalResolution & vbCrLf MyMsg = MyMsg & ""Dikey çözünürlük : "" & MyVideoController.CurrentVerticalResolution & vbCrLf MyMsg = MyMsg & ""Renk kalitesi : "" & MyVideoController.CurrentBitsPerPixel & "" bps"" & vbCrLf MyMsg = MyMsg & ""Video Modu : "" & MyVideoController.VideoModeDescription & vbCrLf MyMsg = MyMsg & ""İşlemci : "" & MyVideoController.VideoProcessor & vbCrLf Next MsgBox MyMsg, vbInformation, ""Ekran Kartı Bilgileri (Raider ®)"" End Sub" Wmi mouse "Sub InfoPointingDevices() Dim MyOBJ As Object Dim MyPtgDev As Variant Dim MyMsg As String On Error Resume Next Set MyOBJ = GetObject(""WinMgmts:"").instancesOf _ (""win32_pointingdevice"") If Err.Number <> 0 Then MsgBox ""WMI yüklenmemiş! Programdan çıkılacak "", vbExclamation, _ ""Windows Management Instrumentation"" Exit Sub On Error GoTo 0 End If For Each MyPtgDev In MyOBJ MyMsg = MyMsg & "" *"" & vbCrLf MyMsg = MyMsg & ""İşlemci : "" & Trim(MyCPU.Name) & vbCrLf MyMsg = MyMsg & ""Ad : "" & MyPtgDev.Name & vbCrLf MyMsg = MyMsg & ""Üretici : "" & MyPtgDev.Manufacturer & vbCrLf MyMsg = MyMsg & ""Buton adedi : "" & MyPtgDev.NumberOfButtons & vbCrLf Next MsgBox MyMsg, vbInformation, ""Mouse Bilgileri (Raider ®)"" End Sub" Wmi network adaptörleri "Sub InfoNetworkAdapter() Dim MyOBJ As Object Dim MyNetworkAdapter As Variant Dim MyMsg As String On Error Resume Next Set MyOBJ = GetObject(""WinMgmts:"").instancesOf _ (""Win32_NetworkAdapter"") If Err.Number <> 0 Then MsgBox ""WMI yüklenmemiş! Programdan çıkılacak "", vbExclamation, _ ""Windows Management Instrumentation"" Exit Sub End If MyMsg = MyMsg & ""Network Adaptörleri hakkında:"" & vbCrLf For Each MyNetworkAdapter In MyOBJ MyMsg = MyMsg & vbCrLf MyMsg = MyMsg & ""Üretici Firma : "" & MyNetworkAdapter.Manufacturer & vbCrLf MyMsg = MyMsg & ""Adı : "" & MyNetworkAdapter.Name & vbCrLf MyMsg = MyMsg & ""Tip : "" & MyNetworkAdapter.AdapterType & vbCrLf Next MsgBox MyMsg, vbInformation, ""Network " Wmi sistem "Sub SysInfo() Dim MyMsg As String, oSystem As Object, Item As Object Set oSystem = GetObject(""winmgmts:"").instancesOf(""Win32_ComputerSystem"") For Each Item In oSystem MyMsg = ""Bilgisayar hakkında "" & vbCrLf MyMsg = MyMsg & ""-----------"" & vbCrLf MyMsg = MyMsg & ""Ad: "" & item.Name & vbCrLf MyMsg = MyMsg & ""Tip: "" & item.SystemType & vbCrLf MyMsg = MyMsg & ""Üretici: "" & item.Manufacturer & vbCrLf MyMsg = MyMsg & ""Model: "" & item.Model & vbCrLf MyMsg = MyMsg & ""RAM: "" & item.TotalPhysicalMemory \ 1024000 & "" Mb"" & vbCrLf MyMsg = MyMsg & ""Domain: "" & item.Domain & vbCrLf MyMsg = MyMsg & ""Kayıtlı kullanıcı: "" & item.UserName & vbCrLf MsgBox MyMsg, vbInformation, ""Sistem Bilgileri (Raider ®)"" Next Set oSystem = Nothing End Sub" Wmi windows "Sub OS_Info() Dim strComputerName As String Dim strNameSpace As String Dim strClassName As String Dim OS As Object Dim objWMIService As Object Dim Osinf As Object Dim strManufacturer As String, strRegisteredUser As String, strSerialNumber As String Dim strVersionId As String, strVersionName As String strComputerName = ""."" strNameSpace = ""root\cimv2"" strClassName = ""Win32_OperatingSystem"" ' On Error Resume Next If Err.Number <> 0 Then MsgBox ""WMI yüklenmemis! Programdan çikilacak "", vbExclamation, _ ""Windows Management Instrumentation"" Exit Sub On Error GoTo 0 End If Set objWMIService = GetObject(""winmgmts:\\"" & strComputerName & ""\"" & strNameSpace) Set Osinf = objWMIService.ExecQuery(""Select * from "" & strClassName) For Each OS In Osinf strManufacturer = ""Üretici Firma = "" & OS.Manufacturer & vbCrLf strRegisteredUser = ""Kayitli Kullanici = "" & OS.RegisteredUser & vbCrLf strSerialNumber = ""Windows Seri Numarasi = "" & OS.SerialNumber & vbCrLf strVersionId = ""Windows Versiyonu ID = "" & OS.Version & vbCrLf strVersionName = ""Windows Versiyonu = "" & OS.Name strServicePack = ""Güncelleme = "" & OS.CSDVersion & vbCrLf strVersionName = Mid(strVersionName, 1, InStr(1, strVersionName, ""|"") - 1) & vbCrLf strInstallDate = ""Windows kurulum tarihi = "" & Left(OS.InstallDate, 4) & ""/"" & Mid(OS.InstallDate, 5, 2) & ""/"" & Mid(OS.InstallDate, 7, 2) & vbCrLf MsgBox strManufacturer & strRegisteredUser & _ strSerialNumber & strVersionId & strVersionName & strServicePack & strInstallDate, _ vbInformation, ""Windows Bilgileri (Raider ®)"" Next End Sub " Word belgesi açma "Sub OuvreWord() MyAppID = Shell(""Winword.EXE C:\test.doc"", 1) AppActivate MyAppID End Sub 'MyAppID = Shell(""Winword.EXE """"C:\Mes documents\test.doc"""""", 1)" Word de fontlar "Sub ShowInstalledFonts() Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer Dim stdFont As String fontSize = 0 fontSize = InputBox(""Enter Sample Font Size Between 8 And 30"", _ ""Select Sample Font Size"", 12) If fontSize = 0 Then Exit Sub If fontSize < 8 Then fontSize = 8 If fontSize > 30 Then fontSize = 30 Set FontNamesCtrl = Application.CommandBars(""Formatting"").FindControl(ID:=1728) If FontNamesCtrl Is Nothing Then Set FontCmdBar = Application.CommandBars.Add(""TempFontNamesCtrl"", _ msoBarFloating, False, True) Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728) End If Application.ScreenUpdating = False fontCount = FontNamesCtrl.ListCount Documents.Add stdFont = ActiveDocument.Paragraphs(1).Range.Font.Name ' add heading With ActiveDocument.Paragraphs(1).Range .Text = ""Installed fonts:"" End With LS 2 ' list font names and font example on every other line For i = 0 To FontNamesCtrl.ListCount - 1 fontName = FontNamesCtrl.List(i + 1) If i Mod 5 = 0 Then Application.StatusBar = ""Listing font "" & _ Format(i / (fontCount - 1), ""0 %"") & "" "" & _ fontName & "" "" With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range .Text = fontName .Font.Name = stdFont End With LS 1 tFormula = ""abcdefghijklmnopqrstuvwxyz"" If Application.International(wdProductLanguageID) = 47 Then tFormula = tFormula & ""æøå"" End If tFormula = tFormula & UCase(tFormula) tFormula = tFormula & ""1234567890"" With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range .Text = tFormula .Font.Name = fontName End With LS 2 Next i ActiveDocument.Content.Font.Size = fontSize Application.StatusBar = False If Not FontCmdBar Is Nothing Then FontCmdBar.Delete Set FontCmdBar = Nothing Set FontNamesCtrl = Nothing ActiveDocument.Saved = True Application.ScreenUpdating = True Application.ScreenRefresh End Sub Private Sub LS(lCount As Integer) ' adds lCount new paragraph(s) at the end of the document Dim i As Integer With ActiveDocument.Content For i = 1 To lCount .InsertParagraphAfter Next i End With End Sub " Word sayfasi olarak Çikti almak "Sub WordAc() fName = Application.InputBox(""Dosya ismi girin "", ""Dosya"") If fName <> 0 Then ActiveSheet.Name = fName Range(""A1:E25"").Copy Set objword = CreateObject(""Word.Application"") objword.Visible = True Set MyDoc = objword.Documents.Add(DocumentType:=wdNewBlankDocument) objword.Selection.PasteSpecial Link:=False, DataType:=10 objword.activedocument.SaveAs ""C:\"" & fName & "".doc"" End If End Sub excelden worde aktarma yapılıyor ama ben worde text olarak yapıştırmak istiyorum ki word biçimlendirmelerini yapabileyim.yani obje olarak değil metin olarak aktarabilirmiyim ' **** DataType:=10 Yukarıdaki data tipini aşağıdaki ile değiştirin. DataType:=2 " Worde veri aktarma "Sub worde() fName = Application.InputBox(""Dosya ismi girin "", ""Dosya"") If fName <> 0 Then ActiveSheet.Name = fName f = InputBox(""Kaçıncı Satıra Kadar Aktarsın?"", ""Aktarılacak Bölge"") Range(""A1: ı"" & f).Copy Set objword = CreateObject(""Word.Application"") objword.Visible = True Set MyDoc = objword.Documents.Add(DocumentType:=wdNewBlankDocu ment) objword.Selection.PasteSpecial Link:=False, DataType:=2 objword.activedocument.SaveAs ""C:\"" & fName & "".doc"" End If Application.CutCopyMode = False End Sub" Wordpad'a yazdırmak istediğiniz bir metni excel içerisinden yazdırmak için "Private Sub Workbook_Open() wpad = Shell(""C:\Program Files\Windows NT\Accessories\wordpad.exe"", vbNormalFocus) SendKeys ""Excelden başka programa yazdırabiliyorum"", True SendKeys ""{enter}"" SendKeys ""Excel 'i {tab}Seviyorum"", True SendKeys ""{enter}"" SendKeys ""Yaşasınnnn!!!!"", True End Sub Hatta kodun sonuna printout yazıp yazıcı çıktısı da alınabilir. Bu kodu fikirlerinizle daha da geliştirip harikalar yaratabilirsiniz. SendKeys Tuş Kodlarından Bazıları Backspace = {bksp} caps lock = {capslock} num lock = {numlock} scroll lock = {scrolllock} insert = {ins} delete = {del} end = {end} home = {home} page up = {pgup} page down= {pgdn} sağ ok = {right} sol ok = {left} alt ok = {down} üst ok = {up} tab = {tab} F1 = {F1} F2 = {F2} F3 .. " Workarea1 isimli hücreyi 0 yapar "Sub ResetValuesToZero2() For Each n In Worksheets(""Mahmut"").Range(""WorkArea1"") n.Value = 0 End If Next n End Sub" Workbook ta yazdırma komutu "Private Sub Workbook_BeforePrint(Cancel As Boolean) 'J.E. McGimpsey http://www.mcgimpsey.com/excel/noprintrange.html Dim vFontArr As Variant Dim oWkSht As Worksheet Dim rNoPrintRange As Range Dim rCell As Range Dim rArea As Range Dim i As Long Dim bOldScreenUpdating As Boolean Cancel = True With Application .EnableEvents = False bOldScreenUpdating = .ScreenUpdating .ScreenUpdating = False End With For Each oWkSht In ActiveWindow.SelectedSheets On Error Resume Next Set rNoPrintRange = oWkSht.Range(""NoPrintRange"") On Error GoTo 0 If Not rNoPrintRange Is Nothing Then With rNoPrintRange ReDim vFontArr(1 To .Count) i = 1 For Each rArea In .Areas For Each rCell In rArea With rCell vFontArr(i) = .Font.ColorIndex If .Interior.ColorIndex = xlColorIndexNone Then .Font.Color = RGB(255, 255, 255) 'white Else .Font.ColorIndex = .Interior.ColorIndex End If i = i + 1 End With Next rCell Next rArea oWkSht.PrintOut i = 1 For Each rArea In .Areas For Each rCell In rArea rCell.Font.ColorIndex = vFontArr(i) i = i + 1 Next rCell Next rArea End With Else oWkSht.PrintOut End If Set rNoPrintRange = Nothing Next oWkSht With Application .ScreenUpdating = bOldScreenUpdating .EnableEvents = True End With End Sub" Workbook_addininstall "Private Sub Workbook_AddinInstall() CmdNommer End Sub Private Sub Workbook_AddinUninstall() DelNommer End Sub Public Const Nommer = ""Définir un nom "" Sub CmdNommer() Dim cBar As CommandBar, Ctrl As CommandBarButton Set cBar = Application.CommandBars(""Cell"") Set Ctrl = cBar.Controls.Add(msoControlButton, ID:=878, before:=1) With Ctrl .Caption = Nommer .FaceId = 1838 .Style = msoButtonIconAndCaption End With End Sub Sub DelNommer() On Error Resume Next Application.CommandBars(""Cell"").Controls(Nommer).Delete End Sub" X Şeklİnde uyari penceresİ " X şeklinde uyarı penceresi Kod: Sub auto_open() Beep MsgBox ""Mesaj Buraya!!"", vbCritical, ""Önemli"" End Sub " Xla dosyasındaki eklenti disable etmek "Sub Test() Workbooks(""pirsa.xla"").IsAddin = False End Sub" Xls dosyaları okuyup içinden veri almak için "z = ""C:\belgelerim\"" Set fs = Application.FileSearch With fs .LookIn = z .Filename = ""*.xls"" If .Execute(SortBy:=msoSortByFileName, _ SortOrder:=msoSortOrderAscending) > 0 Then MsgBox ""Toplam "" & .FoundFiles.Count & _ "" dosya bulundu."" For I = 1 To .FoundFiles.Count ' MsgBox .FoundFiles(i) A$ = .FoundFiles(I) Next I Else MsgBox ""Belirtilen Klasörde Herhangi Bir Dosya Bulunamadı."" End If End With" Yalniz ÇaliŞma sayfasi kaydetme "Aşağıdaki kodu deneyin. Bu kod active sayfayı yeni bir dosyaya aktarır ve o dosyayı açık olan dosyanızın bulunduğu klasöre kaydedip kapatır. Sub kopyala() ad = ActiveWorkbook.Name adr = ActiveWorkbook.Path Workbooks.Add ad2 = ActiveWorkbook.Name Set s1 = Workbooks(ad2) Workbooks(ad).Activate ActiveSheet.Copy after:=s1.Sheets(s1.Sheets.Count) For a = 1 To s1.Sheets.Count - 1 Application.DisplayAlerts = False s1.Sheets(1).Delete Next s1.SaveAs Filename:=adr & ""\"" & s1.Name & "".xls"" s1.Close End Sub" Yanıp sönme "Sub FlashFont() 'Joe Was 'Make cell range font flash, x times, x fast, in x color, 'when Ctrl-z is pressed. Dim newColor As Integer Dim myCell As Range Dim x As Integer Dim fSpeed 'Make this cell range font flash! Set myCell = Range(""A1:AF12"") Application.DisplayStatusBar = True Application.StatusBar = "" Şu an flash yazı gösterisi var lütfen biraz bekleyin ! "" 'Make cell font flash to this color! 'Black 25, Magenta 26, Yellow 27, Cyan 28, Violet 29, Dark Red 30, 'Teal 31, Blue 32, White 2, Red 3, Light Blue 41, Dark Blue 11, 'Gray-50% 16, Gray-25% 15, Bright Cyan 8. newColor = 3 'Make the cell range flash fast: 0.01 to slow: 0.99 fSpeed = 0.3 'Make cell flash, this many times! Do Until x = 15 'Run loop! DoEvents Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Font.ColorIndex = newColor Loop Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Font.ColorIndex = xlAutomatic Loop x = x + 1 Loop Application.StatusBar = False Application.DisplayStatusBar = Application.DisplayStatusBar End Sub Sub reSetFlash() 'Re-set cell range color if edit break on color, Ctrl-r to re-set! ActiveCell.Select Selection.Interior.ColorIndex = xlNone End Sub" Yanıp sönme efekti "Sub CheckRng() If Range(""B1"") < Date Then If Range(""B1"").Font.ColorIndex = xlColorIndexAutomatic Then Range(""B1"").Font.Color = vbRed Else Range(""B1"").Font.ColorIndex = xlColorIndexAutomatic End If Else Range(""B1"").Font.ColorIndex = xlColorIndexAutomatic Exit Sub End If StartTimer End Sub" Yapilan kaydi hafizada tutma "Alıntı: For i = 1 To 10 ComboBox1.AddItem i Next i ile combobox ın içini 1 den 10 kadar doldurdum. combobox ın değeri değiştiği an ilgili satırdan değerleri textboxlara alı aşağıdaki gibi yaptım. Alıntı: Private Sub ComboBox1_Change() TextBox1.Text = Sheets(""sayfa1"").Cells(4 + ComboBox1, 2) TextBox2.Text = Sheets(""sayfa1"").Cells(4 + ComboBox1, 3) TextBox3.Text = Sheets(""sayfa1"").Cells(4 + ComboBox1, 4) End Sub yukarıdaki 4 + ComboBox1 deki 4 seini verilerin 5. satırdan itibaren başladığı için eklendi. kaydete basıldığında ilgili satırdaki değişikleri yapta aşağıdaki şekilde. Alıntı: Private Sub CommandButton1_Click() Sheets(""sayfa1"").Cells(4 + ComboBox1, 2) = TextBox1.Text Sheets(""sayfa1"").Cells(4 + ComboBox1, 3) = TextBox2.Text Sheets(""sayfa1"").Cells(4 + ComboBox1, 4) = TextBox3.Text Sheets(""sayfa1"").Cells(4 + ComboBox1, 5) = TextBox2.Text * TextBox3.Text End Sub yukarıdaki 4 lerin sebebini yukarıda söyledim." Yaş bulma yıl, ay, gün olarak "Function yas(dogum) On Error GoTo son Dim yil, ay, gun As Integer tarih = Date If dogum <> """" Then dogum = CDate(dogum) If dogum = """" Then yas = """": GoTo son: If dogum > tarih Then yas = """": GoTo son 'yil hesaplama yil = Year(tarih) - Year(dogum) If Month(tarih) < Month(dogum) Then yil = yil - 1 If Month(tarih) = Month(dogum) And Day(tarih) < Day(dogum) Then yil = yil - 1 'Ay ay = Month(tarih) - Month(dogum) If Month(tarih) <= Month(dogum) Then ay = 12 + ay If Day(tarih) < Day(dogum) Then ay = ay - 1 If ay = 12 Then ay = 0 'gün kacceker = Day((DateSerial(Year(tarih), Month(tarih), 1) - 1)) gun = Day(tarih) - Day(dogum) If Day(tarih) < Day(dogum) Then gun = kacceker - Day(dogum) + Day(tarih) yas = yil & "" Yıl, "" & ay & "" Ay, "" & gun & "" gün."" son: If Err > 0 Then yas = ""Hata"" End Function " Yaş hesaplama "Function Yaş(DogumTarihi As Date) If DogumTarihi = 0 Then Yaş = ""Tarih Girmediniz"" Else Select Case Month(Date) Case Is < Month(DogumTarihi) Yaş = Year(Date) - Year(DogumTarihi) - 1 Case Is = Month(DogumTarihi) If Day(Date) >= Day(DogumTarihi) Then Yaş = Year(Date) - Year(DogumTarihi) Else Yaş = Year(Date) - Year(DogumTarihi) - 1 End If Case Is > Month(DogumTarihi) Yaş = Year(Date) - Year(DogumTarihi) End Select End If End Function bu fonksiyona göre doğum tarihinin a1 hücresinde olduğunu varsayarsak formül şu şekilde olacak =Yaş(A1)" Yaş hesaplama ve mesajla bildirim " Dim DoğumGünü As Date Dim Yaş DoğumGünü = ""01/01/1977"" Yaş = FormatNumber(DateDiff(""m"", DoğumGünü, Now) / 12, 1) If Yaş < 18 Then MsgBox ""Yaş: "" & Yaş & vbLf & ""18 yaşıdan küçük"" Else MsgBox ""Yaş: "" & Yaş & vbLf & ""18 yaşıdan büyük"" End If" Yatay ve dİkey saydirma "Sub tabloyaaktar() Set s1 = Sheets(""bilgi"") Set s2 = Sheets(""sonuc"") s2.[c3:ag40].ClearContents For a = 2 To s1.[a65536].End(3).Row sat = Day(s1.Cells(a, ""a"")) + 2 sut = Day(s1.Cells(a, ""b"")) + 2 s2.Cells(sat, sut) = 1 + s2.Cells(sat, sut) Next End Sub" Yazdıracağınız satır ve sütunları manuel olarak seçebileceğiniz kodlar "Sub FixArea() Dim C As Range Dim Msg$, TMP$ Msg = ""Type in the range to exclude:"" Set C = Application.InputBox(prompt:=Msg, Type:=8) TMP = C.NumberFormat C.NumberFormat = "";;;"" ActiveSheet.Range(""A1:A50"").PrintPreview C.NumberFormat = TMP End Sub" Yazdırılacak alanın boşluk olmadan "Bir sutun da ki en son dolu hücreye gitmenin en basit yolu (Aralarda boşluk yok 'kabul edilerek) xlup 'Buna göre I sütununun en son dolu olan satırı Range(""I65536"").End(xlUp).Row 'Yazdırılacak alan ise ActiveSheet.PageSetup.PrintArea = ""$A$3:$I$"" & Range(""I65536"").End(xlUp).Row 'veya Sub yazdirmaalani() Range(""A1:B16).Select ActiveSheet.PageSetup.PrintArea = Selection.Address End Sub" Yazdırma alanı seçme "Sub yazalanı_seç() bilgi = ""Yazdırmak istediğiniz hücre aralığını girin. "" bilgi = bilgi + ""Size uygun olanını yazmak için silin ve yazın."" + Chr$(13) + Chr$(10) bilgi = bilgi + ""TAMAM'a tıklayın."" + Chr$(13) + Chr$(10) bilgi = bilgi + ""İPTAL veya ESC basarsanız bütün tabloyu seçersiniz."" + Chr$(13) + Chr$(10) düğme = ""A12:K40"" a$ = InputBox(bilgi, ""YAZDIRMA ALANINI SEÇMEK"", düğme) ActiveSheet.PageSetup.PrintArea = a$ ActiveWindow.SelectedSheets.PrintPreview Range(""A13"").Select End Sub" Yazdırma alanı varsa bulur ve mesajla belirtir "Sub Recupzone() Set zoneIMP = Range(ActiveSheet.PageSetup.PrintArea) MsgBox zoneIMP.Address() End Sub" Yazdırma alanını a3:f15 yapar ve yinelenecek satırı da seçer ve yazdırır "Sub PrintRpt3() With Worksheets(""Sayfa1"").PageSetup .CenterHorizontally = True .PrintArea = ""$A$3:$F$15"" .PrintTitleRows = (""$A$1:$A$2"") .Orientation = xlPortrait .FitToPagesWide = 1 .FitToPagesTall = 1 End With Worksheets(""Sayfa1"").PrintOut End Sub" Yazdırma alanını bulma "If ActiveSheet.PageSetup.PrintArea = """" Then MsgBox ""Yazdırma alanı yok"" Else MsgBox ""Yazdırma Alanı: "" & ActiveSheet.PageSetup.PrintArea End If" Yazdırmak için süzme şart olsun "Private Sub Workbook_BeforePrint(Cancel As Boolean) If Cells(1, 1) <> 1 Then Cancel = True End Sub 'Bu örnek A1 hücresi 1 den farklı ise yazdırmayı iptal eder" Yazdırmak için süzme şart olsun 2 "Aşğıdaki kod filter yaptığın tüm alanlara bakarak en az birinde seçim yapılmış ise sayfayı gönderir aksi halde mesaj verir.. Set s1 = ActiveSheet Secilmiş = False If s1.AutoFilterMode = True Then For i = 1 To s1.AutoFilter.Filters.Count If s1.AutoFilter.Filters.Item(i).On Then Secilmiş = True Next i If Not Secilmiş Then MsgBox ""Hiç Bir Süzme İşlemi Yapılamış"" Cancel = True End If End If 'Tarih alanınız 4. sutun ise ve siz burada mutlaka bir seçim olmasını istiyorsanız o zaman döngü kullanmadan şunu deneyin : s1.AutoFilter.Filters.Item(4).On Then Secilmiş = True '4 alanda seçim yapılıp yapılmadığını kontrol ediyor." Yazdırmayı engelle (üzgünüz çıktı almak yasak) "Private Sub Workbook_BeforePrint(Cancel As Boolean) Cancel = True MsgBox (""üzgünüz çıktı almak yasak"") End Sub" Yazdırmayı engelleme "Private Sub Workbook_BeforePrint(Cancel As Boolean) If ActiveSheet.Name = ""Sheet1"" Then Cancel = True End Sub " Yazdir butonu sayfa yazdirilacak, Önİzleme yapmak İstİyor musunuz "Private Sub yaz_Click() On Error Resume Next soru = MsgBox(""Sayfa Yazdırılacak, Önizleme Yapmak İstiyor musunuz?"", vbYesNo, ""Önizleme"") If soru = vbYes Then DataAc.Hide Sheets(""Print"").PrintPreview DataAc.Show Range(""A1"").Select Else Sheets(""Print"").PrintOut End If End Sub " Yazdirma alani bellİ ama sadece İÇİ dolu olan hÜcrelerİn İÇİnİ nasil yazdirabİlİrİm. "Sub yazdir() ActiveSheet.PageSetup.PrintArea = ""$A$2:$C$"" & [a65536].End(3).Row ActiveSheet.PrintOut End Sub" Yazdirma alani seÇİp yazdirmak. "ActiveSheet.PageSetup.PrintArea = ""$B$1:$F$50"" ActiveSheet.PrintOut Copies:=1 " Yazı tipi kalınlığını ayarlama "Sub FormatRange() Workbooks(""Kitap1"").Sheets(""Sayfa1"").Range(""A1:D5"") _ .Font.Bold = True End Sub" Yazıcı penceresi "Sub ChangePrinter() Application.Dialogs(xlDialogPrinterSetup).Show End Sub" Yazıcı test etme "Sub LanceTestImp() ValRetour = Shell(""C:\WINDOWS\RUNDLL32.EXE msprint2.dll,RUNDLL_PrintTestPage"", 1) End Sub" Yazıcıdan çıktı alma kopya sayısını siz belirleyin "Sub PrintOnePage() Dim wshTemp As Worksheet, wsh As Worksheet Dim rngArr() As Range, c As Range Dim i As Integer Dim j As Integer ReDim rngArr(1 To 1) For Each wsh In ActiveWorkbook.Worksheets i = i + 1 If i > 1 Then ' resize array ReDim Preserve rngArr(1 To i) End If On Error Resume Next Set c = wsh.Cells.SpecialCells(xlCellTypeLastCell) If Err = 0 Then On Error GoTo 0 'Prevent empty rows Do While Application.CountA(c.EntireRow) = 0 _ And c.EntireRow.Row > 1 Set c = c.Offset(-1, 0) Loop Set rngArr(i) = wsh.Range(wsh.Range(""A1""), c) End If Next wsh 'Add temp.Worksheet Set wshTemp = Sheets.Add(after:=Worksheets(Worksheets.Count)) On Error Resume Next With wshTemp For i = 1 To UBound(rngArr) If i = 1 Then Set c = .Range(""A1"") Else Set c = _ ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell) Set c = c.Offset(2, 0).End(xlToLeft) ' skip one row End If 'Copy-paste range (prevent empty range) If Application.CountA(rngArr(i)) > 0 Then rngArr(i).Copy c End If Next i End With On Error GoTo 0 Application.CutCopyMode = False ' prevent marquies With ActiveSheet.PageSetup ' Fit to 1 page .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With 'Preview New Sheet ActiveWindow.SelectedSheets.PrintPreview 'Print Desired Number of Copies i = InputBox(""Print how many copies?"", ""ExcelTips"", 1) If IsNumeric(i) Then If i > 0 Then ActiveSheet.PrintOut Copies:=i End If End If 'Delete temp.Worksheet? If MsgBox(""Delete the temporary worksheet?"", _ vbYesNo, ""ExcelTips"") = vbYes Then Application.DisplayAlerts = False wshTemp.Delete Application.DisplayAlerts = True End If End Sub" Yazıcınızın markasını a1 hücresine yazdır. (Api) "Private Declare Function EnumPrintersA Lib ""Winspool.drv"" _ (ByVal Flags As Long, ByVal name As String, ByVal Level As Long, _ pPrinterEnum As Long, ByVal cdBuf As Long, _ pcbNeeded As Long, pcReturned As Long) As Long Private Declare Function lstrlenA Li" Yazım denetimi türkçe, matematik terimleri "Option Explicit Sub AutoCorrectRead() Dim oList As Variant, i As Integer With Application.AutoCorrect oList = .ReplacementList For i = 1 To UBound(oList) Cells(i, 1) = oList(i, 1) Cells(i, 2) = oList(i, 2) Next i End With End Sub Sub AutoCorrectWrite() Columns(""A:B"").Sort Key1:=Range(""A1""), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Range(""G20"").Select Dim i As Integer With Application.AutoCorrect For i = 1 To Range(""a1"").CurrentRegion.Rows.Count .AddReplacement Cells(i, 1), Cells(i, 2) Next i End With End Sub" Yazım denetimindeki kelimelerin listesi "Option Explicit 'Mahmut Bayram 2005 Sub AutoCorrectRead() 'zum Auslesen, danach Tabelle zum Zielrechner Dim oList As Variant, i As Integer With Application.AutoCorrect oList = .ReplacementList For i = 1 To UBound(oList) Cells(i, 1) = oList(i, 1) Cells(i, 2) = oList(i, 2) Next i End With End Sub" Yazi anİmasyonu "WORD ARD YAZILARINA HAREKET VERİR Sub Animasyon3() ActiveSheet.Shapes(""WordArt 3"").Select m = 20 For i = 1 To m Selection.ShapeRange.TextEffect.PresetShape = msoTextEffectShapeCurveUp Next i For i = 1 To m Selection.ShapeRange.TextEffect.PresetShape = msoTextEffectShapeCurveDown Next i Selection.ShapeRange.TextEffect.PresetShape = msoTextEffectShapePlainText Range(""a1"").Select End Sub " Yazi tipleri penceresi "Sub Dialog_29() Application.Dialogs(xlDialogFont).Show End Sub Sub Dialog_31() Application.Dialogs(xlDialogFormatFont).Show End Sub" Yazi tiplerini örnekli listele "Sub yazitipleri() Dim SchrNr As Integer, Schriftliste As Object, Text As Variant Set Schriftliste = Application.CommandBars(""formatting"").FindControl(Id:=1728) Application.ScreenUpdating = False On Error Resume Next [A:D].ClearContents For SchrNr = 0 To Schriftliste.ListCount - 1 Cells(SchrNr + 1, 1).Value = Schriftliste.List(SchrNr + 1) Cells(SchrNr + 1, 2).Value = ""€"" 'Eurosymbol Cells(SchrNr + 1, 3).Value = ""abcdefghijklmnopqrstuvwxyzäöü"" Cells(SchrNr + 1, 4).Value = ""ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜ"" Cells(SchrNr + 1, 2).Font.Name = Schriftliste.List(SchrNr + 1) Cells(SchrNr + 1, 3).Font.Name = Schriftliste.List(SchrNr + 1) Cells(SchrNr + 1, 4).Font.Name = Schriftliste.List(SchrNr + 1) Next [A:D].EntireColumn.AutoFit Application.ScreenUpdating = True ' Warnmeldung zuviele Schriften hier einstellbar: If SchrNr > 200 Then Text = Chr(13) & Chr(13) & ""Achtung!"" & Chr(13) & _ ""Sie haben viel zu viele Schriftarten installiert"" End If MsgBox "" Es wurden insgesamt "" & SchrNr & "" Schriftarten gefunden."" _ & Chr(13) & ""Im Feld mit der Roten Schrift sieht man das Eurosymbol,"" _ & Chr(13) & "" wenn die Schrift Eurofähig ist,"" _ & Chr(13) & "" sonst nur ein Kästchen"" & Text End Sub" Yazilar İÇerİsİnde kirmizi renk var İse bulabİlİrmİyİz? "Sub Kırmızıbul() For X = 1 To [A65536].End(3).Row For Y = 1 To Len(Cells(X, 1)) If Cells(X, 1).Characters(Start:=Y, Length:=Y).Font.ColorIndex = 3 Then Cells(X, 2).Value = ""Kırmızı"" End If Next Next End Sub" Yazilari yanip sÖndÜrme "BU KOD VERİLEN ADRESTEKİ YAZILARI YANIP SÖNDÜRÜR Sub FlashFont() Dim newColor As Integer Dim myCell As Range Dim x As Integer Dim fSpeed Set myCell = Range(""A1:D1"") Application.DisplayStatusBar = True Application.StatusBar = "" Şu an flash yazı gösterisi var lütfen biraz bekleyin ! "" newColor = 4 'yeşil fSpeed = 0.3 Do Until x = 15 'süre DoEvents Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Font.ColorIndex = newColor Loop Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Font.ColorIndex = xlAutomatic Loop x = x + 1 Loop Application.StatusBar = False Application.DisplayStatusBar = Application.DisplayStatusBar End Sub " Yedek alma İle İlgİlİ "Private Sub CommandButton3_Click() Dim dsy dsy = InputBox(""Lütfen LEAD TIME'a ait ayın adını giriniz?"", ""Lead Time Dosyası Oluşturma"", Format(Now, ""mmmm_yyyy"")) If dsy = Cancel Then Exit Sub On Error GoTo 10 MkDir ""C:\LEAD TİME\"" & dsy Set NewBook = Workbooks.Add With NewBook .SaveAs ""C:\LEAD TİME\"" & dsy & ""\"" & ""Lead_time_"" & dsy & "".xls"" End With Windows(""LEAD TİME.xls"").Activate Cells.Select Selection.Copy Windows(""Lead_time_"" & dsy & "".xls"").Activate ActiveSheet.Paste Range(""A2"").Select Range(""Z1:AG9"").Select Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft Range(""A2"").Select ActiveWorkbook.Save ActiveWorkbook.Close Windows(""LEAD TİME.xls"").Activate Range(""A2"").Select ActiveWorkbook.Save Unload UserForm1 Exit Sub 10: MsgBox ""Dosya ismini kontrol edip tekrar deneyiniz."", vbExclamation, ""UYARI!!!!!!!"" End Sub" Yedek alma şifreleyerek "Sub Datensicherung() Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=""C:\Datensicherung.xls"", _ FileFormat:=xlNormal, Password:="""", WriteResPassword:="""", _ ReadOnlyRecommended:=False, CreateBackup:=False Application.DisplayAlerts = True End Sub" Yedek alma tarihli "Sub date_backup() zaman = Application.Text(Now(), ""mm-dd-yy hh-mm"") isim = ""Yedek"" & zaman & "".XLS"" ActiveWorkbook.SaveCopyAs isim End Sub" Yeni araç çubuğu ekleme "Sub NeueSymbolleiste() Dim cmdB As CommandBar Set cmdB = CommandBars.Add(""MyToolbar"", temporary:=True) With cmdB .Left = 50 .Top = 100 .Visible = True End With End Sub" Yeni belge açma penceresi "Sub Dialog_43() Application.Dialogs(xlDialogNew).Show End Sub" Yeni belge aöma penceresi "Sub Dialog_45() Application.Dialogs(xlDialogOpen).Show End Sub" Yenİ bİr sayfa oluŞturmak ve o sayfaya İsİm vermek. "Sub Sayfa_Ekle() ThisWorkbook.Sheets.Add Sheets(ActiveSheet.Name).Name =sheets(""sayfa1""). [a1].value End Sub " Yenİ ÇaliŞma sayfasi aÇarken bİÇİmlİ sayfayi kopyalama "Kopyalama için aşağıdaki kodu deneyin. visual basic kodu: Sub kopyala() Sheets(""Sayfa1"").Copy After:=Workbooks(""Kitap1"").Sheets(1) End Sub " Yeni kitap açar "Sub CreateWindow() Dim wnParent As Window Dim wnChild As Window 'make a reference to be used later Set wnParent = ActiveWindow 'create a new window that will be the smaller window wnParent.NewWindow Set wnChild = ActiveWindow 'change the size of the windows With Application wnChild.WindowState = xlNormal wnChild.Top = .Top + (.Height * 0.2) wnChild.Height = .Height * 0.4 wnChild.Left = .Left + .Width * 0.6 wnChild.Width = .Width * 0.35 wnParent.Top = 1 wnParent.Left = 1 wnParent.Height = .Height * 0.85 wnParent.Width = .Width * 0.95 End With End Sub" Yeni kitap oluşturma kitabın ismiyle başlayan ve birer artan kitap oluşturur "Private Sub Workbook_NewSheet(ByVal Sh As Object) Sh.Move After:=Sheets(Sheets.Count) End Sub" Yenİ tl ve kuruŞa Çevİr "Public Function ParaCevir(Para) Dim ParaStr As String Dim Lira As String, Kurus As String If Not IsNumeric(Para) Then GoTo SayiDegil ParaStr = Format(Abs(Para), ""0.00"") Lira = Left(ParaStr, Len(ParaStr) - 3) Kurus = Right(ParaStr, 2) ParaCevir = IIf(Para < 0, ""Eksi "", """") & Cevir(Lira) & "" Lira "" & Cevir(Kurus) & "" Kuruş"" Exit Function SayiDegil: ParaCevir = ""GİRİLEN DEÃER SAYI DEÃİL!"" End Function Private Function Cevir(SayiStr As String) As String Dim Rakam(15) Dim c(3), Sonuc, e Birler = Array("""", ""bir"", ""iki"", ""üç"", ""dört"", ""beş"", ""altı"", ""yedi"", ""sekiz"", ""dokuz"") Onlar = Array("""", ""on"", ""yirmi"", ""otuz"", ""kırk"", ""elli"", ""altmış"", ""yetmiş"", ""seksen"", ""doksan"") Binler = Array(""trilyon"", ""milyar"", ""milyon"", ""bin"", """") SayiStr = String(15 - Len(SayiStr), ""0"") + SayiStr For i = 1 To 15 Rakam(i) = Val(Mid$(SayiStr, i, 1)) Next i Sonuc = """" For i = 0 To 4 c(1) = Rakam(i * 3 + 1) c(2) = Rakam(i * 3 + 2) c(3) = Rakam(i * 3 + 3) If c(1) = 0 Then e = """" ElseIf c(1) = 1 Then e = ""yüz"" Else e = Birler(c(1)) + ""yüz"" End If e = e + Onlar(c(2)) + Birler(c(3)) If e <> """" Then e = e + Binler(i) If (i = 3) And (e = ""birbin"") Then e = ""bin"" Sonuc = Sonuc + e Next i If Sonuc = """" Then Sonuc = ""Sıfır"" Cevir = UCase(Mid(Sonuc, 1, 1)) + Mid(Sonuc, 2, Len(Sonuc) - 1) End Function " Yeni web sorgusu alma penceresi "Sub Dialog_44() Application.Dialogs(xlDialogNewWebQuery).Show End Sub" Yer tanımlama makrosu "Sub ilan() yer = Worksheets(""OkBil"").Range(""j5"").Value 'yer tanımlama sihirbazı OkBil sayfasında seç j5 hücresini seç MsgBox "" Sayın "" & yer & "" pirs@1.00 Programına Hoş Geldiniz!"" 'mesaj ver Başına Sayın koy birleştir(&) tanımlı yer ile birleştir(&) evrağınız gelen-giden evrak defterine kayıt edilmiştir. End Sub" Yerİnİ deĞİŞtİrene aŞkolsun. (Hareket ettİrİlemeyen userform) "Private Sub UserForm_Layout() ' Von Bert Körn ' http://www.forum.excelabc.de/ Me.Move Application.Width / 2 - Me.Width / 2, Application.Height / 2 - Me.Height / 2 End Sub" Yıl ekleme "A1'de tarih B1'de kaç yıl ekleneceği olmalı Sub PratikVB1() MsgBox Format(Day([A1]), ""00"") & ""."" & Format(Month([A1]), ""00"") & ""."" & Year([A1]) + [B1] End Sub Sub PratikVB2() MsgBox Day([A1]) & ""."" & Month([A1]) & ""."" & Year([A1]) + [B1] End Sub " Yıldızlı efektler "Sub ShowStars() Cells.Select Selection.Interior.ColorIndex = 1 Range(""A1"").Select Randomize StarWidth = 35 StarHeight = 35 For i = 1 To 10 TopPos = Rnd() * (ActiveWindow.UsableHeight - StarHeight) LeftPos = Rnd() * (ActiveWindow.UsableWidth - StarWidth) Set NewStar = ActiveSheet.Shapes.AddShape _ (msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight) NewStar.Fill.ForeColor.SchemeColor = Int(Rnd() * 56) Application.Wait Now + TimeValue(""00:00:01"") DoEvents Next i Application.Wait Now + TimeValue(""00:00:02"") Set myShapes = Worksheets(1).Shapes For Each shp In myShapes If Left(shp.Name, 9) = ""AutoShape"" Then shp.Delete Application.Wait Now + TimeValue(""00:00:01"") End If Next Cells.Select Selection.Interior.ColorIndex = 2 Range(""A1"").Select End Sub" Yılı yaz sayfalara ayları ekler "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 "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? "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 İstermisiniz "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 İstermİsİnİz "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 "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 "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 "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 "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 "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 <= 60 End Sub 2) 60 saniye saydıktan sonra tekrar başlaması için; Kod: Sub Test2() ResumeSub: Start = Timer Do DoEvents Finnish = Timer [a1] = Format(Finnish - Start, ""00"") Loop While Finnish - Start <= 60 GoTo ResumeSub: End Sub " Zamanlamalı userform "Private Sub UserForm_Activate() Application.OnTime Now + TimeValue(""00:00:05""), ""KillTheForm"" End Sub" Zamanlamalı userform 2 "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 " Zamanlanmİs makro ontİme ? "Sub tarih() Application.OnTime Now + [a1], procedure:=""zaman"" End Sub Sub zaman() Application.OnTime TimeValue(""12:00:00""), ""makro""' End Sub " Bu, http://www.excel.gen.tr/ için Google'ın önbelleğidir. Bu, sayfanın 14 Ara 2010 20:54:25 GMT tarihine ait anlık görüntüsüdür. Aradan geçen süre zarfında geçerli sayfa değişmiş olabilir. Daha fazla bilgi Salt metin sürümü Şu arama terimleri vurgulanmaktadır: excel Anasayfa Akademik Forum Sizden Gelenler Sipariş Neler Yaptık Eğitimlerimiz Yazar Girişi İletişim Çok Okunanlar Excel Makroları'na Giriş Eğitimlerimizden Bazıları Excel'i Doğru Tanımlamak Bul - Değiştir EĞER Ürünlerimizi Alan Sektörler(Diğer Sektörler) iletişim Yan Yana Yazılı Olan Bilgileri Alt Alta Yazma Son Eklenenler NESNELER-TEXTBOX Yan Yana Yazılı Olan Bilgileri Alt Alta Yazma BUL ASC YANLIŞ YADA VE EĞER Duyurular - Forum Sitemiz : www.hesaptablosu.com www.hesaptablosu.gen.tr www.hesaptablosu.web.tr Alış Veriş Sitemiz www.office.gen.tr/ www.office.web.tr/ SOL MENÜ Makaleler M.Temel KORKMAZ Cemil Gökmen Çeşitli Makaleler Sorular Cevaplar Makro işlev Genel Yerleşik İşlevler Mantıksal Metin Makrolara Giriş Dosya İndir MTK Programları Diğer Animasyon Sizden Gelenler Yumurtalar Değişken Alan Adları Tanımlamak Excel listeleri ile çalışırken çoğu zaman tablolardaki veri sayısı değişken nitelik taşımakta, yani satır ve/veya sütun bazında artış veya azalışlar gösterebilmektedir. Hal böyle olunca da bu tablo dizisini referans alan formül ve özet tablo başvuruları gibi unsurlarda da değişiklikler yapmak gerekmektedir. Çünkü bu değişikliklerin yapılmaması hatalı sonuçlar elde edilmesine neden olabilmektedir. Excel’de dinamik alan tanımlamaları yaparak bu durumu ortadan kaldırmak, veri tablosunda değişiklik olsa bile bu tabloya yapılan başvuruların da bu değişimlere duyarlı hale getirerek doğru sonuçlar üretmeyi sürdürmesini sağlamak mümkündür. Dinamik alanlar tanımlayabilmek bazı yerleşik işlevler ile desteklenmiş olarak Excel’in “Ad Tanımlama” özelliğinden faydalanılmaktadır. Şekil-1’deki gibi bir liste oluşturalım. Şekil-1 Devamını oku Google Reklamları Anket Excel'i hangi dilde kullanıyorsunuz Türkçe İngilizce Türkçe - İngilizce Diğer Bulundurma: Bilgisayarcı Amca Sitemize Ziyaret için tıklayın Bu siteyi, "Hayatını çocuklarının Ahlâklı ve Dürüst yetişmesi için harcamış olan Cefakar ve Fedakar, Canım ANNEM'e adadım." Copyright © 1998-2010 M. Temel Korkmaz - Tüm hakları saklıdır.Değişken Alan Adları Tanımlamak Excel listeleri ile çalışırken çoğu zaman tablolardaki veri sayısı değişken nitelik taşımakta, yani satır ve/veya sütun bazında artış veya azalışlar gösterebilmektedir. Hal böyle olunca da bu tablo dizisini referans alan formül ve özet tablo başvuruları gibi unsurlarda da değişiklikler yapmak gerekmektedir. Çünkü bu değişikliklerin yapılmaması hatalı sonuçlar elde edilmesine neden olabilmektedir. Excel’de dinamik alan tanımlamaları yaparak bu durumu ortadan kaldırmak, veri tablosunda değişiklik olsa bile bu tabloya yapılan başvuruların da bu değişimlere duyarlı hale getirerek doğru sonuçlar üretmeyi sürdürmesini sağlamak mümkündür. Dinamik alanlar tanımlayabilmek bazı yerleşik işlevler ile desteklenmiş olarak Excel’in “Ad Tanımlama” özelliğinden faydalanılmaktadır. Şekil-1’deki gibi bir liste oluşturalım. Residential Small Office Business Partners Carrier Excel.com Login Contact Excel Online Bill Pay Small & Medium Businesses If you are ready to accelerate your business you should be talking to us. Our Excel-Your-Business seminar series will teach you the tips and tricks of online marketing, and our cutting edge products for tracking marketing ROI online and offline are must haves. Learn More Partners By making small and medium sized businesses one of our primary targets, we have developed our products and services in a way that makes them easy, affordable, and accessible to these businesses. From our one page bill, to our solid communications infrastructure, to the aggregated services we bring within reach, we are in this to help businesses thrive! Learn More Carrier Whether you are new to the market or have years of industry experience, Excel can help enhance your product offering and ultimately increase your profitability. As a stable and experienced provider, Excel offers carriers a wide range of services supported by one of the most dependable networks in the United States. Learn More Residential Excel offers great rates on local and long distance service. We have several plans to choose from so that you can pick the plan that will meet your individual needs. Learn More Small & Medium Businesses | Residential | Carrier | Partners | About Excel | News | Promotions | Careers | Site Map Privacy Policy | Terms & Conditions | Legal Notices | 911 Policy Copyright 2007-2008 Excel Telecommunications Home Local Long Distance VoIP Unlimited Lifeline Internet Pay My Bill Contact Excel Live Support Excel.com Home Excel Residential Excel Telecommunications, VarTec Telecom, and Clear Choice Communications are part of the same corporate family. Learn More (boxes not included) Local You can find out more information and order Excel local service by calling 1-877-668-0808. If you are a local voicemail customer you can access the voicemail quick guide here. Long Distance Excel offers great rates on long distance service. We have several plans to choose from so that you can pick the plan that will meet your individual needs. Select product link for special product details. Customer Service Excel Local: 1-877-668-0808 Excel Long Distance: 1-800-875-9235 VarTec Local: 1-800-708-7395 VarTec Long Distance: 1-800-583-6767 Clear Choice Support: 1-800-668-4872 You can also email us at excelcustomerservice@excel.com or fill out our contact form. Türkçe | English Haberler Excel İletişim Danışmanlığı Ankara ofisi hizmete girdi Ankara - Gaziosmanpaşa'da faaliyete geçen Excel İletişim Danışmanlığı'nın Ankara Ofisi, mevcut ve potansiyel iş ortaklarının, lobi ve kamuyla ilişki yönetimi alanındaki ihtiyaçlarına yönelik iletişim taleplerini karşılamak üzere kuruldu. Ofis aynı zamanda Ankara merkezli kurum, şahıs ve markaların iletişim danışmanlığı beklentilerini de İstanbul Merkez Ofisi ile birlikte koordineli olarak karşılayacak. Excel İletişim Danışmanlığı, kamu kurumlarına ve sektörlerinde lider ulusal ve uluslar arası saygın birçok "iş ortağına", marka değerlerini ve kurumsal itibarlarını geliştirmeleri amacıyla stratejik iletişim alanında danışmanlık, planlama ve uygulama hizmetleri veriyor. Excel İletişim Danışmanlığı'nın gerçekleştirdiği "başarı hikayeleri" arasından birkaç örnek: "Dumansız Hava Sahası / Havanı Koru": Dünya Sağlık Örgütü (WHO) Başarı Ödülü, Farmaskop Sağlık İletişimi Yaratıcılık Ödülleri 2009’da En İyi Farkındalık Bilinçlendirme Kampanyası Başarı Ödülü ve Sağlık Bakanlığı’na Onur Ödülü, Galatasaray Üniversitesi “En 2008” Ödülleri En İyi Sosyal Sorumluluk Projesi Ödülü alan 4207 Sayılı yasa hakkında bilgilendirmeyi ve farkındalık yaratmayı hedefleyen kampanya. www.dumansizhavasahasi.org "Bebeğim Sağ Olsun": Avrupa Birliği mali desteğiyle Sağlık Bakanlığı tarafından yürütülen "Türkiye Üreme Sağlığı Programı"nda yer alan ve Avrupa Birliği Türkiye Delegasyonu internet sitesinde başarı hikayesi olarak yayınlanan kampanya. "Sen Gülerken Çok Güzelsin!": İpana'nın Türkiye'deki 50. yılı kutlamaları iletişim kampanyası. "Gelecek İçin Beslenmek": Milupa ile yürütülen ve Milupa'nın bulunduğu tüm ülkeler arasındaki FFL (Feeding For Life) çalışmaları içinde Global En İyi Uygulama Ödülü'ne layık görülen kampanyası. "Sokakları İstila": Unilever Foodsolutions ile yürütülen, Unilever Global tarafından "2008 yılının en iyi medya uygulaması olarak seçilen" müşterilerini daha iyi anlamak, tanımak ve kendilerini anlatmak için düzenlenen proje. "Algida Türkiye'yi Dünyaya Tanıtıyor": Farklı yaklaşımı ve dünya çapındaki relansmana kattığı özgün yaklaşımla Türkiye'nin tanıtımına destek olan Algida Türkiye'ye, Unilever dondurma operasyonları arasında dünya çapında yılın en başarılı projesi ödülünü getiren, MTV işbirliğiyle gerçekleştirilen kampanya. Tekin Sokak Havuzlar Sitesi Köşkü No: 5/1 34718 Acıbadem - İstanbul T: 0216 544 94 00 F: 0216 544 94 01 info@excel.com.tr Türkçe | English HizmetlerimizUzmanlık Alanlarımız Medya İletişimi Kriz & Sorun Yönetimi İçerik Yaratım & Yönetimi Sosyal Sorumluluk Yönetimi Etkinlik Yönetimi Sponsorluk Yönetimi AB Fonları Danışmanlığı Medikal PR Hizmet Yaklaşımımız 90'lı yılların başlarında Türkiye iletişim alanında çok büyük ve hızlı bir dönüşüm yaşamaya başladı. Bu dönüşümün hızını, özel TV kanalları ve radyolarının yanı sıra internet kullanımı belirledi. Türkiye bu süreçte gelişmiş tüketim toplumlarında görülen iletişim modellerini benimsemek ve hayata geçirmek konusunda çok hızla yol kat etti. Aynı dönemde ülke ekonomisinin çizdiği yeni model uluslararası markaların Türkiye pazarına aktif katılımını sağlayıp çabuklaştırdı. Türkiye, gelişkin ve rekabetçi pazarlama yöntemleriyle aktif olarak tanışmaya başladı. Reklam neredeyse yegane iletişim disiplini ve TV, gazete, dergi, radyo reklamları da tek iletişim yöntemi olarak algılanıyorken, gelişkin pazarlardaki tüm iletişim disiplinlerinin kullanıldığı 360 derece iletişim yöntemi tanınmaya ve benimsenmeye başlandı. Türkiye'de tüm iletişim disiplinleri için önemli bir gelişme de, "yaratılan iş sonuçlarının ölçülebilir olması beklentisi ve bilinci oluşmaya/oturmaya başlaması" oldu. Bugün artık pazarlanan ürün ya da hizmetlerin rekabetçi açıdan fark yaratma ve bu farkı koruma ömrü ciddi oranda kısaldı. İletişim, "farkın" oluşması ve yaşamasında başlı başına bir "olmazsa olmaz" ve "yatırım değeri" haline geldi. Bu nedenle, iletişimin farklı disiplinlerinden sorumlu bizler, hizmet verdiğimiz marka ve kurumların iş hedeflerine doğrudan katkı sağlamak için sıkı bir işbirliğine girmek ve güçler birliği olmak / oluşturmak zorundayız. Bu güçler birliği modelinde, mesleğimiz sadece medya iletişimiyle ve etkinlik üretmek-yönetmekle sınırlı tutulmamalıdır. Tekin Sokak Havuzlar Sitesi Köşkü No: 5/1 34718 Acıbadem - İstanbul T: 0216 544 94 00 F: 0216 544 94 01 info@excel.com.tr Türkçe | English İş Ortaklarımız (Alfabetik Sıralanmıştır) Algida Algida, 1959'da İtalya'da kuruldu ve şimdi dünyanın bir numaralı dondurma markası. 1990 yılından beri Türkiye'de dondurmalarını Türk damak tadına ve tüketici beğenilerine göre şekillendiriyor. Max, Cornetto, Magnum, Magnum Çikolata ve Carte d'Or markalarıyla, farklı damak tatlarına ve yaş gruplarına sesleniyor. www.algida.com.tr Airfel 1999 yılında kurulan Sanko Holding şirketlerinden Airfel, ısıtma-soğutma ve havalandırma sektörünün öncüleri arasında yer alıyor. Firma, her türlü split klima, ısıtma, soğutma, havalandırma cihaz ve ekipmanlarının üretimini, satış ve pazarlamasını kendi markası 'AIRFEL' adı altında yapıyor. Airfel aynı zamanda birçok uluslararası markanın da distribütörlüğünü üstleniyor. www.airfel.com.tr Allianz 1890’da kurulan Allianz Grup, dünyanın önde gelen sigorta şirketlerinden ve finans hizmetleri sağlayıcılarından biridir. Allianz Grup 150.000’i aşkın çalışanıyla 70’in üzerinde ülkede faaliyet gösteriyor. Allianz 75 milyon müşterisine konut, kaza, yaşam, sağlık sigortası ve varlık yönetimi gibi alanlarda dünya genelinde hizmetler veriyor. Şirket, sigorta alanında Alman pazarının lideridir ve Avrupa, Asya, Güney Amerika ve Amerika Birleşik Devletleri’nde güçlü bir uluslararası konuma sahiptir. Allianz Grup 2009 Haziran sonu itibariyle 35,5milyar Euro’luk öz sermayesi ve yönettiği 813 milyar Euro değerindeki üçüncü şahıslara ait varlıklarla dünyanın en büyük varlık yöneticilerinden biridir. Allianz SE, Dow Jones Sürdürülebilirlik Endeksi’nde lider sigorta şirketidir. Çokuluslu Teşebbüsler İçin OECD Yönergeleri belgesinin yanı sıra Birleşmiş Milletler’in Küresel İlkeler Sözleşmesi prensiplerini desteklemektedir. www.allianz.com.tr Altıparmak Gıda Kurulduğu 1980 yılından bu yana bal sektörünün gelişimine öncülük eden ve uzun yıllardır sektörün lider firması olan Altıparmak Gıda, bugün bünyesinde bulundurduğu Balparmak, Binbirçiçek ve Balkovan markalarıyla sağlığı, doğallığı, lezzeti sofralara taşıyor. Tüketicisine sunduğu kalite ve sağlık standardı ile farklılaşan Altıparmak, bu anlamda sektörün öncülüğünü üstleniyor. Gıda güvenliği konusunda uluslararası standartlara göre çalışan firma, gıda güvenliği sistemi ISO 22000:2005 ile global gıda standardı BRC (British Retail Consortium) gibi sertifikalara da sahip. Altıparmak ayrıca, Avrupa’nın eşdeğer ilk 4 laboratuvarı arasında yer alan bal analiz laboratuvarı sayesinde, tüketicisine sunduğu bütün ürünleri toplam 65 parametre doğrultusunda analiz ederek sağlıklı olduğunun garantisini veriyor. www.altiparmak.com.tr Ansell Bariyer koruyucu ürünlerinde dünya liderliğini üstlenen Ansell, dünya çapında 11.000’den fazla çalışanı ile Amerika, Avrupa ve Asya’da faaliyet gösteriyor. Doğal lâteks ve sentetik polimer eldiven ile prezervatif pazarlarındaki lider konumunu sürdüren Ansell, temel olarak üç ticari segmentte faaliyet gösteriyor. Ansell, İş Güvenliği alanında endüstriyel pazara el koruması sağlarken, Profesyonel Sağlık Koruması alanında sağlık uzmanlarına, cerrahi ve muayene eldivenleri, Tüketici Sağlık Koruması alanında ise prezervatif ve tüketici el koruması ürünleri/çözümleri sunuyor. www.anselleurope.com AVEA Türkiye’nin en genç ve hızlı büyüyen ilk GSM 1800 mobil iletişim operatörü olan Avea, 2004 yılında kurulmuştur. Şirket, gelişmiş altyapısı ve teknoloji yatırımlarıyla müşterilerine yenilikçi ve kaliteli hizmetler sunmaktadır. Türkiye’nin abone başına en çok konuşturan GSM operatörü olan Avea, 2009 sonu itibarıyla 11,7 milyon aboneye sahiptir. 199 ülkede 620 operatörle uluslararası dolaşım anlaşması bulunan şirket, bir Türk Telekom iştirakidir. Avea’nın %81,37 hissesi Türk Telekomünikasyon A.Ş.’ye, %18,63 hissesi İş Bankası Grubuna aittir. www.avea.com.tr avm mfi partners avm mfi partners 2006 yılının Mart ayında Aydın Yurdum, Tarkan Ander ve Dora Şahintürk tarafından kurulmuştur. Ekim 2007’de Alman mfi Management für Immobillien AG ile güç birliği yapmıştır. Bu ortaklıktan sonra ismi avm mfi partners olarak değişmiştir. AVM sektöründe yatırımcı ve mülk sahiplerine proje geliştirme, yönetim, kiralama, mimari konsept tasarım ve planlama danışmanlığı, hukuki danışmanlık konularında en üst düzeyde, uzun süreli ve sürdürülebilir hizmet sunan avm mfi partners’ın şu andaki hizmet alanı içerisinde Türkiye’nin yanı sıra Avrupa, Balkanlar, Ortadoğu ve Türki Cumhuriyetleri de yer almaktadır. www.avmmfipartners.com.tr Bayer Consumer Care Bayer Consumer Care ürün gamında, sağlık sahasında küçük rahatsızlıklar için kullanılan multivitamin ve mineraller, ağrı kesiciler, cilt ürünleri ve özel vitaminler bulunuyor. "Daha iyi bir hayat için bilim" sloganıyla hareket eden Bayer, daha sağlıklı bireyler için çalışmalarını sürdürüyor. Bayer Consumer Care, Türkiye'de 200 çalışanı ile 30 binden fazla doktor ve 10 binden fazla eczaneye hizmet veriyor. Başlıca ürünleri arasında Aspirin, Supradyn, Bepanthen, Rennie, Talcid, Elevit Pronatal, One-A-Day ve Priorin bulunuyor. www.bayer.com.tr Becel Adını, "Blood Cholesterol Lowering" (Kan Kolesterolünü Düşürücü) kelimelerinin baş harflerinden alan BECEL, üniversitelerin talebi üzerine ilk kez Hollanda'da Unilever tarafından üretilmeye başlandı. Kalp açısından sağlıklı ürünleri piyasaya sürme konusunda 50 yıldan uzun bir süredir lider olan Becel, Unilever'in fonksiyonel gıda markalarındandır. www.becel.com.tr Bel Grup Bel Grup Fransız kökenli olan ve ABD’den Japonya’ya geniş bir bantta faaliyet gösteren dünya lideri bir peynir markasıdır. 2006 yılında tarihsel geçmişini de bildikleri Türkiye pazarına Karper’i satın alarak yeniden giriş yapan Bel Grup, La Vache Qui Rit markasını relanse ederek varlığını güçlendirmiştir. www.groupe-bel.com Ben&Jerry's Ben Cohen ile Jerry Greenfield adlı iki kafadar tarafından 1978 yılında Vermont, Burlington'daki yıkık dökük bir benzin istasyonunda temelleri atılan marka, Kasım 2007'de Türkiye pazarına girdi. Amatör bir ruhla hayata geçirilen Ben&Jerry's, Adil Ticaret Sertifikası'na sahip olan ilk dondurma markası. Hollywood filmlerine konu olan marka, çevreye yaptığı yatırımları, iklim dostu uygulamaları ve mutlu inekleriyle birbirinden lezzetli kocaman parçalı dondurmalar üretiyor. www.benandjerys.com.tr Boyner Türkiye'de gıda dışı perakende sektörünün önde gelen gruplarından Boyner Holding'in bir üyesi olarak 1981 yılında Çarşı Mağazacılık olarak kuruldu. 1985 yılı ile birlikte, Türk Perakendecilik Sektörü'nde hizmet verdiği müşteri kitlesini büyük mağazacılık anlayışına uygun yenilikler sundu. 1997'de halka açılan şirket, bugün Boyner adıyla devam ediyor. www.boyner.com.tr Clear 1986 yılında tüketicilerle buluşarak, Türkiye'nin ilk ve tek kepeğe karşı etkili şampuan markası olarak raflarda yerini aldı. Pazara girdiği ilk günden bu yana yenilikçi vizyonunu sürekli geliştiren Clear, kepek problemine kökten çözümler üretirken, aynı zamanda sağlıklı ve güzel saçlar için etkili formüller sunmaya devam ediyor. Unilever'in kişisel bakım markalarından biri olan Clear, erkeklerin saç yapısına göre özel şampuan serisi de sunmaktadır. www.clear.com.tr Dove Unilever'in önde gelen markalarından Dove, kişisel bakım kategorisinde yüz ve vücut temizliği, cilt bakımı ve saç bakım ürünlerini bünyesinde bulundurmaktadır. Türk tüketicisiyle 1993 yılında buluşan Dove, saç konusunda sayısız araştırma ve dermatolojik test yapmıştır. www.dove.com.tr Anadolu Efes 1969 yılında İstanbul ve İzmir’de iki fabrika ile yola çıkan Anadolu Efes, bugün yurt içindeki 5 bira, 2 malt fabrikası ve 1 adet şerbetçiotu işleme tesisi ile sektörün lideri olarak faaliyet gösteriyor. Dünya genelinde 60’tan fazla ülkeye ihraç edilen Efes Pilsen, ülkemizin yanı sıra Rusya, Kazakistan, Moldova ve Gürcistan’da yer alan 9 bira ve 4 malt fabrikası ile Avrupa’nın 5’inci, dünyanın ise 13’üncü büyük bira üreticisi ayrıca Avrupa'da en çok tüketilen 10 bira markası arasında yer alıyor. Anadolu Efes Türkiye’de, “Efes” şemsiyesi altında toplanan Efes Pilsen, Efes Light, Efes Dark, Efes Dark Brown ve Efes Xtra markalarının yanı sıra Türkiye’nin ilk buğday birası olan Gusta ve siyah buğday birası Gusta Dark, agav ve limon aromalı Mariachi, Mariachi Black ve Mariachi Dry ile; Marmara Gold, Marmara Kırrmızı ve 2010 yılında tüketiciyle buluşan Bomonti markalarının yer aldığı ürün portföyüne sahiptir. Anadolu Efes ayrıca Türkiye’deki bu portföyü, lisanslı olarak ürettiği Miller Genuine Draft (MGD), Beck’s ve Foster’s markaları ile genişletmiştir. www.efespilsen.com.tr Elidor Türk tüketicisiyle ilk olarak 1973 yılında tanıştı. Genç, neşeli, pozitif, sıcak ve modern marka kimliğiyle kısa sürede Türk tüketicisinin vazgeçilmez markalarından biri oldu. Elidor arkasındaki global gücü, teknolojisi ve sürekli kendini yenileyen kimliğiyle Türk kadınlarına her zaman ilkleri ve daha iyisini sunmaya hedefleyen bir marka olarak günümüze kadar geldi. Elidor, Unilever'in kişisel bakım markalarındandır. www.elidor.com.tr Gillette 100 yılı aşkın süredir erkek bakımının öncü markası olan Gillette, tüm dünyada her gün erkekleri güne en iyi şekilde hazırlamak için çalışıyor. Erkeklerin kendilerini iyi ve bakımlı hissettiklerinde daha başarılı olduğunu bilen Gillette, engin bilgi ve deneyimini son teknolojiyle bir araya getirerek, mükemmel bakım için en doğru ürün ve çözümlerini erkeklerin hizmetine sunuyor. İlk 3 bıçaklı sistem bıçağı Mach 3, pille çalışan ilk tıraş sistemi Mach3 Turbo ve ilk 5+1 bıçaklı tıraş sistemi Fusion Power gibi birçok ilki Türk tüketicisine sunan Gillette, Türk erkeğine mükemmel tıraş deneyimi yaşatıyor. Gillette, yenilikçi bakış açısı ile tüketicilerin hayatlarını iyileştirmeye devam ediyor. www.gillette.com.tr GSK Sensodyne Bilimsel ağız sağlığı ürünleri konusunda lider konumdaki GlaxoSmithKline’nın (GSK) ürünleri arasında bulunan Sensodyne Diş Macunu, dişlerde görülen hiper hassasiyetin kontrolü için en çok tercih edilen diş macunu olma özelliği taşıyor. Hassas dişler için her 10 diş hekiminden 9’u, Sensodyne öneriyor. Sensodyne’in Pronamel, F, Ferah Nefes, Naneli, Jel, Tam Koruma, Beyazlatıcı ile Tam Koruma ve Beyazlatıcı çeşitleri bulunuyor. www.gsk.com.tr HUAWEI Dünyanın dört bir yanındaki operatörlere yeni nesil telekomünikasyon çözümleri sağlamada lider konumda bulunan Huawei, şu anda 100’den fazla ülkede dünyanın önde gelen 50 operatörünün 45’ine, dünya çapında bir milyarı aşkın kullanıcısıyla birlikte hizmet sunmaktadır. Şirket, müşterileri için uzun süreli katma değer sağlayan, potansiyel gelişimin önünü açan yenilikçi ve özel ürünler, hizmetler ve çözümler sunmaya odaklanmıştır. www.huawei.com İstanbul 2010 Avrupa Kültür Başkenti Ajansı 2 Kasım 2007’de İstanbul’u, Avrupa Kültür Başkenti olarak hazırlamak, 2010 yılında yapılacak etkinlikleri planlamak ve yönetmek, kamu kurum ve kuruluşlarının bu amaçla yapacakları çalışmalarda koordinasyonu sağlamak amacıyla kurulan İstanbul 2010 Avrupa Kültür Başkenti Ajansı bugün, tarihi boyunca farklı kültürleri bir arada yaşatan İstanbul’un, sahip olduğu dünya kültür mirasını tüm zenginliğiyle paylaşabilmek adına kültür ve sanat, turizm ve tanıtım ve kentsel dönüşüm alanlarında çalışmalarını sürdürmektedir. www.istanbul2010.org LG Electronics Tüketici elektroniği, beyaz eşya ve mobil iletişim pazarlarının dünya liderliğini üstlenen LG Electronics, dünyanın dört bir yanında 84’ü yan kuruluş olmak üzere 115 iş biriminde 84 binden fazla kişiye iş imkânı sağlıyor. 2008 yılı global satışları 44.7 milyar dolar olan LG, Ev Eğlencesi, Mobil İletişim, Ev Aletleri, Klima ve İş Çözümleri olmak üzere 5 ana alanda faaliyet gösteriyor. tr.lge.com Orkid 1970’li yılların sonunda ilk hazır hijyenik pedi Türk tüketicisinin kullanımına sunan Orkid, hijyenik ped sektörün doğmasını ve markalaşmasını sağlamıştır. Teknoloji, kalite ve iletişim alanında yenilikçi ve tüketici ihtiyaç odaklı yaklaşımıyla sektör normlarını belirlemiş ve düzenlediği sosyal sorumluluk kampanyalarıyla da sektörün büyümesinde rol oynamıştır. Kategoriye ismini veren Orkid, lanse edildiği ilk günden beri aralıksız ve geliştirilerek sürdürdüğü hizmet anlayışıyla bugün lider konumda markadır. Türk kadınına mükemmel koruma, rahatlık ve özgürlük duygusu veren Orkid, aynı zamanda kadınların sosyal hayatlarına da katkı sağlamayı hedefliyor. www.orkid.com.tr Palladium Alışveriş Merkezi İstanbulluları moda, lezzet ve eğlence ile buluşturan ve İstanbul'un simgelerinden biri haline gelen Palladium Alışveriş Merkezi; toplam 40 bin metrekare kiralanabilir alanı olan bir alışveriş merkezi ve Asya yakasının en yüksek yapısı olan 32 katlı rezidans kulesinden oluşuyor. 2006 yılında başlayan ve 230 milyon dolarlık bir yatırımın sonucunda İstanbul Kozyatağı'nda açılan Palladium, 1500 metrekarelik açık alanı, ön cephesinde yer alan yeşil alanı ve gün ışığından maksimum faydalanmayı sağlayan dev cam küresi ile farklı bir alışveriş merkezi konsepti sunuyor. Ziyaretçilerine farklı bir yaşam deneyimi sunmayı arzulayan ve İstanbul'un yaşam ve eğlence merkezi olmayı hedefleyen Palladium, yabancı organizasyonlara ve farklı etkinliklere de ev sahipliği yapıyor. 165 mağazası ile hizmet veren Palladium, pek çok açıdan olduğu gibi marka karmasıyla da ilkleri yaşama geçiriyor. Sephora, Kitchenette, Banana Republic, Trussardi ve Armani Jeans gibi dünyaca ünlü markaların Anadolu yakasındaki ilk mağazaları Palladium'da bulunuyor. www.palladium.com.tr SERAMİKSAN SERAMİKSAN, 1990 yılında Turgutlu toprak sanayinin önder kuruluşlarından olan Bloksan A.Ş.'nin ortakları tarafından kuruldu. SERAMİKSAN, gelişen teknoloji ve büyüme anlayışı ile üretimini her yıl arttırarak 2009 yıllında 22 milyon m2‘lik üretim kapasitesine ulaşarak Türkiye ve dünyada sayılı seramik üreticileri arasındaki yerini aldı. Manisa Turgutlu Organize Sanayi Bölgesi bulunan SERAMİKSAN, yer ve duvar karoları, sırlı ve teknik porselenler, bordür ve dekoratif ürünler, dış cephe kaplaması ve yapı kimyasalları üretiyor. www.seramiksan.com.tr T.C. Sağlık Bakanlığı 5727 sayılı “Tütün Mamullerinin Zararlarının Önlenmesine Dair Kanunda Değişiklik Yapılması Hakkında Kanun” ve 4207 sayılı “Tütün Ürünlerinin Zararlarının Önlenmesi ve Kontrolü Hakkında Kanun” ile yapılan değişikliklerle, 19 Mayıs 2008 tarihinden itibaren kamusal alanlarda sigara içilmesine yeni düzenlemeler getirdi. “Dumansız Hava Sahası” iletişim kampanyası ile kamuoyuna duyurulan bu kanun, kamu sağlığına önemli katkılar sağlıyor. www.saglik.gov.tr TTNET TTNET, 6 milyon abonesi ile bugünün ve geleceğin iletişim teknolojilerini sunan markadır. Kurumsal ve bireysel hizmetleriyle müşterilerinin değişen iletişim ihtiyaçlarını göz önüne alarak hizmet ve servislerini sürekli geliştiren TTNET, pazardaki ihtiyaçları en etkin ve hızlı şekilde karşılamaktadır. Türkiye’nin 81 ilinde hizmet veren TTNET’in ürün portföyünde ADSL/VDSL2-hızlı internet erişimi, WiFi kablosuz internet erişimi ve iPass işbirliği ile TTNET WiFi yurtdışı erişim hizmeti, Avea işbirliği ile 3G Mobil İnternet erişim hizmetleri, G.SHDSL, Metro Ethernet, ATM ve Frame Relay internet erişimi hizmetleri bulunmaktadır. www.ttnet.com.tr Wella Professionals Wella Professionals uluslararası moda danışmanları ve profesyonellerin ihtiyaçlarına göre geliştirilen ve sadece yetkili kuaför salonlarından temin edilebilecek ürünler sunuyor. Şekillendirme serisi olan High Hair, saç boyasında yaratıcılık sağlayan Koleston Perfect, bakım ve şekillendirme ürünlerinden saçlarda enerjiyi hissettiren Lifetex, saç kozmetiğinde kışkırtıcı, cezbedici, egzotik, cesaret ve avant-garde ile özdeşleşen Sebastian, makyajda prestijin göstergesi Trucco, farklı saç tipleri için çeşitli ürünler sunan System Professional, kusursuz şekillendiriciler, güneş ürünleri ve erkeklere özel System Professional Just Men serilerini de sunuyor. www.wella.com.tr Proje Bazlı Çalışmalar (Alfabetik sıralanmıştır) APOCP APOCP (Asian Pasific Organization for Cancer Prevention – Asya Pasifik Kanseri Önleme Organizasyonu), Asya Pasifik bölgesinde kanserden korunmaya yönelik ortak çalışmaların yapılmasını sağlamak ve ortak çalışmaları desteklemek amacıyla çalışmalarını sürdürüyor. Her iki yılda bir düzenlediği genel konferans ile 5000’e yakın üst düzey doktoru bir araya getiriyor. 5. Uluslararası APOCP Genel Konferansı, 3-7 Nisan 2010 tarihinde Türkiye’de gerçekleştirilecek. www.apocp.org Marka Konferansı Türkiye gündemine yön veren, pazarlama alanında pek çok ilke imza atan, pazarlama dünyasının trendlerini belirleyen MARKA Konferansı 11. yılında birbirinden çarpıcı konuşmacıları bir araya getiriyor. Moda dünyasından, çağdaş tasarıma, grafik yaklaşımlardan, internete kadar birçok konuya başka bir gözle bakmamızı sağlayacak, yepyeni ufuklar açacak konuşmacıların yanı sıra stratejik ve tüketici eğilimlerine ilişkin yeni marka trendlerine de yakından bakılacak. www.markaconference.com Prima Bebeklerden ilham alan marka, bir bebek bezinden beklenen tüm detayları anneler ve bebekleri için geliştiriyor. www.prima.com.tr Tekin Sokak Havuzlar Sitesi Köşkü No: 5/1 34718 Acıbadem - İstanbul T: 0216 544 94 00 F: 0216 544 94 01 info@excel.com.tr Excel Forum Hoşgeldin, kenan633. Son Ziyaretiniz: 29-12-2010 14:55 Özel Mesajlar: 0 Okunmamış, Toplam 0. Kontrol Paneli Yeni Mesajlar Arama Hızlı Linkler Çıkış Yap Son 30 Mesaj (* - Son 2 gün için) Son Mesajlar Konu Tarih, Saat Son Gönderen Yanıt Görüntüleme Forum verileri userform üzerine almak ve kayıt yapmak 31-12, 14:45 Husgvarna 3 83 Makro-VBA Vekil Takip 31-12, 14:42 isfa67 2 0 Access Soruları Excell'de Satır Renklendirmek 31-12, 14:42 huseyincoban 2 28 Makro-VBA Başka bir dosayadan veri çekmek 31-12, 14:37 onur_unlu 0 0 Fonksiyonlar Stok takip formülü 31-12, 14:36 İhsan Tank 1 0 Fonksiyonlar metin içersinden parça alarak ek yapmak 31-12, 14:18 onur_unlu 20 308 Fonksiyonlar özet tablo 31-12, 14:13 Black Lord 1 4 Diğer Excel Soruları Okulum1.0 Programı 31-12, 14:09 Black Lord 33 3024 Okul Uygulamaları pps uzantılı dosyayı swf yada flash converter 31-12, 14:08 levo26 4 13 Windows-Word-PowerPoint . Resmi Yazışma Programım v2.0 BİTTİ 31-12, 14:03 htsumer 161 15982 Okul Uygulamaları Tablodaki satırları sıralamada yardım 31-12, 14:00 mr.cyclone 6 171 Diğer Excel Soruları Sayfaları Menü haline getirmek? 31-12, 13:57 uzmanamele 3 110 Diğer Excel Soruları Function işlemini hızlandırma mümkünmü? 31-12, 13:47 Huseyinkis 1 64 Makro-VBA Yeni Yılınız Kutlu Olsun 31-12, 13:37 aatoş 41 2453 Bayram ve Özel Gün Mesajları kaydet makro kodunda yardım 31-12, 13:33 fatih34 7 86 Makro-VBA güncel giriş fiyatı 31-12, 13:30 Huseyinkis 1 27 Diğer Excel Soruları serideki en büyük ilk 10 öğe 31-12, 13:13 muzzymania 2 42 Fonksiyonlar Aynı Özellikteki Birden Fazla Excel Tablosunu 31-12, 13:08 omerceri 7 323 Access Soruları Ad soyadı ayırma 31-12, 12:55 yurekliumut 5 66 Diğer Excel Soruları 1900 öncesi tarihler 31-12, 12:54 altanson 2 44 Diğer Excel Soruları Yıllık izin Takip Programı(Süper) 31-12, 12:44 waterbrave 19 5399 Access Örnekleri ve Bilgileri Excel mi Access mi? 31-12, 12:00 ali8686 1 41 Makro-VBA Cari hesaplar ve Stok takibi + Web. 31-12, 11:57 mekanikçi 23 2938 Muhasebe,Satış ve Stok Takibi kestirme veya kesişim ile ilgili 31-12, 11:53 ferhatt 3 148 Grafik Soruları Tarih aralıkları için işlem yaptırma 31-12, 11:47 iskava 7 111 Diğer Excel Soruları Stok Takip Programı 31-12, 11:34 mekanikçi 5 1503 Access Örnekleri ve Bilgileri Depo takip istiyorum 31-12, 11:27 mekanikçi 5 208 Excel'e Yeni Başlayanlar Borçlu takip programı yardım.. 31-12, 11:26 Aleksitimik 8 183 Excel'e Yeni Başlayanlar Veri Dogrulama ve Ad Tanimi Kullanarak Dinamik 31-12, 11:14 tefenli 11 224 Fonksiyon ve Diğer İşlev outlooktan bilgi alma 31-12, 11:11 tamer42 10 1160 Makro-VBA Forum Son Mesaj Konular Mesaj EXCEL-Soruları Excel'e Yeni Başlayanlar (90 Kişi Görüntülüyor) Excel kullanmaya yeni başladıysanız sorularınızı buraya gönderebilirsiniz. Depo takip istiyorum Gönderen: mekanikçi Bugün 11:27 18,511 108,339 Fonksiyonlar (37 Kişi Görüntülüyor) Bir fonksiyonun, nasıl işlediğini veya aradığınız bir işleme uygun olup olmadığını bu başlık altında sorabilirsiniz. Başka bir dosayadan veri Gönderen: onur_unlu Bugün 14:37 7,622 48,248 Reklam - - Makro-VBA (32 Kişi Görüntülüyor) Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz. verileri userform üzerine Gönderen: Husgvarna Bugün 14:45 25,487 148,784 Grafik Soruları (3 Kişi Görüntülüyor) Grafik uygulamaları ile ilgili sorularınızı bu başlığa yöneltebilirsiniz. kestirme veya kesişim ile Gönderen: ferhatt Bugün 11:53 539 2,719 Diğer Excel Soruları (49 Kişi Görüntülüyor) Yukarıdaki başlıklara uymayan Excel sorularınızı bu bölüme gönderebilirsiniz. özet tablo Gönderen: Black Lord Bugün 14:13 11,707 64,243 Uygulamalı Excel Eğitimi (1 Kişi Görüntülüyor) Bu başlıkta uygulamalı excel eğitimi verebilir yada verilen eğitimlere katılabilirsiniz. (Bu başlıkta yeni konu açılması onaya bağlıdır.) Ofiice 2007'de Butonlar İçin Gönderen: Black Lord 28-12-2010 11:42 37 1,564 Beyin Fırtınası Bu başlıkta, ilginç olduğunu düşündüğünüz sorularınızı, bir problem şeklinde sorabilir, alternatif olduğunu düşündüğünüz çözümlerinizi paylaşabilirsiniz. (Bu başlıkta yeni konu açılması onaya bağlıdır.) Labirentte Yol Bulma Gönderen: asri 19-12-2010 01:27 22 355 Bilgi Bankası (SADECE ÜYELERE) Excel Dersanesi (3 Kişi Görüntülüyor) Excel öğrenmek istiyorsanız bu başlığı düzenli takip edin. Bu bölümde sorular yok sadece öğretici bilgiler yer alıyor. Hem yeni başlayanlar için, hemde ileri Excel bilgileri. Herkes için bir şeyler var. (Bu başlık mesaj gönderimine kapalıdır. Lütfen mesaj göndermeye çalışmayın.) Dizi - Array formülünün Gönderen: yurttas 29-12-2010 15:32 149 814 Excel’de Bunları Biliyor muydunuz? Kullanım kolaylığı sağlayan güzel, ilginç ve faydalı Excel bilgileri ve kısayolları. Excel 2003'den Excel 2007'ye Gönderen: betulburak 23-12-2010 14:03 148 1,417 Excel, Access ve VBA Linkleri (1 Kişi Görüntülüyor) Bu başlıkta faydalı olduğunu düşündüğünüz excel sitelerinin tanıtımını yapabilirsiniz. (Bu başlıkta yeni konu açılması onaya bağlıdır.) Excel ve Makrolar (e-kitap) Gönderen: ferdi_ferdi Dün 21:30 59 404 Reklam - - Excel İçin Örnek Uygulamalar (20 Kişi Görüntülüyor) Kendi yaptığınız veya harici Excel çalışmalarının kısa açıklaması ile linkini buradan paylaşabilirsiniz. (Bu başlıkta yeni konu açılması onaya bağlıdır.) Alt Forumlar: ADO-DAO-Kapalı Dosya Uygulamaları, Animasyon ve Oyun Uygulamaları, Bordro ve Maaş Uygulamaları, Bütçe Örnekleri ve Uygulamaları, Class Module Uygulamaları, Diğer Uygulamalar, Excel Eğitim ve Kod Bankası Uygulamaları, Fonksiyon ve Diğer İşlev Uygulamaları, Grafik Uygulamaları, Hukuk Uygulamaları, İlginç Programlar ve API Uygulamaları, Kullanıcı Adı ve Parola Uygulamaları, Menü Uygulamaları, Muhasebe,Satış ve Stok Takibi Uygulamaları, Mühendislik ve Teknik Uygulamalar, Mükerrer Kayıt Uygulamaları, Okul Uygulamaları, Özel Excel Uygulamaları ve Eklentiler, Personel Uygulamaları, Regular Expressions (RegExp) - Düzenli İfadeler, Saat ve Timer Uygulamaları, Sayıyı Yazıya Çevirme Uygulamaları, Scripting.Dictionary Nesnesi, Userform ve Nesnelere Yönelik uygulamalar, Veri Yönetimi Uygulamaları, Webten Bilgi Sorgulama, WMI Uygulamaları Okulum1.0 Programı Gönderen: Black Lord Bugün 14:09 2,562 27,318 Diğer Yazılımlar Access Soruları (12 Kişi Görüntülüyor) Access hakkındaki sorular ve cevaplar. Vekil Takip Gönderen: isfa67 Bugün 14:42 5,904 33,635 Access Örnekleri ve Bilgileri (7 Kişi Görüntülüyor) Access ile ilgili başvuru kaynakları, örnek açıklamalar ve linkler. Alt Forumlar: Access Dersanesi Yıllık izin Takip Gönderen: waterbrave Bugün 12:44 703 7,258 Reklam - - SQL (1 Kişi Görüntülüyor) Yapısal sorgulama dili hakkında sorularınızı buraya sorabilirsiniz. Sql sorgusuyla gelen veri Gönderen: zafer 29-11-2010 16:20 315 1,550 Windows-Word-PowerPoint . (28 Kişi Görüntülüyor) Excel haricindeki Ofis programları ile ilgili konular. pps uzantılı dosyayı swf yada Gönderen: levo26 Bugün 14:08 1,379 6,076 Yazılım ve Donanım (8 Kişi Görüntülüyor) Yazılım ve Donanım konuları ve diğer kullanıcılara tavsiye etmek istediğiniz programların açıklamaları. Excel ve Autocad proğramlarım Gönderen: iibfli Dün 22:40 907 4,091 WEB Tasarım&Programlama Alt Forumlar: Alan Adı, Hosting(Sunum), PHP & MySql, JavaScript, ASP & VBscript, Grafik Tasarım Vbs uzantılı dosya çalışmıyor. Gönderen: voicemale 27-12-2010 12:55 246 1,066 EXCEL WEB TR - Hizmetleri excel.web.tr olarak üyelerimize sunduğumuz ilave hizmetler kategorisi KİTAP MAĞAZAMIZ (e-mağaza) EXCEL.WEB.TR Güvencesi ile online satılan kitaplar hakkında değerlendirmeler. "Excel 2007 |