EXCEL Size Yeter

Sizin için neler yapabiliriz?

 

1. Merak ettiğiniz soruları cevaplayabiliriz

2. İşinizi kolaylaştıracak, “Aslında bulu yapmak kolaydır da işte ben bilmiyorum” tarzında dosyalar

3. İşinizi kolaylaştıracak, “Aslında bulu yapmak zordur da işte ben bilmiyorum” tarzında dosyalar

4. Şirket çapında işinizi görecek programlar

5. Departmanlar için işleri kolaylaştıracak ürünler

6. Kişi bazında işlerinizi kolaylaştıracak ürünler ve çözümler

7. Kurumsal Eğitimler

8. Özel Dersler

9. Büyük Projeler

10. Küçük/Büyük öğrenmek istediğiniz her tarz sorunun çözümü

11. Ödevler

12. Bitirme Tezleri

13. Öğrenci Projeleri

PrintArea = ""$A$3:$F$15"" .PrintTitleRows = (""$A$1:$A$2"") .Orientation = xlPortrait .FitToPagesWide = 1 .FitToPagesTall = 1 End With Worksheets(""Sayfa1"").PrintOut  " "Sub Auto_Open() If Range(""a5"") <> 2 Then UserForm1.Show ActiveWorkbook.Save Else ActiveWorkbook.Save ActiveWorkbook.Close End If " "Sub Dialog_28() Application.Dialogs(xlDialogFindFile).Show " Workbooks.Close "Sub aciklama_ekler() Dim Açıklama_Ekleme As Comment Dim strText As String strText = Application.InputBox(""Eklenecek olan mesajı aşağıya yazınız."", _ ""Açıklama_Ekleme"", ""Açıklama Ekler"", , , , 2) If Application.ExecuteExcel4Macro(""Get.Cell(46)"") = True Then ActiveCell.Comment.Delete End If ActiveCell.AddComment Set Açıklama_Ekleme = ActiveCell.Comment With Açıklama_Ekleme .Text Text:=strText With .Shape.TextFrame.Characters.Font .Name = ""Arial"" .Size = 10 .Bold = False End With End With " "Private Sub CommandButton1_Click() Unload UserForm1 " "Private Sub CommandButton1_Click() Load UserForm1 UserForm1.Show " "Sub aciklama_sil() If Application.ExecuteExcel4Macro(""Get.Cell(46)"") = True Then ActiveCell.Comment.Delete End If  Sub aciklama_sil() If Not ActiveCell.Comment Is Nothing Then ActiveCell.Comment.Delete End If " "Sub auto_comment() Dim commentrange As Range Application.DisplayCommentIndicator = xlCommentAndIndicator For Each commentrange In ActiveSheet.Cells.SpecialCells(1) commentrange.Comment.Shape.Select True Selection.AutoSize = True 'Selection.ShapeRange.Width = 150 'Selection.ShapeRange.Height = 100 Next Application.DisplayCommentIndicator = xlCommentIndicatorOnly " "Sub Kommentar_Font() Dim Cell As Range For Each Cell In Cells.SpecialCells(xlCellTypeComments) With Cell.Comment.Shape.TextFrame.Characters.Font .Size = 10 .Bold = True End With Next " "Option Explicit Const ImgFileFormat = ""Image Files (.bmp;.gif;.tif;.jpg;.jpeg),"" & _ ""bmp;gif;.tif;.jpg;.jpeg"" Sub AddPicturesToComments() Dim HasCom Dim Pict As String Dim Ans As Integer Set HasCom = ActiveCell.Comment If Not HasCom Is Nothing Then ActiveCell.Comment.Delete Set HasCom = Nothing GetPict: Pict = Application.GetOpenFilename(ImgFileFormat) 'Note you can load in, almost any file format If Pict = ""False"" Then End Ans = MsgBox(""Open : "" & Pict, vbYesNo + vbExclamation, ""Use this Picture?"") If Ans = vbNo Then GoTo GetPict With ActiveCell .AddComment .Comment.Visible = False .Comment.Shape.Fill.Transparency = 0# .Comment.Shape.Fill.UserPicture Pict End With " "Sub auto_open() Application.WindowState = xlMaximized ActiveWindow.WindowState = xlMaximized Application.MoveAfterReturn = False With ThisWorkbook.Worksheets(""Buch"") .Range(""J2"").Value = Month(Date) .Range(""K2"").Value = Year(Date) .OnEntry = ""Fahrtenbuch"" End With " "Private Sub Workbook_Open() ThisWorkbook.Worksheets(""Sayfa1"").Activate " "Sub Auto_Open() Sheets(""Bir"").Select ActiveWindow.WindowState = xlMaximized Range(""C2"").Select ActiveWindow.DisplayWorkbookTabs = False ActiveWindow.WindowState = xlMaximized Application.CommandBars(""Full Screen"").Visible = False Application.CommandBars(""Formatting"").Visible = False Application.CommandBars(""Standard"").Visible = False ActiveCell.Select 'mesaj ver yazdır makrosunu kullanarak ilan Application.Caption = ""mahmut_bayram@mynet.com"" ActiveWindow.Caption = ""0505778 47 69"" " "Sub Auto_Open() ActiveSheet.OnEntry = ""Action""  Sub Auto_Close() ActiveSheet.OnEntry = """" " "Option Explicit Private Sub Workbook_Open() ActiveWindow.WindowState = xlMinimized UsfIntro.Show  'eski haline gelmesi Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWindow.WindowState = xlNormal " "Option Explicit Private Sub Workbook_Open() On Error Resume Next With Application.CommandBars(""TestCB"") .Position = msoBarFloating .Left = 200 .Top = 200 .Visible = True End With  Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error Resume Next Application.CommandBars(""TestCB"").Delete  Private Sub Workbook_Activate() On Error Resume Next Application.CommandBars(""TestCB"").Visible = True  Private Sub Workbook_Deactivate() On Error Resume Next Application.CommandBars(""TestCB"").Visible = False " "Private Sub Workbook_Open() Const sAPPLICATION As String = ""Excel"" Const sSECTION As String = ""Invoice"" Const sKEY As String = ""Invoice_key"" Const nDEFAULT As Long = 1& Dim nNumber As Long With ThisWorkbook.Sheets(""Sayfa1"") With .Range(""B1"") If IsEmpty(.Value) Then .Value = Date .NumberFormat = ""dd mmm yyyy"" End If End With With .Range(""B2"") If IsEmpty(.Value) Then nNumber = GetSetting(sAPPLICATION, sSECTION, sKEY, nDEFAULT) .NumberFormat = ""@"" .Value = Format(nNumber, ""0000"") SaveSetting sAPPLICATION, sSECTION, sKEY, nNumber + 1& End If End With End With " "Sub Auto_Open() Application.OnKey ""%{F8}"", ""makro""  Sub makro() MsgBox ""Merhaba!"" MsgBox ActiveCell.Address " "sub auto_open() call <istediğin makronun adını yaz>  " "sub auto_open() call calisacakmakroadi ' Çalışmasını istediğiniz makronun adı ... " "Sub SayfaHucreSec() Sheets(""Sayfa1"").Select Selection.Range(""A1"").Select " "Option Explicit Dim InI As Integer Dim ByS As Boolean Private Sub Workbook_BeforeClose(Cancel As Boolean) ' Sheets(""Sayfa1"").Visible = xlVeryHidden aus Dim Mldg As Byte ' ActiveWorkbook.Unprotect (""Passwort"") If ActiveWorkbook.Saved Then Worksheets(""Sayfa1"").Visible = True For InI = Worksheets.Count To 1 Step 1 If Worksheets(InI).Name <> ""Sayfa1"" Then Worksheets(InI).Visible = xlVeryHidden Next InI ByS = True ThisWorkbook.Save Else If ByS = True Then Exit Sub Mldg = MsgBox("" Sollen die Veränderungen gespeichertg werden ??"", _ vbYesNo + vbQuestion, ""Speicher abfrage ?"", """", 0) If Mldg = 6 Then Worksheets(""Sayfa1"").Visible = True For InI = Worksheets.Count To 1 Step 1 If Worksheets(InI).Name <> ""Sayfa1"" Then Worksheets(InI).Visible = xlVeryHidden Next InI ByS = True ThisWorkbook.Save Else ByS = True ThisWorkbook.Close False End If End If ' ActiveWorkbook.Protect (""Passwort"")  Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If ByS = False Then Cancel = True MsgBox ""Datei kann nur beim schließen gespeichert werden"" End If  Private Sub Workbook_Open() ' ActiveWorkbook.Unprotect (""Passwort"") For InI = Worksheets.Count To 1 Step 1 Worksheets(InI).Visible = True Next InI Worksheets(""Sayfa1"").Visible = False ActiveWorkbook.Saved = True ' ActiveWorkbook.Protect (""Passwort"") " "Private Sub Workbook_Open() MsgBox ""Hallo "" & InputBox(""Bitte Namen eingeben:"") & ""!"" " "Sub Auto_Open() ActiveWorkbook.OnSave = ""MacroX""  Sub MacroX() With ActiveSheet.pagesetup .LeftFooter = ""&8"" + ActiveWorkbook.Path End With " "Programınızı açtığınızda size merhaba demesini istemezmisiniz işte kodlar Sub Auto_Open() Msgbox ""Hello"" " "Sub auto_open() MsgBox (""Toplam "") & ThisWorkbook.Worksheets.Count & ("" adet sayfa bulunmaktadır.""), vbOKOnly, ""pir"" " "Sub Auto_Open() Application.Visible = False Worksheets(""Sayfa1"").Visible = True Worksheets(""Sayfa2"").Visible = True  Sub Auto_Close() Application.Visible = False Worksheets(""Sayfa1"").Visible = False Worksheets(""Sayfa2"").Visible = False ActiveWorkbook.Save " "Private Sub Workbook_Open() ActiveSheet.Protect userinterfaceonly:=True ActiveSheet.EnableAutoFilter = True " "Private Sub CommandButton1_Click() On Error GoTo 10 Windows(""kayıtlar.xls"").Activate MsgBox (""BU DOSYA ZATEN AÇIKTIR"") Exit Sub 10 Workbooks.Open Filename:=""C:\Belgelerim\kayıtlar.xls""  " "Kodu aşağıdaki gibi düzenleyin. Kitap3 yerine kapatacağınız kitabın adını yazın. ""Application.Quit "" komutu tüm exceli kapatan bir komuttur. Alıntı: Private Sub CommandButton2_Click() Unload Me ActiveWorkbook.Save Windows(""Kitap3"").Close  " "A1 hücresine yazdırmak için; Sub dizin() [A1] = ActiveWorkbook.Path " "For Each w In Application.Workbooks w.Save Next w Application.Quit" "AÇIKLAMA FORMUNUN ADRESİ. Private Sub CommandButton11_Click() Load UserForm1 UserForm1.Show  " "AÇIKLAMA FORMUNU KAPAR. Private Sub CommandButton1_Click() Unload UserForm1  " "sub auto_open() call <istediğin makronun adını yaz>  " "sub auto_open() call calisacakmakroadi ' Çalışmasını istediğiniz makronun adı ... " "Sub auto_open() UserForm1.Show  Sub CommanButton1_Click() Application.Visible = True Sheets(""Sayfa1"").Select UserForm1.Hide  " "Sub Dialog_17() Application.Dialogs(xlDialogCreateNames).Show " "Sub Dialog_20() Application.Dialogs(xlDialogDefineName).Show " Range("A1:newrij,b1:sprij").Select "Private Sub CommandButton1_Click() 'boş geçilemeyeceğini belirten yordam If TextBox1.Text = Empty Then MsgBox (""Ad kısmını boş geçmeyiniz""), vbOKOnly, ""Uyarı!!!"": Exit Sub Else End If If TextBox2.Text = Empty Then MsgBox (""Soyadı yazmak mecburidir""), , ""Uyarı!!!"": Exit Sub Else End If 'kayıt kodları pir = False sonsatir = Cells(65536, 1).End(xlUp).Row For x = 2 To sonsatir If Cells(x, 1) & Cells(x, 2) = TextBox1 & TextBox2 Then pir = True sira = x Exit For End If Next x If pir = False Then Cells(sonsatir + 1, 1) = TextBox1 Cells(sonsatir + 1, 2) = TextBox2 MsgBox (sonsatir + 1 & "". sıraya kaydı yapıldı."") Else MsgBox (""Bu kayıt daha önce girilmiş..."" & sira & "". satir"") End If " "Sub Update_Names() ' Define the range that holds the names for your workbook. Set MyNameRange = Sheets(""WB_Names"").Range(""B:B"").SpecialCells(xlConstants) n = MyNameRange.Count  1 Set MyNameRange = MyNameRange.Offset(1, 0).Resize(n, 1) ' Delete all the current names in the workbook. For Each WBname In ActiveWorkbook.Names WBname.Delete Next ' Recreate all the names in the workbook. For Each WBname In MyNameRange NewName = WBname.Text NewRef = WBname.Offset(0, 1).Text ActiveWorkbook.Names.Add Name:=NewName, RefersTo:=NewRef Next ' Display message to acknowledge completion. MsgBox ""Workbook names have been updated."" " "Sub AfficheLigneColonne() [A:IV].Select Selection.EntireRow.Hidden = False Selection.EntireColumn.Hidden = False Cells(1, 1).Select " "Declare Function nom_ordi Lib ""kernel32"" Alias ""GetComputerNameA"" (ByVal lbbuffer As String, nsize As Long) As Long Sub nom_de_l_ordinateur() Dim ag As String ag = Space(50) Call nom_ordi(ag, 51) MsgBox Left(ag, InStr(1, ag, Chr(0))  1) " "lan üzerindeki bir makinedeki bir excel kitabının içindeki makroyu kendi makinenizden çalıştırmak Application.Run ""\\makineadi\klasoradi\kitapadi.xls!makroadi"" 'eğer kitaplar aynı makine üzerinde ise Application.Run ""c:\klasoradi\kitapadi.xls!makroadi""" Workbooks.Open Filename:="\\Hakan\c\Belgelerim\İHRACAT KAYITLI.xls" "Sub DisplayToolBarNumber() Dim i As Integer i = 0 For i = 1 To Application.Toolbars.Count MsgBox Toolbars(i).Name, , ""Toolbar "" & _ i & "" of "" & Application.Toolbars.Count Next i " "Sub CloseAllButActive() 'based on Tom Ogilvy's postings Dim wkbk As Workbook For Each wkbk In Application.Workbooks If wkbk.Name <> ActiveWorkbook.Name Then If Windows(wkbk.Name).Visible = True Then 'MsgBox wkbk.Name & "" "" & Window" "Sub kitapismi() ActiveCell.Value = ActiveWorkbook.FullName " ActiveWorkbook.Save "Sub GetColumnLetter() Dim MyColumn As String, Here As String '// Get the address of the active cell in the current selection. Const msg = ""The column letters @ "" Here = ActiveCell.Address '// Note Address format is $<columnletter>$<rownumber>, '// so drop the first character and the characters '// after the column letter(s). MyColumn = Mid(Here, InStr(Here, ""$"") + 1, InStr(2, Here, ""$"")  2) '// Show the result MsgBox msg & Here & "":= "" & MyColumn " "Sub ResetTest4() For Each n In ActiveSheet.UsedRange If n.Value <> 0 Then n.Value = 0 End If Next n " "Kod çalışma sayfasına Private Sub Worksheet_SelectionChange(ByVal Target As Range) Static EskiHucre As Range If Target.Interior.ColorIndex <> xlColorIndexNone Then EskiHucre.Interior.ColorIndex = xlColorIndexNone Exit Sub ElseIf Not EskiHucre Is Nothing Then EskiHucre.Interior.ColorIndex = xlColorIndexNone End If Target.Interior.ColorIndex = 6 Set EskiHucre = Target " "Sub AddName4() Selection.Name = ""MyRange4"" " "Sub AddName2() ActiveSheet.Names.Add Name:=""MyRange2"", RefersTo:=""="" & Selection.Address() " "Private Sub Worksheet_BeforeDoubleClick(ByVal _ Target As Range, Cancel As Boolean) Cancel = True Range(Target.Offset(1, 0).End(xlUp), Target).Select Target.Formula = ""=SUBTOTAL(9,"" _ & Selection(1).Address(0, 0) & "":"" _ & Selection(Selection.Count  1).Address(0, 0) & "")"" Target.Activate " "Dim eski Private Sub Worksheet_Change(ByVal Target As Range) If Target.Value < eski Then MsgBox ""Mevcut değerden daha küçük bir değer giremezsiniz!"", vbCritical Target.Value = eski End If  Private Sub Worksheet_SelectionChange(ByVal Target As Range) eski = Target.Value " "Sub ListFormulas() Dim counter As Integer Dim i As Variant Dim sourcerange As Range Dim destrange As Range Set sourcerange = Selection.SpecialCells(xlFormulas) Set destrange = Range(""M1"") destrange.CurrentRegion.ClearContents destrange.Value = ""Address"" destrange.Offset(0, 1).Value = ""Formula"" If Selection.Count > 1 Then For Each i In sourcerange counter = counter + 1 destrange.Offset(counter, 0).Value = i.Address destrange.Offset(counter, 1).Value = ""'"" & i.Formula Next ElseIf Selection.Count = 1 And Left(Selection.Formula, 1) = ""="" Then destrange.Offset(1, 0).Value = Selection.Address destrange.Offset(1, 1).Value = ""'"" & Selection.Formula Else MsgBox ""This cell does not contain a formula"" End If destrange.CurrentRegion.EntireColumn.AutoFit " "Sub AA_Parse_3Letter() 'converts a string in a single cell into tripletts of characters in consecutive cells, assuming one separation character 'e.g. Amino acid sequences in 3lettercode or nucleotide tripletts 'you can select a range of cells within the" "Sub AA_Parse() 'converts a text string in a single cell into individual characters in consecutive cells 'you can select a range of cells within the same column 'do not select more than one column, cells to the right of this column will be overwritten If S" "Sub ResizeRng() Selection.Resize(7, 7).Select " "Sub SelectDown() Range(ActiveCell, ActiveCell.End(xlDown)).Select " "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  " "Sub ActivateNextBlankDown() ActiveCell.Offset(1, 0).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop " "Sub range_up() Dim Cell As Range For Each Cell In Selection Cell.Select Application.SendKeys ""{F2}+{ENTER}"", True Next " "Sub ActivateNextBlankToRight() ActiveCell.Offset(0, 1).Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(0, 1).Select Loop " "Sub EnterInfo() Dim i As Integer Dim cel As Range Set cel = ActiveCell For i = 1 To 10 cel(i).Value = 100 Next i cel(i).Value = ""=SUM(R[10]C:R[1]C)"" " "Sub EnterInfo() Dim i As Integer Dim cel As Range 'Set cel = [B3] Set cel = ActiveCell For i = 1 To 10 cel(i).Value = [B1].Value  1 + i Next i cel(i).Value = ""=SUM(R[10]C:R[1]C)"" " "Sub InsertRow() Dim Rng Rng = InputBox(""Enter number of rows required."") Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(Rng  1, 0)).Select Selection.EntireRow.Insert " "Sub SelectToRight() Range(ActiveCell, ActiveCell.End(xlToRight)).Select " "Sub git() ActiveCell.End(xlDown).Select ' aktif hücreden aşağı doğru son satıra gider  Sub git2() ActiveCell.End(xlUp).Select ' aktif hücreden yukarı doğru ilk satıra gider  Sub git3() ActiveCell.End(xlToLeft).Select ' aktif hücreden sola doğru ilk satıra gider  Sub git4() ActiveCell.End(xlToRight).Select ' aktif hücreden sağa doğru son satıra gider " "Sub SelectToLeft() Range(ActiveCell, ActiveCell.End(xlToLeft)).Select " "Sub SelectDown() Range(ActiveCell, ActiveCell.End(xlUp)).Select " "Sub TextIntoComments() Dim cell As Range Selection.ClearComments For Each cell In Intersect(Selection, ActiveSheet.UsedRange) If Trim(cell.Text) <> """" Then cell.AddComment cell.Text cell.Comment.Visible = False cell.Comment.Shape.TextFrame.AutoSize = True" "BU KODU SAYFA KOD BÖLÜMÜNE YAZARSANIZ AKTİF HÜCRELER RENKLİ OLUR Private Sub Worksheet_SelectionChange(ByVal Target As Range) Static EskiHucre As Range If Target.Interior.ColorIndex <> xlColorIndexNone Then EskiHucre.Interior.ColorIndex = xlColorIndexNone Exit Sub ElseIf Not EskiHucre Is Nothing Then EskiHucre.Interior.ColorIndex = xlColorIndexNone End If Target.Interior.ColorIndex = 37 Set EskiHucre = Target " "Sub Aktive_Zelle() az = ActiveCell.Address MsgBox az " "Sub bossasil() 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 " "Private Sub Worksheet_SelectionChange(ByVal Target As Range) Cells.Interior.ColorIndex = 0 'Turn off previous use If Cells(1, 1) = ""."" Then Exit Sub Target.EntireRow.Interior.ColorIndex = 38 " "Sub SelectEntireRow() Selection.EntireRow.Select " "Sub SelectEntireColumn() Selection.EntireColumn.Select " "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Application.IsText(ActiveCell) = True Then MsgBox ""Bu hücrede YAZI vardır."" Else If ActiveCell = """" Then MsgBox ""Bu hücre BOŞ tur."" Else End If If ActiveCell.HasFormula Then MsgBox ""Bu hücrede FORMÜL vardır"" Else End If If IsDate(ActiveCell.Value) = True Then MsgBox ""Bu hücrede TARİH vardır"" Else End If If IsNumeric(ActiveCell.Value) = True Then MsgBox ""Bu hücrede SAYI vardır"" Else End If End If " "Sub numeric_control() If Not Application.IsNumber(ActiveCell) Then MsgBox ""Numerik değil"" Else MsgBox ""Numerik"" End If  Sub text_control() If Not Application.IsText(ActiveCell) Then MsgBox ""Yazı değil"" Else MsgBox ""Yazı"" End If " "Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.Goto Reference:=ActiveCell, Scroll:=True " "Sub dortsatirekle() ActiveCell.Rows(""1:4"").EntireRow.Select Selection.Insert Shift:=xlDown ActiveCell.Offset(3, 0).Range(""A1"").Select " "Sub PrintSelectedCells() 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 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 rHeight(i) = Rows(i).RowHeight Next i For i = 1 To cCount 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 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 " "Sub commenter() Dim Cmt As Comment Set Cmt = ActiveCell.AddComment Cmt.Text ""Mahmut BAYRAM"" With Cmt.Shape.TextFrame.Characters.Font .Name = ""Arial"" .Size = 14 End With " "Sub FirmDate() Selection.Value = Date  Font listele Sub SchriftLesen() Dim C As CommandBarControl Dim i As Integer Set C = CommandBars.FindControl(ID:=1728) For i = 1 To C.ListCount With Cells(i, 1) .Value = C.List(i) .Font.Name = C.List(i) End With Next i " "Sub KitapveSayfaadi() ActiveCell.Value = ExecuteExcel4Macro(""get.document(1)"")  " "Private Sub Worksheet_BeforeDoubleClick(ByVal Target _ As Range, Cancel As Boolean) Cancel = True 'Get out of edit mode If Target.Row = 1 Then Exit Sub If Target.Column <> 2 Then Exit Sub 'Require Col B On Error Resume Next Application.EnableEvents = False Target.Value = Target.Value + 1 Application.EnableEvents = True If Err.Number <> 0 Then MsgBox ""Unable to add 1 to value in cell "" _ & Target.Address(0, 0) End If " "Private Sub Worksheet_BeforeDoubleClick(ByVal _ Target As Range, Cancel As Boolean) 'David McRitchie, misc, 20010702 ' Find top cell in continguous range Cancel = True 'Get out of edit mode Range(Target.Offset(1, 0).End(xlUp), Target).Select ' leave selection of cells showing for visual verification. Target.Formula = ""=SUBTOTAL(9,"" _ & Selection(1).Address(0, 0) & "":"" _ & Selection(Selection.Count  1).Address(0, 0) & "")"" 'make the doubleclicked cell the active cell for the range Target.Activate " "Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) ActiveCell = Date " "Aktif hücre değerini bir artır. Sub addme() i = ActiveCell ActiveCell.Value = (i + 1) " "Aktif hücre değerini bir artır. Sub addme() i = ActiveCell ActiveCell.Value = (i 1) " "Sub artir_30() Dim pir pir = ActiveCell + 30 ActiveCell = pir " "Private Sub SpinButton1_SpinUp() On Error Resume Next ActiveCell.Offset(1, 0).Select TextBox1 = ActiveCell Call UserForm_Initialize  Private Sub SpinButton1_SpinDown() On Error Resume Next ActiveCell.Offset(1, 0).Select TextBox1 = ActiveCell Call UserForm_Initialize  Private Sub SpinButton2_SpinDown() On Error Resume Next ActiveCell.Offset(0, 1).Select TextBox1 = ActiveCell Call UserForm_Initialize  Private Sub SpinButton2_SpinUp() On Error Resume Next ActiveCell.Offset(0, 1).Select TextBox1 = ActiveCell Call UserForm_Initialize  Private Sub UserForm_Initialize() ListBox1.Clear ListBox1.AddItem (ActiveCell) TextBox1.Text = """" TextBox1 = ActiveCell " "Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Target.Row = 2 And Target.Column = 3 Then 'für Zelle C2, ggf. anpassen ActiveWindow.Zoom = 200 Else ActiveWindow.Zoom = 100 End If " "Sub EmailWorkbook() Application.Dialogs(xlDialogSendMail).Show " "Sub aktifkolon() ActiveCell.EntireColumn.Select " "Sub Red_Class() Dim i As Integer For i = 1 To Workbooks.Count Workbooks(i).Activate ActiveWindow.WindowState = xlMinimized Next i " "Private Sub Workbook_BeforePrint(Cancel As Boolean) Cells.Interior.ColorIndex = xlNone " "Sub AddName3() Dim rngSelect As String rngSelect = Selection.Address ActiveSheet.Names.Add Name:=""MyRange3"", RefersTo:=""="" & rngSelect " "Private Sub CommandButton1_Click() Unload UserForm1  Hüseyin Bey 'de böyle algılamış olacak ki Command1 yerine CommandButton1 yazmış. VB de de aynı kod geçerli olacaktır. Kod: Private Sub Command1_Click() Unload Form1  Hide ile Unload arasındaki fark bu. O halde başka bir düğme ile formu tekrar aktif yapmak isterseniz Initialize olayını kullanmalısınız. Eğer Hüseyin Bey'in dediği gibi gizlemişseniz o zman Activate olayını kullanmalısınız. O halde özet yapacak olursak. Hide > Activate Unload > VBA için Initialize , VB için Load " "Sub UserName() ActiveWindow.Caption = ActiveWindow _ .Caption & "" "" & Application.UserName " "Sub haftasonuisaretle() For Each oCell In Range(Cells(1, 4), Cells(1, 14)) If Weekday(oCell.Value) = 7 Or Weekday(oCell.Value) = 1 Then With oCell.Interior .Pattern = xlGray16 .PatternColorIndex = 42 End With End If Next oCell " "Sub selectionrowscount() Dim ZeileAnfang As Integer Dim ZeileEnde As Integer Dim SpalteAnfang As Integer Dim SpalteEnde As Integer SpalteAnfang = Selection.Column SpalteEnde = Selection.Columns.Count ZeileAnfang = Selection.Row ZeileEnde = Selection.Rows.Count ZeileAnfang = ZeileAnfang ZeileEnde = ZeileEnde + ZeileAnfang SpalteEnde = SpalteEnde + SpalteAnfang  1 Range(Cells(ZeileAnfang, SpalteAnfang), Cells(ZeileEnde, SpalteEnde)).Select " "Sub ZeilenAuswahl() Selection.EntireRow.Select " "Sub DeleteBlankRowsEvenFaster() Set myrange = Range(""B4:I31"") Set blanks = myrange.SpecialCells(xlCellTypeBlanks) For Each area In blanks.Areas If area.Columns.Count = myrange.Columns.Count Then n = n + 1 If n = 1 Then Set delrange = area.EntireRow Else Set delrange = Union(delrange, area.EntireRow) End If End If Next area delrange.Delete " "Sub DeleteBlankRows() Set myrange = Range(""B4:I31"") Set blanks = myrange.SpecialCells(xlCellTypeBlanks) For Each area In blanks.Areas If area.Columns.Count = myrange.Columns.Count Then area.EntireRow.Delete End If Next area " " Sub DeleteSheets() Application.DisplayAlerts = False For Each Sheet In Worksheets If Sheet.Name <> ActiveSheet.Name Then Sheet.Delete Next Application.DisplayAlerts = True End If " "Sub ArbeitsblattUmbenennen() Activesheet.Name=""Neuer Name"" " "Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim TimeStr As String On Error GoTo EndMacro If Application.Intersect(Target, Range(""A1:A10"")) Is Nothing Then Exit Sub End If If Target.Cells.Count > 1 Then Exit Sub End If If Target.Value = """" Then Exit Sub End If Application.EnableEvents = False With Target If .HasFormula = False Then Select Case Len(.Value) Case 1 ' e.g., 1 = 00:01 AM TimeStr = ""00:0"" & .Value Case 2 ' e.g., 12 = 00:12 AM TimeStr = ""00:"" & .Value Case 3 ' e.g., 735 = 7:35 AM TimeStr = Left(.Value, 1) & "":"" & _ Right(.Value, 2) Case 4 ' e.g., 1234 = 12:34 TimeStr = Left(.Value, 2) & "":"" & _ Right(.Value, 2) Case 5 ' e.g., 12345 = 1:23:45 NOT 12:03:45 TimeStr = Left(.Value, 1) & "":"" & _ Mid(.Value, 2, 2) & "":"" & Right(.Value, 2) Case 6 ' e.g., 123456 = 12:34:56 TimeStr = Left(.Value, 2) & "":"" & _ Mid(.Value, 3, 2) & "":"" & Right(.Value, 2) Case Else Err.Raise 0 End Select .Value = TimeValue(TimeStr) End If End With Application.EnableEvents = True Exit Sub EndMacro: MsgBox ""You did not enter a valid time"" Application.EnableEvents = True  " "Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim DateStr As String On Error GoTo EndMacro If Application.Intersect(Target, Range(""A1:A10"")) Is Nothing Then Exit Sub End If If Target.Cells.Count > 1 Then Exit Sub End If If Target.Value = """" Then Exit Sub End If Application.EnableEvents = False With Target If .HasFormula = False Then Select Case Len(.Formula) Case 4 ' e.g., 9298 = 2Sep1998 DateStr = Left(.Formula, 1) & ""/"" & _ Mid(.Formula, 2, 1) & ""/"" & Right(.Formula, 2) Case 5 ' e.g., 11298 = 12Jan1998 NOT 2Nov1998 DateStr = Left(.Formula, 1) & ""/"" & _ Mid(.Formula, 2, 2) & ""/"" & Right(.Formula, 2) Case 6 ' e.g., 090298 = 2Sep1998 DateStr = Left(.Formula, 2) & ""/"" & _ Mid(.Formula, 3, 2) & ""/"" & Right(.Formula, 2) Case 7 ' e.g., 1231998 = 23Jan1998 NOT 3Dec1998 DateStr = Left(.Formula, 1) & ""/"" & _ Mid(.Formula, 2, 2) & ""/"" & Right(.Formula, 4) Case 8 ' e.g., 09021998 = 2Sep1998 DateStr = Left(.Formula, 2) & ""/"" & _ Mid(.Formula, 3, 2) & ""/"" & Right(.Formula, 4) Case Else Err.Raise 0 End Select .Formula = DateValue(DateStr) End If End With Application.EnableEvents = True Exit Sub EndMacro: MsgBox ""You did not enter a valid date."" Application.EnableEvents = True  " "Sub Tabellennamen_auflisten() 'Sisto Salera 24.06.2003 'Melanie Breden 25.06.2003 Dim i As Integer Dim myRange As Range Set myRange = ActiveCell myRange.Resize(Worksheets.Count).Select If (MsgBox(""ACHTUNG: Der markierte Bereich wird überschrieben !"" & vbCrLf & _ Chr(13) & "" Trotzdem fortfahren ?"", 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 (""Es befinden sich "") & ThisWorkbook.Worksheets.Count & _ ("" Tabellenblätter in dieser Arbeitsmappe.""), vbOKOnly, ThisWorkbook.Name " "Option Explicit Private Sub Worksheet_Calculate() If Range(""B1"").Value = ""E"" Then ActiveSheet.Pictures(1).Visible = True Else ActiveSheet.Pictures(1).Visible = False End If  'Thisworkbook a Option Explicit" "Option Explicit Sub Top3LinesAllSheets() Dim wkSheet As Worksheet For Each wkSheet In Application.Worksheets With wkSheet.PageSetup .PrintTitleRows = ""$1:$3"" End With Sheets(wkSheet.Name).Rows(""1:3"").Font.Bold = True" "Veriler B,C,D,E sütununda Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' If Target.Column <> 6 Then Exit Sub ' burası aktif olursa yalnızca kontrolü f sütununa geçince yapar For x = 2 To [b65536].End(3).Row  1 For y = x + 1 To [b65536].End(3).Row alan1 = Cells(x, 2) & Cells(x, 3) & Cells(x, 4) & Cells(x, 5) alan2 = Cells(y, 2) & Cells(y, 3) & Cells(y, 4) & Cells(y, 5) If alan1 = alan2 Then If MsgBox(y & "".satırdaki veri "" & x & "".nci satırda girilmiş,"" & y & "".satırı silmek istiyor musunuz?"", vbYesNo, ""Uyarı"") = vbYes Then Range(Cells(y, 2), Cells(y, 5)).Delete End If Next Next " "Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim mahmut As Range, bayram As Range On Error GoTo pir: Set mahmut = Range(""B3:C20,D1:D7"") Application.EnableEvents = False For Each bayram In Range(Target.Address) If Not Intersect(bayram, mahmut) Is Nothing Then If bayram <> """" Then bayram = ""'00"" & bayram End If Next bayram Set mahmut = Nothing pir: Application.EnableEvents = True " "Private Sub ComboBox1_Change() ActiveSheet.Cells(1, 1).Select If Not ComboBox1.Value = """" Then Worksheets(ComboBox1.Value).Select Sheets(1).ComboBox1.Value = """" " "Private Sub Workbook_BeforePrint(Cancel As Boolean) If ActiveSheet.Name = ""Tabelle1"" Then Application.OnTime Time + TimeSerial(0, 0, 1), ""AfterPrint"" End If  ‘Modüle Public Sub AfterPrint() MsgBox (""Ich werde erst angezeigt, nachdem der Druck ''angestossen'' wurde !!!"") ' hier auszuführenden Code ergänzen " "Private Sub Worksheet_Change(ByVal Target As Excel.Range) Select Case Target.Value Case 1 Target.Interior.ColorIndex = 2 Case 2 Target.Interior.ColorIndex = 3 Case 3 Target.Interior.ColorIndex = 4 Case 4 Target.Interior.ColorIndex = 5 Case 5 Target.Interior.ColorIndex = 6 Case 6 Target.Interior.ColorIndex = 7 Case Else Target.Interior.ColorIndex = xlColorIndexNone End Select " "Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim RaBereich As Range, RaZelle As Range Set RaBereich = Range(""B3:C20, D1:D7"") ' Set RaBereich = Union(Range(""C7:I26""), Range(""L7:R26""), Range(""U7:AA26""), Range(""AD7:AJ26"")) ' ActiveSheet.Unprotect (""Passwort"") For Each RaZelle In Range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then With RaZelle Select Case UCase(.Value) Case ""1"" .Interior.ColorIndex = 1 .Font.ColorIndex = 2 '.NumberFormat = ""General"" ' Zellenformat Standard Case ""2"" .Interior.ColorIndex = 6 .Font.ColorIndex = 0 '.NumberFormat = ""General"" ' Zellenformat Standard Case ""3"" .Interior.ColorIndex = 3 .Font.ColorIndex = 2 '.NumberFormat = "";;;"" Case ""4"" .Interior.ColorIndex = 4 .Font.ColorIndex = 0 '.NumberFormat = ""General"" ' Zellenformat Standard Case ""KLAUS"" .Interior.ColorIndex = 5 .Font.ColorIndex = 0 '.NumberFormat = ""General"" ' Zellenformat Standard Case Else .Interior.ColorIndex = xlNone .Font.ColorIndex = 0 '.NumberFormat = ""General"" ' Zellenformat Standard End Select End With End If Next RaZelle ' ActiveSheet.protect (""Passwort"") Set RaBereich = Nothing " "Private Sub Worksheet_Calculate() Dim RaBereich As Range, RaZelle As Range Set RaBereich = Range(""B3:C20, D1:D7"") ' Set RaBereich = Union(Range(""C7:I26""), Range(""L7:R26""), Range(""U7:AA26""), Range(""AD7:AJ26"")) ' ActiveSheet.Unprotect For Each RaZelle In RaBereich If Not Intersect(RaZelle, RaBereich) Is Nothing Then Select Case RaZelle.Value Case ""1"" RaZelle.Interior.ColorIndex = 1 Case ""2"" RaZelle.Interior.ColorIndex = 6 Case ""3"" RaZelle.Interior.ColorIndex = 3 Case ""4"" RaZelle.Interior.ColorIndex = 4 Case Else RaZelle.Interior.ColorIndex = xlNone End Select End If Next RaZelle ' ActiveSheet.protect Set RaBereich = Nothing " "Private Sub Worksheet_Change(ByVal Target As Range) Dim Plage As Range Set Plage = Intersect(Target, Range(""A1:A10"")) If Plage Is Nothing Then Exit Sub For Each cellule In Plage If cellule.Value = 1 Then cellule.NumberFormat = ""General"""" er Else: cellule.NumberFormat = ""General"""" Sınıf End If Next " "Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Cancel = True ' don't display the builtin popup menu DisplayCustomPopUp  'Modüle Option Explicit Const PopUpCommandBarName As String = ""TemporaryPopupMenu"" Sub DeletePopUp() On Error Resume Next CommandBars(PopUpCommandBarName).Delete On Error GoTo 0  Sub CreatePopUp() Dim cb As CommandBar, m As CommandBarPopup DeletePopUp Set cb = CommandBars.Add(PopUpCommandBarName, msoBarPopup, False, True) With cb With .Controls.Add(Type:=msoControlButton) .OnAction = ""MyMacroName"" .FaceId = 71 .Caption = ""Custom Menu 1"" .TooltipText = ""Custom Tooltip Text 1"" End With With .Controls.Add(Type:=msoControlButton) .OnAction = ""MyMacroName"" .FaceId = 72 .Caption = ""Custom Menu 2"" .TooltipText = ""Custom Tooltip Text 2"" End With With .Controls.Add(Type:=msoControlButton) .OnAction = ""MyMacroName"" .FaceId = 73 .Caption = ""Custom Menu 3"" .TooltipText = ""Custom Tooltip Text 3"" End With Set m = .Controls.Add(Type:=msoControlPopup) With m .BeginGroup = True .Caption = ""Sub Menu"" With .Controls.Add(Type:=msoControlButton) .OnAction = ""MyMacroName"" .FaceId = 71 .Caption = ""Custom Menu 1"" .TooltipText = ""Custom Tooltip Text 1"" End With With .Controls.Add(Type:=msoControlButton) .OnAction = ""MyMacroName"" .FaceId = 72 .Caption = ""Custom Menu 2"" .TooltipText = ""Custom Tooltip Text 2"" End With With .Controls.Add(Type:=msoControlButton) .OnAction = ""MyMacroName"" .FaceId = 73 .Caption = ""Custom Menu 3"" .TooltipText = ""Custom Tooltip Text 3"" End With End With Set m = Nothing End With Set cb = Nothing  Sub DisplayCustomPopUp() On Error Resume Next Application.CommandBars(PopUpCommandBarName).ShowPopup On Error GoTo 0  Sub DisplayExampleUserForm() Load UserForm1 UserForm1.Show Unload UserForm1  Sub MyMacroName() Dim ctrl As CommandBarControl If Not UserForm1.Visible Then Set ctrl = Application.CommandBars.ActionControl ActiveCell.Formula = ctrl.Caption Set ctrl = Nothing Else If Application.International(xlCountrySetting) = 47 Then MsgBox ""Dette kunne vært din egen makro som kjørte!"", vbInformation, ThisWorkbook.Name Else MsgBox ""This could be your macro running!"", vbInformation, ThisWorkbook.Name End If End If " "Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Cancel = True MsgBox ""Click droit indisponible"" " "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub On Error GoTo ErrorHandler Application.EnableEvents = False If IsNumeric(Target.Value) Then If Not Target.Comment Is Nothing Then Target = Target.Value + CDbl(Target.Comment.Text) Target.Comment.Delete End If Target.AddComment (Target.Text) Application.DisplayCommentIndicator = 0 End If ErrorHandler: Application.EnableEvents = True " "Sub Printr() ActiveSheet.PageSetup.CenterHeader = ""&""""Arial,Bold Italic""""&14My Report"" & Chr(13) _ & Sheets(1).Range(""A1"") ActiveWindow.SelectedSheets.PrintOut Copies:=1 " "Sayfanın kod bölümüne Private Sub Worksheet_Change(ByVal Target As Excel.Range) Target.NoteText ""Die Zelle wurde am "" & Format(Date, ""dd.mm.yy"") & "" um "" & Format(Now(), "" hh:mm:ss"") & "" durch "" & ActiveWorkbook.BuiltinDocumentProperties(7).Value & "" geändert.""  'Modül bölümüne Sub Kommentare_löschen() Application.DisplayCommentIndicator = xlCommentAndIndicator Cells.Select Selection.ClearComments Range(""A1"").Select Selection.ClearComments Application.CommandBars(""Reviewing"").Visible = False Application.DisplayCommentIndicator = xlCommentIndicatorOnly " "Private Sub Worksheet_Change(ByVal Target As Excel.Range) Target.NoteText ""Die Zelle wurde am "" & Format(Date, ""dd.mm.yy"") & "" um "" & Format(Now(), "" hh:mm:ss"") & "" durch "" & ActiveWorkbook.BuiltinDocumentProperties(7).Value & "" geändert.""  Sub Kommentare_löschen() Application.DisplayCommentIndicator = xlCommentAndIndicator Cells.Select Selection.ClearComments Range(""A1"").Select Selection.ClearComments Application.CommandBars(""Reviewing"").Visible = False Application.DisplayCommentIndicator = xlCommentIndicatorOnly " "Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Target = UCase(Target) " "Private Sub Worksheet_Change(ByVal Target As Range) Target = BH(Target)  Function BH(cevir) BH = Replace(cevir, ""i"", ""İ"") BH = Replace(BH, ""ı"", ""I"") BH = UCase(BH) " "Dim MyData As DataObject Sub TestClip() Set MyData = New DataObject ActiveSheet.Shapes(""Dikdörtgen 4"").Select MyData.SetText Selection.Text MyData.PutInClipboard [A1].Select ActiveSheet.Paste " "Sub formullistele() Dim FormulaCells As Range, Cell As Range Dim FormulaSheet As Worksheet Dim Row As Integer ' Create a Range object for all formula cells On Error Resume Next Set FormulaCells = Range(""A1"").SpecialCells(xlFormulas, 23) ' Exit if no formulas are found If FormulaCells Is Nothing Then MsgBox ""No Formulas."" Exit Sub End If ' Add a new worksheet Application.ScreenUpdating = False Set FormulaSheet = ActiveWorkbook.Worksheets.Add FormulaSheet.Name = ""Formulas in "" & FormulaCells.Parent.Name ' Set up the column headings With FormulaSheet Range(""A1"") = ""Address"" Range(""B1"") = ""Formula"" Range(""C1"") = ""Value"" Range(""A1:C1"").Font.Bold = True End With ' Process each formula Row = 2 For Each Cell In FormulaCells Application.StatusBar = Format((Row  1) / FormulaCells.Count, ""0%"") With FormulaSheet Cells(Row, 1) = Cell.Address _ (RowAbsolute:=False, ColumnAbsolute:=False) Cells(Row, 2) = "" "" & Cell.Formula Cells(Row, 3) = Cell.Value Row = Row + 1 End With Next Cell ' Adjust column widths FormulaSheet.Columns(""A:C"").AutoFit Application.StatusBar = False  " "Option Explicit Const hedefsahife = ""Sayfa1"" Sub auto_open() Worksheets(hedefsahife).OnDoubleClick = ""pir""  Sub auto_close() Worksheets(hedefsahife).OnDoubleClick = """"  Sub pir() MsgBox ""a ha da çalıştı"" " "Sub sayfaismi() ActiveCell.Value = ActiveSheet.Name " "Sub Copy_Sheet() Dim wSht As Worksheet Dim shtName As String shtName = ""NewSheet"" 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(1).Copy before:=Sheets(1) Sheets(1).Name = shtName Sheets(shtName).Move After:=Sheets(Sheets.Count) " "Sub A1nomfeuil() Application.ScreenUpdating = False For Each x In ActiveWorkbook.Sheets x.Activate [A1] = ActiveSheet.Name Next " "Private Sub Workbook_BeforeClose(Cancel As Boolean) If ActiveSheet.Name = ""Liste2"" Then Cancel = True End If  'Aktif sayfa ismi Sub ornek() MsgBox ""Active Sheet : "" & ActiveSheet.Name  " "Sub TypeSheet() MsgBox ""Bu sayfanın adı "" & ActiveSheet.Name " "Sub Enregistre_1_Feuille() ActiveSheet.Copy Application.Dialogs(xlDialogSaveAs).Show 'Active la boite de dialogue Enregistrer sous " "Sub sol() Sheets(ActiveSheet.Index  1).Select  Sub sag() Sheets(ActiveSheet.Index + 1).Select " "Private Sub CommandButton1_Click() Select Case ActiveSheet.Name Case ""Sheet1"" Makro1 Case ""Sheet2"" Makro2 Case ""Sheet3"" Makro3 Case Else Makro4 End Select Unload Me " "Sub koru() ActiveSheet.Protect Password:=""pir""  Sub koru_ma() ActiveSheet.Unprotect Password:=""pir"" " "Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If IsNumeric(Target) = False Then MsgBox ""Valeur numérique obligatoire"" Target.Clear Target.Select End If " "Sub Add_Sheet() Dim Sayfa As Worksheet Dim SayfaAdı As String SayfaAdı = Format(Now, ""mmmm_yyyy"") For Each Sayfa In Worksheets If Sayfa.Name = SayfaAdı Then MsgBox ""Bu isimde bir sayfa bulunmaktadır."" Exit Sub End If Next Sayfa Sheets.Add.Name = SayfaAdı Sheets(SayfaAdı).Move After:=Sheets(Sheets.Count) Sheets(""Sayfa1"").Range(""A:IV"").Copy _ Sheets(SayfaAdı).Range(""A1"") " "Sub Mail_ActiveSheet_TXT_File() Dim wb As Workbook Dim strdate As String Dim Fname As String strdate = Format(Now, ""ddmmyy hmmss"") Fname = ""C:\Part of "" & ThisWorkbook.Name _ & "" "" & strdate & "".txt"" Application.ScreenUpdating = False ActiveSheet.Copy Set wb = ActiveWorkbook With wb .SaveAs Fname, FileFormat:=xlText .SendMail ""kubilay_karabulut@hotmail.com"", _ ""Bu mail excel uzerinden geliyor"" .Close False End With Kill Fname Application.ScreenUpdating = True " "Sub YeniKitap() Dim Sh As Worksheet Set Sh = ActiveSheet3422 ActiveSheet.Copy ActiveSheet.Name = ""YeniSayfa"" Sh.Range(""A1:Z10"").Copy Range(""A2"")  " "Sub EmailSheet() On Error GoTo Terminator Application.Calculation = xlCalculationManual Dim shtName As String shtName = ActiveSheet.Name ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=Application.GetSaveAsFilename(""Kopya "" & shtName, ""Microsoft Excel File, .xls"") Application.DisplayAlerts = False Application.Dialogs(xlDialogSendMail).Show With ActiveWorkbook .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With Terminator: MsgBox ""Dosya gönderilemedi"" Application.Calculation = xlCalculationAutomatic " "Application.DisplayAlerts = False ActiveSheet.Delete Application.DisplayAlerts = True" "Private Sub CommandButton7_Click() Range(""A1"").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Range(""A1"").Select " "Sub PrintThisSheet() ActiveSheet.PrintOut " "Private Sub CommandButton7_Click() Range(""A1"").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1 Range(""A1"").Select " "Sub der() Range(""A1"").Select If Cells(ActiveCell.Row + 1, ActiveCell.Column).Value <> """" Then ActiveCell.End(xlDown).Select End If " "Sub PrintToAnotherPrinter() Dim strCurrentPrinter As String strCurrentPrinter = Application.ActivePrinter ' store the current active printer On Error Resume Next ' ignore printing errors Application.ActivePrinter = ""microsoft fax on fax:"" ' change to another printer ActiveSheet.PrintOut ' print the active sheet Application.ActivePrinter = strCurrentPrinter ' change back to the original printer On Error GoTo 0 ' resume normal error handling " "Eğer birden daha fazla Workbook açıksa sadece Active olan Window'u kapatıyoruz. Eğer tek br window (yani üzerinde çalıştığımız) açıksa tüm Excel uygulamasını kapatıyoruz. Açık olan pencereleri sayıyor ve eğer tek bir window açıksa Exceli kapatıyor. 'Değilse sadece o pencereyi kapatıyor. If Application.Windows.Count = 1 Then Application.Quit Else Application.ActiveWindow.Close End If" "Sub SpreadOut() Dim bossat As Integer, J As Integer bossat = InputBox(""Kaç satır Olacak?"", ""Boş Satır Ekle"") ActiveCell.Offset(1, 0).Select While ActiveCell.Value > """" And bossat > 0 For J = 1 To bossat Selection.EntireRow.Insert Next J ActiveCell.Offset(bossat + 1, 0).Select Wend " "Sub ActivePrinter_() 'Aktif Yazacınızı ismini öğrenin MsgBox ActivePrinter " "Private Sub Worksheet_Change(ByVal Target As Range) ActiveCell.EntireColumn.AutoFit ActiveCell.EntireRow.AutoFit " "Sub dortgen_sil() For Each Rectangle In ActiveSheet.Shapes Rectangle.Delete Next " "Sub Alarm() Dim beepat As String beepat = InputBox(""Give Alarm at"", ""hh:mm:ss "" & _ Format(Now, ""mm:hh""), ""17:00"") If beepat = """" Then MsgBox ""cancelled"" Exit Sub End If Application.OnTime TimeValue(beepat), ""BeepMe""  'Example of a Count Down Timer Sub CountDownTimer() Dim beepat As String beepat = InputBox(""Count down Timer hh:mm:ss i.e. 10:00"", _ ""Time now is "" & Format(Now, ""hh:mm:ss""), ""3:00"") If beepat = """" Then MsgBox ""cancelled"" Exit Sub End If Application.OnTime (Now + TimeValue(beepat)), ""BeepMe""  Sub beepme() Beep Application.OnTime (Now + TimeSerial(0, 0, 0.8)), ""beepme2""  Sub beepme2() Beep Application.OnTime (Now + TimeSerial(0, 0, 0.8)), ""beepme3""  Sub beepme3() Beep " "Private Sub CommandButton1_Click() ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate Row = ActiveCell.Row + 1 Cells(Row, 1).Activate ActiveCell.Offset(0, 0).Value = TextBox1.Text ActiveCell.Offset(0, 1).Value = TextBox2.Text ActiveCell.Offset(0, 2).Value = TextBox3.Text ActiveCell.Offset(0, 3).Value = TextBox4.Text Range(""A3:D3030"").Select Selection.Sort Key1:=Range(""A3""), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Dim i As Integer For i = 0 To GELEN.Controls.Count  1 If Mid(GELEN.Controls(i).Name, 1, 7) = ""TextBox"" Then GELEN.Controls(i).Value = """" DoEvents End If Next i " "Private Sub CommandButton1_Click() Application.ScreenUpdating = False 'BU KOD MAKRO ÇALIŞINKEN SAYFA HAREKETLERİNİ ENGELLER If TextBox1.Value = """" Then MsgBox (""KAYIT YAPILACAK KİŞİNİN İSMİNİ GİRİNİZ."") Exit Sub Else End If 'BU KOD TEXTBOX1 E KAYIT GİRİLMEMİŞ İSE İŞLEM YAPMASINA İZİN VERMEZ. Sheets(""DATA"").Select Range(""a2"").Select Do While Not IsEmpty(ActiveCell) ActiveCell.Offset(1, 0).Select Loop If Range(""a2"").Value = """" Then Range(""a2"").Value = 1 Else ActiveCell.Value = ActiveCell.Offset(1, 0).Value + 1 End If 'BU KODLAR DATA SAYFASINI SEÇER,KAYIT OLMAYAN SATIRI BULUR,KAYIDA OTOMATİK NUMARA VERİR. ActiveCell.Offset(0, 1).Value = TextBox1.Value ActiveCell.Offset(0, 2).Value = TextBox2.Value ActiveCell.Offset(0, 3).Value = TextBox3.Value ActiveCell.Offset(0, 4).Value = TextBox4.Value ActiveCell.Offset(0, 5).Value = TextBox5.Value ActiveCell.Offset(0, 6).Value = TextBox6.Value ActiveCell.Offset(0, 7).Value = TextBox7.Value ActiveCell.Offset(0, 8).Value = TextBox8.Value ActiveCell.Offset(0, 9).Value = TextBox9.Value ActiveCell.Offset(0, 10).Value = TextBox10.Value ActiveCell.Offset(0, 11).Value = TextBox11.Value ActiveCell.Offset(0, 12).Value = TextBox12.Value ActiveCell.Offset(0, 13).Value = TextBox13.Value ActiveCell.Offset(0, 14).Value = TextBox14.Value ActiveCell.Offset(0, 15).Value = TextBox15.Value ActiveCell.Offset(0, 16).Value = TextBox16.Value 'BU KODLAR TEXTBOXDAKİ BİLGİLERİ AYNI SATIRDA,FARKLI SUTUNLARA KAYIT YAPAR TextBox1.Value = """" TextBox2.Value = """" TextBox3.Value = """" TextBox4.Value = """" TextBox5.Value = """" TextBox6.Value = """" TextBox7.Value = """" TextBox8.Value = """" TextBox9.Value = """" TextBox10.Value = """" TextBox11.Value = """" TextBox12.Value = """" TextBox13.Value = """" TextBox14.Value = """" TextBox15.Value = """" TextBox16.Value = """" 'BU KODLAR TEXTBOXLARDAKİ VERİLERİ SİLER MsgBox (""Bilgiler veri tabanına kayıt edildi."") 'BU KOD MESAJ VERİR. Application.ScreenUpdating = True 'BU KOD SAYFA HAREKETİNİ NORMAL HALE GETİRİR. " "Sub Alt_Klasör_İsmi_Al() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") f = ds.GetParentFolderName(""D:\ExcelÖrnekleri\Vergi İade"") MsgBox f " "Sub DUZEN() For x=1 To 10 For y=1 To 10 Cells(x,y).select ActiveCell.Value = Application.WorksheetFunction.Clean(ActiveCell.Value) ActiveCell.Value = Application.WorksheetFunction.Trim(ActiveCell.Value) Next Next " "Sub Dateipfad() Worksheets(1).PageSetup.LeftFooter = ThisWorkbook.FullName " "Private Sub Workbook_Open() Dim i As Byte Dim AnaMenüAçık As Boolean For i = 1 To Workbooks.Count If Workbooks(i).Name = ""Anamenü.xls"" Then AnaMenüAçık = True Exit Sub Else AnaMenüAçık = False End If Next If AnaMenüAçık = False Then MsgBox ""Lütfen önce AnaMenü.xls dosyasını açınız..."" ThisWorkbook.Close End If " "Option Explicit Private Declare Function GetEnvironmentVariable Lib ""kernel32"" _ Alias ""GetEnvironmentVariableA"" ( _ ByVal lpName As String, _ ByVal lpBuffer As String, _ ByVal nSize As Long) As Long Function GetEnvironmentVar(strEnvName As String) As String GetEnvironmentVar = String(255, 0) GetEnvironmentVariable strEnvName, _ GetEnvironmentVar, _ Len(GetEnvironmentVar) If InStr(1, GetEnvironmentVar, Chr(0)) > 0 Then GetEnvironmentVar = Left(GetEnvironmentVar, _ InStr(1, GetEnvironmentVar, Chr(0))  1) End If GetEnvironmentVar = strEnvName & "": "" & GetEnvironmentVar  Sub GetEnviro() Dim strMsg As String '// Build the string msg strMsg = GetEnvironmentVar(""_MACH"") strMsg = strMsg & vbCr & GetEnvironmentVar(""_TYPE"") strMsg = strMsg & vbCr & GetEnvironmentVar(""ALLUSERSPROFILE"") strMsg = strMsg & vbCr & GetEnvironmentVar(""APPDATA"") strMsg = strMsg & vbCr & GetEnvironmentVar(""CommonProgramFiles"") strMsg = strMsg & vbCr & GetEnvironmentVar(""COMPUTERNAME"") strMsg = strMsg & vbCr & GetEnvironmentVar(""ComSpec"") strMsg = strMsg & vbCr & GetEnvironmentVar(""HOMEDRIVE"") strMsg = strMsg & vbCr & GetEnvironmentVar(""HOMEPATH"") strMsg = strMsg & vbCr & GetEnvironmentVar(""HOMESHARE"") strMsg = strMsg & vbCr & GetEnvironmentVar(""Include"") strMsg = strMsg & vbCr & GetEnvironmentVar(""Lib"") strMsg = strMsg & vbCr & GetEnvironmentVar(""LOGONSERVER"") strMsg = strMsg & vbCr & GetEnvironmentVar(""LOGSERVER"") strMsg = strMsg & vbCr & GetEnvironmentVar(""NUMBER_OF_PROCESSORS"") strMsg = strMsg & vbCr & GetEnvironmentVar(""OS"") strMsg = strMsg & vbCr & GetEnvironmentVar(""Os2LibPath"") strMsg = strMsg & vbCr & GetEnvironmentVar(""Path"") strMsg = strMsg & vbCr & GetEnvironmentVar(""PATHEXT"") strMsg = strMsg & vbCr & GetEnvironmentVar(""PROCESSOR_ARCHITECTURE"") strMsg = strMsg & vbCr & GetEnvironmentVar(""PROCESSOR_IDENTIFIER"") strMsg = strMsg & vbCr & GetEnvironmentVar(""PROCESSOR_LEVEL"") strMsg = strMsg & vbCr & GetEnvironmentVar(""PROCESSOR_REVISION"") strMsg = strMsg & vbCr & GetEnvironmentVar(""ProgramFiles"") strMsg = strMsg & vbCr & GetEnvironmentVar(""SMSHOME"") strMsg = strMsg & vbCr & GetEnvironmentVar(""STARTUPLOG"") strMsg = strMsg & vbCr & GetEnvironmentVar(""SYBASE"") strMsg = strMsg & vbCr & GetEnvironmentVar(""SystemDrive"") strMsg = strMsg & vbCr & GetEnvironmentVar(""SystemRoot"") strMsg = strMsg & vbCr & GetEnvironmentVar(""TEMP"") strMsg = strMsg & vbCr & GetEnvironmentVar(""TMP"") strMsg = strMsg & vbCr & GetEnvironmentVar(""USERDOMAIN"") strMsg = strMsg & vbCr & GetEnvironmentVar(""USERDOMAIN"") strMsg = strMsg & vbCr & GetEnvironmentVar(""UserName"") strMsg = strMsg & vbCr & GetEnvironmentVar(""USERPROFILE"") strMsg = strMsg & vbCr & GetEnvironmentVar(""windir"") MsgBox strMsg, vbInformation, ""Envoronmental variables""  " "Size Bu Örnek Fikir verebilir.Kendi çalışmanıza derlersiniz. A1 Hücresine İstediğiniz zamanı atarsınız.Tabii A1 Hücresini ss:dd:nn biçimlendirmeniz gerek. Kod: Sub basla() Application.OnTime Now + [a1], procedure:=""Mesaj""  Sub Mesaj() MsgBox ""deneme""  " "Sub SearchText() Dim SearchString, SearchChar, MyPos SearchChar = ""salut"" For Each cell In Range(""A1:A11"") SearchString = cell.Text MyPos = InStr(SearchString, SearchChar) If MyPos > 0 Then MsgBox (""Mot trouvé"") MsgBox ""Mot trouvé à cette adresse: "" & cell.Address cell(1, 2).Value = ""(salut) est sur cette ligne"" End If Next " "Sub arabul() ara = Application.InputBox(prompt:=""Aranacak Veri?"", Type:=3) Range(""A3:A341"").Select Selection.Find(What:=ara, After:=ActiveCell, LookIn:=xlFormulas, LookAt _ :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ False, SearchFormat:=False).Activate satir = ActiveCell.Row Range(Cells(satir, 2), Cells(satir, 8)).Select Selection.Copy Sheets(""Sayfa1"").Select Range(""A2"").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True " "Sub Asteriks() 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."" " "Private Sub CommandButton1_Click() Dim FirstMatch As String, strVal As String, MyMsg As String Dim MyData As Variant If Len(TextBox1) >= 1 Then Set MyData = Columns(""C"").Find(TextBox1) If Not MyData Is Nothing Then FirstMatch = MyData.Address Do strVal = strVal & MyData.Address(False, False) & vbCrLf Set MyData = Columns(""C"").FindNext(MyData) Loop While Not MyData Is Nothing And MyData.Address <> FirstMatch End If Else MsgBox ""Aranılacak değeri girin..."" Exit Sub End If If strVal = Empty Then strVal = ""Bulunamadı...."" MyMsg = ""Aranılan değer "" & TextBox1 & "" nın bulunduğu hücreler:"" _ & vbCrLf & String(35, """") MsgBox MyMsg & vbCrLf & strVal Set MyData = Nothing " "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  Sub Check_Values_2() Dim CurCell As Range For Each CurCell In Range(""A1:A10"") If CurCell.Value = 10 Then CurCell.Value = 21 Next " "UserForma Bir TextBox1 ve CommandButton1 ekliyerek aşağıdaki kodları CommandButtonu clikliyerek açacağınız kod sayfasına yazın. 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  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 " "Ancienne version Sub Creation_barre_outil() Application.ScreenUpdating = False Toolbars.Add Name:=""Outils NewGam"" Toolbars(""Outils NewGam"").Visible = True Set BarOutil = Toolbars(""Outils NewGam"").ToolbarButtons BarOutil.Add Button:=214, Before:=1, OnAction:=""Action0"",Enabled:=True,Pushed:=False BarOutil(1).Name = ""Interface"" Set BarOutil = Toolbars(""Outils NewGam"").ToolbarButtons BarOutil.Add Button:=211, Before:=1, OnAction:=""Action1"", Enabled:=True,Pushed:=False BarOutil(1).Name = ""CréeTarifCatalogue"" Set BarOutil = Toolbars(""Outils NewGam"").ToolbarButtons BarOutil.Add Button:=213, Before:=1, OnAction:=""Action2"", Enabled:=True, Pushed:=False BarOutil(1).Name = ""CreeTarifExport"" Set BarOutil = Nothing 'Positionnement de la barre d'outils With Toolbars(""Outils NewGam"") .Left = 620 .Top = 450 .Width = 120 End With  Sub Action0() Range(""a1"").Formula = ""Commande Action0""  Sub Action1() Range(""a2"").Formula = ""Commande Action1""  Sub Action2() Range(""a3"").Formula = ""Commande Action2""  Sub SupprimeBarOutil() On Error Resume Next Toolbars(""Outils NewGam"").Delete " "Sub Auto_open() Eigene_Symbolleiste_erzeugen  Sub Eigene_Symbolleiste_erzeugen() Toolbars.Add Name:=""Eigene_Symbolleiste"" Toolbars(""Eigene_Symbolleiste"").Visible = True With Application .ShowToolTips = True: .LargeButtons = False: .ColorButtons = True End With With Toolbars(""Eigene_Symbolleiste"") .ToolbarButtons.Add Button:=211, Before:=1 .ToolbarButtons(1).OnAction = ""Dieser_Befehl_wird_bei_Klick_ausgeführt"" .ToolbarButtons(1).Name = (""Dieser Text erscheint als Quickinfotext, wenn die Maus an das Symbol gehalten wird"") .Position = xlTop .Left = 1 .Top = 1 End With  Sub Dieser_Befehl_wird_bei_Klick_ausgeführt() MsgBox ""Diese Meldungsbox ist der Befehl, der bei Klick auf das Symbol ausgeführt wird."", vbOKOnly + vbInformation, ""Funktion dieses Symbols""  Sub Eigene_Symbolleiste_löschen() Dim Sym As Toolbar Toolbars(""Eigene_Symbolleiste"").Delete For Each Sym In Toolbars If Sym.Visible = True Then Sym.Left = 1 Next Sym  Sub Auto_close() Eigene_Symbolleiste_löschen " "Sub toolres() For Each tb In Application.Toolbars tb.Reset Next tb " "Private Sub Workbook_Open() Dim CmdB As CommandBar Dim Ctl As CommandBarControl, nCtlC As CommandBarComboBox For Each Ctl In Application.CommandBars(""Worksheet Menu Bar"") _ .Controls If Ctl.Type = msoControlComboBox And _ Ctl.Caption = ""Symbolleistenauswahl"" Then Ctl.Delete End If Next Ctl With Application.CommandBars(""Worksheet Menu Bar"") Set nCtlC = .Controls.Add(Type:=msoControlComboBox, _ Before:=.Controls.Count, Temporary:=True) End With With nCtlC .Caption = ""Symbolleistenauswahl"" .OnAction = ""Me_007_Visible"" For Each CmdB In Application.CommandBars If CmdB.Type = msoBarTypeNormal Then .AddItem CmdB.NameLocal End If Next CmdB .DropDownLines = 20 .Width = 150 .ListIndex = 1 End With  Private Sub Workbook_BeforeClose(Cancel As Boolean) Call Me_007_Delete  Public Sub Me_007_Visible() Dim CmdB As CommandBar Dim CtlC As CommandBarComboBox Dim CmdBName As String 'Dim CmdBName$ Set CtlC = Application.CommandBars(""Worksheet Menu Bar"") _ .Controls(""Symbolleistenauswahl"") CmdBName = CtlC.List(CtlC.ListIndex) For Each CmdB In Application.CommandBars If CmdB.Type = msoBarTypeNormal And _ CmdB.NameLocal = CmdBName Then CmdB.Visible = True Exit Sub End If Next CmdB MsgBox ""Die Symbolleiste '"" & CmdBName & ""' existiert"" & _ "" nicht!"", _ vbInformation, ""CodeBeispiel (Me_007)""  Public Sub Me_007_Delete() On Error Resume Next Application.CommandBars(""Worksheet Menu Bar"") _ .Controls(""Symbolleistenauswahl"").Delete On Error GoTo 0 " "Sub toolbar_disable() For Each tb In Toolbars tb.Visible = False 'true geri getirir Next tb " "Sub auto_open() Application.ScreenUpdating = False For i = 1 To Application.CommandBars.Count Application.CommandBars(i).Enabled = False Next i Application.ScreenUpdating = True  Sub auto_close() Application.ScreenUpdating = False For i = 1 To Application.CommandBars.Count Application.CommandBars(i).Enabled = 1 Next i Application.ScreenUpdating = True " "Private VisibleCmdBs As New Collection Private Sub Workbook_Open() Dim CmdB As CommandBar For Each CmdB In Application.CommandBars If CmdB.Type = msoBarTypeNormal And CmdB.Visible = True Then VisibleCmdBs.Add CmdB, CmdB.Name CmdB.Visible = False End If Next CmdB  Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim CmdB As Object For Each CmdB In VisibleCmdBs CmdB.Visible = True Next CmdB Set VisibleCmdBs = Nothing " "Sub Auto_Open() Application.CommandBars.FindControl(ID:=30007).Enabled = False  Sub Auto_Close() Application.CommandBars.FindControl(ID:=30007).Enabled = True " "Application.ScreenUpdating = False For i = 1 To Cells(65536, 1).End(xlUp).Row If Trim(Cells(i, 1)) <> """" And Trim(Cells(i, 1)) <> ""m.cinsi"" Then Range(i & "":"" & i).EntireRow.Copy Sheets(""sayfa2"").Range(""A65536"").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next i Application.ScreenUpdating = True edit : yukarıdaki örnekteki gibi aplication 'un screenupdate'i daha sonra kullanılmayacaksa, true yapmak mantıksızdır. iş bittiğinde zaten otomatik olarak true olur. sen neden yaptın derseniz, alışkanlık. " "Application.ScreenUpdating = False For i = 1 To Cells(65536, 1).End(xlUp).Row If Trim(Cells(i, 1)) <> """" And Trim(Cells(i, 1)) <> ""m.cinsi"" Then Range(i & "":"" & i).EntireRow.Copy Sheets(""sayfa2"").Range(""A65536"").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next i Application.ScreenUpdating = True edit : yukarıdaki örnekteki gibi aplication 'un screenupdate'i daha sonra kullanılmayacaksa, true yapmak mantıksızdır. iş bittiğinde zaten otomatik olarak true olur. sen neden yaptın derseniz, alışkanlık. " "Sub bul() On Error GoTo 10 aranan = InputBox(""İçeriği girtiniz"", ""Arama Yap"", "" "") cells.Find(aranan).Select Exit Sub 10 MsgBox ""Aranan veri bulunamadı."" " "Sub sil() For i = 1 To Range(""A65536"").End(xlUp).Row If Cells(i, 1) = ""Sunta"" Then Rows(i).Delete End If Next " "Sub Bul_Adres() Find = InputBox(""Aranan değer?"", ""pir"") On Error GoTo yok bul = Cells.Find(Find).Address MsgBox bul, vbInformation, ""Aradığınız kaydın bulunduğu hücre:"" Exit Sub yok: MsgBox ""Kayıt bulunamadı"", vbCritical " "Sub FindItAll() Dim oSheet As Object Dim Firstcell As Range Dim NextCell As Range Dim WhatToFind As Variant WhatToFind = Application.InputBox(""What are you looking for ?"", ""Search"", , 100, 100, , , 2) If WhatToFind <> """" And Not WhatToFind = False Then For Each oSheet In ActiveWorkbook.Worksheets oSheet.Activate oSheet.[a1].Activate Set Firstcell = Cells.Find(What:=WhatToFind, LookIn:=xlValues, LookAt _ :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) If Not Firstcell Is Nothing Then Firstcell.Activate MsgBox (""Found "" & Chr(34) & WhatToFind & Chr(34) & "" in "" & oSheet.Name & ""!"" & Firstcell.Address) On Error Resume Next While (Not NextCell Is Nothing) And (Not NextCell.Address = Firstcell.Address) Set NextCell = Cells.FindNext(After:=ActiveCell) If Not NextCell.Address = Firstcell.Address Then NextCell.Activate MsgBox (""Found "" & Chr(34) & WhatToFind & Chr(34) & "" in "" & oSheet.Name & ""!"" & NextCell.Address) End If Wend End If Set NextCell = Nothing Set Firstcell = Nothing Next oSheet End If " "Private Sub TextBox9_Change() [a1] = Replace(TextBox9, Chr(13), """") " "Sub FlashBack() 'Make cell range Background color, flash x times, x fast, in x color, 'when Ctrla is pressed. Dim newColor As Integer Dim myCell As Range Dim x As Integer Dim fSpeed 'Make this cell range background flash! Set myCell = Range(""A1:M8"") Application.DisplayStatusBar = True Application.StatusBar = ""... Select Cell to Stop and Edit or Wait for Flashing to Stop! "" 'Make cell background 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, 'Gray50% 16, Gray25% 15, Bright Cyan 8. newColor = 11 'Make the cell range flash fast: 0.01 to slow: 0.99 fSpeed = 0.2 'Make cell flash, this many times! Do Until x = 2 'Run loop! DoEvents Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Interior.ColorIndex = newColor Loop Start = Timer Delay = Start + fSpeed Do Until Timer > Delay DoEvents myCell.Interior.ColorIndex = xlNone Loop x = x + 1 Loop Application.StatusBar = False Application.DisplayStatusBar = Application.DisplayStatusBar " "Declare Function SystemParametersInfo Lib ""user32"" Alias ""SystemParametersInfoA"" ( _ ByVal uAction As Long, _ ByVal uParam As Long, _ ByVal lpvParam As Any, _ ByVal fuWinIni As Long) As Long ' Const SPI_SETDESKWALLPAPER = 20 Const SPIF_UPDATEINIFILE = &H1 Const MyPic = ""C:\muhtelif\resim1.bmp"" ' Sub Test() SystemParametersInfo SPI_SETDESKWALLPAPER, ByVal 0&, MyPic, SPIF_UPDATEINIFILE  'none yapmak için .... Const SPI_SETDESKWALLPAPER = 20 Const SPIF_UPDATEINIFILE = &H1 Const MyPic =  "Sub myScrollDown() ActiveWindow.SmallScroll Down:=1 ActiveWindow.ActivateNext ActiveWindow.SmallScroll Down:=1 ActiveWindow.ActivatePrevious  Sub myScrollUp() ActiveWindow.SmallScroll Up:=1 ActiveWindow.ActivateNext ActiveWindow.SmallScroll Up:=1 ActiveWindow.ActivatePrevious " "Sub Down() ActiveCell.Offset(1, 0).Select  Sub up() ActiveCell.Offset(1, 0).Select  Sub Right() ActiveCell.Offset(0, 1).Select  Sub Left() ActiveCell.Offset(0, 1).Select " "Sub Düğme1_Tıklat() e = Application.CountA(Range(""A:A"")) Cells(e, 1).Select Selection.Delete Shift:=xlUp " "Sub PanZehir() CommandBars(""Cell"").Reset  " "Public Sub CopyDown() LastRow = Range(""A65536"").End(xlUp).Row For i = 1 To LastRow If Range(""A"" & i).Value = """" Then Range(""A"" & i  1 & "":CB"" & i  1).Copy Destination:=Range(""A"" & i) End If Next i " "Sub Add_Sheet() Dim Sayfa As Worksheet Dim SayfaAdı As String SayfaAdı = Format(Now, ""mmmm_yyyy"") For Each Sayfa In Worksheets If Sayfa.Name = SayfaAdı Then MsgBox ""Bu isimde bir sayfa bulunmaktadır."" Exit Sub End If Next Sayfa Sheets.Add.Name = SayfaAdı Sheets(SayfaAdı).Move After:=Sheets(Sheets.Count) Sheets(""Sayfa1"").Range(""A:IV"").Copy _ Sheets(SayfaAdı).Range(""A1"") " "Sub NomFeuilMois() For I = 1 To 12 ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = Format(30  I, ""mmmm"") Next I " "Sub DoDays() Dim J As Integer Dim K As Integer Dim sDay As String Dim sTemp As String Dim iTarget As Integer Dim dBasis As Date iTarget = 13 While (iTarget < 1) Or (iTarget > 12) iTarget = Val(InputBox(""Numeric month?"")) If iTarget = 0 Then Exit Sub Wend Application.ScreenUpdating = False sTemp = Str(iTarget) & ""/1/"" & Year(Now()) dBasis = CDate(sTemp) For J = 1 To 31 sDay = Format((dBasis + J  1), ""dddd mmddyyyy"") If Month(dBasis + J  1) = iTarget Then If J <= Sheets.Count Then If Left(Sheets(J).Name, 5) = ""Sheet"" Then Sheets(J).Name = sDay Else Sheets.Add.Move after:=Sheets(Sheets.Count) ActiveSheet.Name = sDay End If Else Sheets.Add.Move after:=Sheets(Sheets.Count) ActiveSheet.Name = sDay End If End If Next J For J = 1 To (Sheets.Count  1) For K = J + 1 To Sheets.Count If Right(Sheets(J).Name, 10) > _ Right(Sheets(K).Name, 10) Then Sheets(K).Move Before:=Sheets(J) End If Next K Next J Sheets(1).Activate Application.ScreenUpdating = True " "Private Sub CommandButton1_Click() Cells([C65536].End(3).Row + 1, ""C"") = TextBox3 TextBox1 = """" TextBox2 = """" TextBox3 = """" UserForm_Initialize  Private Sub UserForm_Initialize() SON = [C65536].End(3).Row + 1 TextBox1 = Cells(SON, ""A"") TextBox2 = Cells(SON, ""B"") TextBox3.SetFocus " "sub songun() Dim MyDate as Date ActiveCell.Value = DateSerial(Year(Now), Month(Now) + 1, 0)  'tarih şimdiki zaman hesaplama Sub ss1() 'As constants the following will not update [a1] = Int(Now) 'date [a2] = Now 'date and time [a3] = Date 'date [a4] = Date + Time 'same as now 'As Worksheet Functions the following will update [a5] = ""=Today()"" 'current date into worksheet formula [a6] = ""=now()"" 'current date [a7] = ""=now()  Today()"" 'current time when recalculated [a7].NumberFormat = ""hh:mm"" [a8] = ""=MOD(NOW(),1)"" 'current time when recalculated [a8].NumberFormat = ""hh:mm"" " "Sub DoMonths() Dim J As Integer Dim K As Integer Dim sMo(12) As String sMo(1) = ""January"" sMo(2) = ""February"" sMo(3) = ""March"" sMo(4) = ""April"" sMo(5) = ""May"" sMo(6) = ""June"" sMo(7) = ""July"" sMo(8) = ""August"" sMo(9) = ""September"" sMo(10) = ""October"" sMo(11) = ""November"" sMo(12) = ""December"" For J = 1 To 12 If J <= Sheets.Count Then If Left(Sheets(J).Name, 5) = ""Sheet"" Then Sheets(J).Name = sMo(J) Else Sheets.Add.Move after:=Sheets(Sheets.Count) ActiveSheet.Name = sMo(J) End If Else Sheets.Add.Move after:=Sheets(Sheets.Count) ActiveSheet.Name = sMo(J) End If Next J For J = 1 To 12 If Sheets(J).Name <> sMo(J) Then For K = J + 1 To Sheets.Count If Sheets(K).Name = sMo(J) Then Sheets(K).Move Before:=Sheets(J) End If Next K End If Next J Sheets(1).Activate " "Option Explicit Sub CreateMonths() Dim lDay As Long Dim iWks As Integer, iDay As Integer For iWks = 1 To 12 Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = Format(DateSerial(1, iWks, 1), ""mmmm"") For lDay = DateSerial(Year(Date), iWks, 1) To DateSerial(Year(Date), iWks + 1, 0) iDay = iDay + 1 Cells(iDay, 1).Value = DateSerial(Year(Date), iWks, iDay) Next lDay iDay = 0 Next iWks Worksheets(1).Select  Sub GotoToDay() Dim iRow As Integer Worksheets(Month(Date) + 1).Select iRow = WorksheetFunction.Match(CDbl(Date), Columns(1), 0) Cells(iRow, 1).Select  'Kodun çalıştırılacağı aktif sayfaya Option Explicit" "Sub Jahreskalender() Dim strJahr As String Dim lngNumSheets As Long Dim intI As Integer, intJahr As Integer strJahr = InputBox(""Kalender anlegen für Jahr:"", , Year(Date)) If strJahr = """" Or Not IsNumeric(strJahr) Then Exit Sub intJahr = CInt(strJahr) lngNumSheets = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 12 Workbooks.Add Application.SheetsInNewWorkbook = lngNumSheets Application.DisplayAlerts = False Application.ScreenUpdating = False Windows(1).Caption = ""Jahreskalender "" & strJahr For intI = 1 To 12 Worksheets(intI).Activate Call MonatAnlegen(intJahr, intI) Next intI Application.DisplayAlerts = True Application.ScreenUpdating = True  Private Sub MonatAnlegen(intJahr As Integer, intMonat As Integer) Dim intI As Integer Dim lngDate As Long lngDate = CLng(DateSerial(intJahr, intMonat, 1)) ActiveSheet.Name = Format(lngDate, ""mmmm"") 'zB ""Januar"" Range(""A1"") = ""Datum"" Range(""C1"") = ""Eintragung"" Range(""D1"") = ""Geburtstage"" With Range(""A1:D1"") With .Font .Bold = True .Size = 10 .ColorIndex = 6 End With .Interior.ColorIndex = 11 End With intI = DateSerial(intJahr, intMonat + 1, 1)  lngDate + 1 Range(""A2"") = lngDate Range(""A3"").Formula = ""=A2+1"" Range(""A3:A"" & intI).FillDown Range(""A2:A"" & intI).Copy Range(""A2:A"" & intI).PasteSpecial (xlValues) Range(""A2:A"" & intI).NumberFormat = ""dd.mm.yy"" Columns(1).Copy Columns(2) Range(""B1"") = ""Tag"" Range(""B1"").HorizontalAlignment = xlRight Range(""B2:B"" & intI).NumberFormat = ""dddd"" 'zB ""Samstag"" Range(""C2"").Select intI = 2 Do Until IsEmpty(Cells(intI, 1)) Select Case Weekday(Cells(intI, 1)) Case vbSaturday Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 40 'Orange Case vbSunday Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 3 'Rot End Select Cells(intI, 3).Value = Feiertag(Cells(intI, 1).Value) intI = intI + 1 Loop ActiveSheet.UsedRange.Columns.AutoFit  'http://home.tonline.de/home/t.igel/xlostern.htm Private Function Feiertag(datum As Long) As String Dim temp As Variant Feiertag = """" Select Case Month(datum) Case 1 Select Case Day(datum) Case 1 Feiertag = ""Neujahr"" Case 6 Feiertag = ""Heiligen 3 Könige"" End Select Case 2 To 6 osSo = OsterSo(Year(datum)) Select Case datum Case osSo  48 Feiertag = ""Rosenmontag"" Case osSo  47 Feiertag = ""Fasching"" Case osSo  46 Feiertag = ""Aschermittwoch"" Case osSo  2 Feiertag = ""Karfreitag"" Case osSo  1 Feiertag = ""Karsamstag"" Case osSo Feiertag = ""Ostersonntag"" Case osSo + 1 Feiertag = ""Ostermontag"" Case DateSerial(Year(datum), 5, 1) Feiertag = ""Tag der Arbeit"" Case osSo + 39 Feiertag = ""Christi Himmelfahrt"" Case osSo + 48 Feiertag = ""Pfingstsamstag"" Case osSo + 49 Feiertag = ""Pfingstsonntag"" Case osSo + 50 Feiertag = ""Pfingstmontag"" Case osSo + 60 Feiertag = ""Fronleichnam"" End Select Case 8 Select Case Day(datum) Case 15 Feiertag = ""Maria Himmelfahrt"" End Select Case 10 Select Case Day(datum) Case 3 Feiertag = ""Tag der Dt. Einheit"" End Select Case 11 temp = DateSerial(Year(datum), 12, 25) Select Case datum Case DateSerial(Year(datum), 11, 1) Feiertag = ""Allerheiligen"" Case (temp  Weekday(temp, vbMonday)  32) Feiertag = ""Buß und Bettag"" End Select Case 12 Select Case Day(datum) Case 24 Feiertag = ""Heilig Abend"" Case 25 Feiertag = ""1. Weihnachtsfeiertag"" Case 26 Feiertag = ""2. Weihnachtsfeiertag"" Case 31 Feiertag = ""Silvester"" End Select End Select  Private Function OsterSo(jahr As Integer) As Variant Dim d As Variant d = (((255  11  (jahr Mod 19))  21) Mod 30) + 21 OsterSo = DateSerial(jahr, 3, 1) + d + (d > 48) + _ 6  ((jahr + jahr \ 4 + d + (d > 48) + 1) Mod 7)   Ayları sayfa olarak ekler günleri ayrıntılı olarak belirtir Option Explicit Sub Kalender_erstellen() Dim i As Integer, x As Integer, alt As Integer Dim WS As Worksheet Dim Jahr As Integer Jahr = InputBox(""Bitte Das Jahr 4stellig 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  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  B1127B1141" "Sub CreateMonths() Dim lDay As Long Dim iWks As Integer, iDay As Integer For iWks = 1 To 12 Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = Format(DateSerial(1, iWks, 1), ""mmmm"") For lDay = DateSerial(Year(Date), iWks, 1) To DateSerial(Year(Date), iWks + 1, 0) iDay = iDay + 1 Cells(iDay, 1).Value = DateSerial(Year(Date), iWks, iDay) Next lDay iDay = 0 Next iWks Worksheets(1).Select  Sub GotoToDay() Dim iRow As Integer Worksheets(Month(Date) + 1).Select iRow = WorksheetFunction.Match(CDbl(Date), Columns(1), 0) Cells(iRow, 1).Select " "Private Sub UserForm_Initialize() UserForm1.StartUpPosition = 0 UserForm1.Top = 10 UserForm1.Left = 10 " "Sub als_text_speichern() Dim iRow As Long, strDatei As String, iLastRow As Integer iLastRow = Sheets(1).Cells(65536, 1).End(xlUp).Row strDatei = ThisWorkbook.Path & ""\test1.txt"" Open strDatei For Output As #1 For iRow = 1 To iLastRow Print #1, Format(Cells(iRow, 1), ""#0.00""); Chr(9); Print #1, Format(Cells(iRow, 2), ""YYYYMMDD""); Chr(9); Print #1, Cells(iRow, 3) Next iRow Close #1 " "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Cells.Address <> ""$A$2"" Then Exit Sub If [b1] = Empty Then [b1] = ""="" If IsNumeric([a1]) And [a1] <> 0 Then [b1].Formula = [b1].Formula & ""+"" & [a1] " "Private Sub cmbkaydet_Click() Dim i As Integer Sheets(""Sayfa1"").Select ' önce textoxları kontrol edelim If txtadet.Value = """" Or txtkilo.Value = """" Or txtfiyat.Value = """" Then MsgBox ""Eksik taımlama yapmışsınız!"" Exit Sub End If ' Şimdi de aynı fiyattan varmı diye bakalım ' varsa üzerine toplayalım ' yoksa alttaki boş satıra gidelim For i = 1 To 18 If txtfiyat.Value  1 = Cells(i, 3) Then Cells(i, 1) = Cells(i, 1) + txtadet.Value Cells(i, 2) = Cells(i, 2) + txtkilo.Value Cells(i, 3) = Cells(i, 3) GoTo AtlaSona Else If Cells(i, 3).Value = """" Then Cells(i, 1) = txtadet.Value Cells(i, 2) = txtkilo.Value Cells(i, 3) = txtfiyat.Value GoTo AtlaSona End If End If Next i MsgBox ""18 satırınız da dolmuş"" Exit Sub AtlaSona: txtadet.Value = """" txtkilo.Value = """" txtfiyat.Value = """" MsgBox ""Kaydedildi"" txtadet.SetFocus " "For x = 2 To Cells(65536, 3).End(xlUp).Row If WorksheetFunction.CountIf(Range(""c2:c"" & x), Cells(x, 3)) = 1 Then ComboBox1.AddItem Cells(x, 3).Value End If Next" "Private Sub cmbkaydet_Click() Dim i As Integer Sheets(""Sayfa1"").Select ' önce textoxları kontrol edelim If txtadet.Value = """" Or txtkilo.Value = """" Or txtfiyat.Value = """" Then MsgBox ""Eksik taımlama yapmışsınız!"" Exit Sub End If Dim j As Integer, k As Integer j = 1 k = 3 BASADONELIM: ' Şimdi de aynı fiyattan varmı diye bakalım ' varsa üzerine toplayalım ' yoksa alttaki boş satıra gidelim For i = k To k + 15 If txtfiyat.Value  1 = Cells(i, j + 2) Then Cells(i, j) = Cells(i, j) + txtadet.Value Cells(i, j + 1) = Cells(i, j + 1) + txtkilo.Value Cells(i, j + 2) = Cells(i, j + 2) GoTo AtlaSona Else If Cells(i, j + 2).Value = """" Then Cells(i, j) = txtadet.Value Cells(i, j + 1) = txtkilo.Value Cells(i, j + 2) = txtfiyat.Value GoTo AtlaSona End If End If Next i If i = k + 16 And j < 16 Then '18satır dolu ve son sütunlar boş ise j = j + 5 'AFKP şeklinde 1 den başlayıp 5er 5er ilerledik GoTo BASADONELIM Else If k < 72 And j = 16 Then j = 1 k = k + 23 GoTo BASADONELIM Else If k = 72 And j = 16 Then j = 1 k = 120 GoTo BASADONELIM Else If k < 166 And j = 16 Then j = 1 k = k + 23 GoTo BASADONELIM Else If k = 166 And j = 16 Then Msgox "" tüm aralıklar dolu"" End If End If End If End If End If AtlaSona: txtadet.Value = """" txtkilo.Value = """" txtfiyat.Value = """" txtadet.SetFocus MsgBox ""Kaydedildi"" " "Sub Auto_Open() Sheets(""Sayfa2"").Select " "isimgir = TextBox3.Text satırından sonra For i = 1 To Sheets.Count If Sheets(i).Name = isimgir Then MsgBox ""Aynı isimde sayfa var"" Exit Sub End If Next i" "Private Sub CommandButton1_Click() If Not TextBox3.Text = Empty Then For i = 1 To Worksheets.Count If Sheets(i).Name = TextBox3.Text Then MsgBox ""Bu isimli bir sayfa mevcut..... !"" Exit Sub End If Next Set NewSh = Worksheets.Add(After:=Sheets(Sheets.Count)) NewSh.Name = TextBox3.Text End If Set NewSh = Nothing " "Bu kodları denermisin..Yalnız kaydetmek istediğin hücrelerde veri doğrulama ile yapılmış kısımlar var.Onları halletmen gerek.. Kod: Private Sub CommandButton5_Click() If TextBox14.Value <> """" Then Sheets(""Cari Kart"").Activate Cells(8, 1).Select Do While ActiveCell.Value <> """" If Trim(ActiveCell.Value) = Trim(Me.TextBox15.Value) Then If MsgBox(Me.TextBox15 & "" Dosya Numaralı Ürün Kaydı Var"" & "" Yeniden Kayıt Yapılsın mı?"", vbYesNo, ""Mükerrer Kayıt"") = vbNo Then Exit Sub End If ActiveCell.Offset(1, 0).Activate Loop ActiveCell.Value = TextBox14.Value ActiveCell.Offset(0, 1).Value = TextBox15.Value ActiveCell.Offset(0, 2).Value = TextBox16.Value ActiveCell.Offset(0, 3).Value = TextBox19.Value 'diyelimki Bundan sonrakileri Sayfa2'ye kaydedeceksiniz. 'Sheets(""Sayfa2"").Select ile verileri kaydetmek istediğiniz sayfaya geçiyor 'Range (""A1).Select Aktif hücreyi seçerek kaydı tamamlıyor. Sheets(""Kasa"").Select Range(""B8"").Select ActiveCell.Offset(1, 0).Activate ActiveCell.Value = TextBox14.Value ActiveCell.Offset(0, 1).Value = TextBox15.Value ActiveCell.Offset(0, 2).Value = TextBox16.Value ActiveCell.Offset(0, 3).Value = TextBox19.Value 'Kasa sayfasına kayıtlar B8 hücresinden başlaması gerekiyor 'TextBox14 deki bilgiler B sütununa atılıyor ActiveCell.Offset(0, 2).Value = TextBox14.Value 'TextBox17 deki bilgiler C sütununa atılıyor ActiveCell.Offset(0, 3).Value = TextBox17.Value 'TextBox20 deki bilgiler E sütununa atılıyor ActiveCell.Offset(0, 5).Value = TextBox20.Value End If  " "Sub listele() [a2:p65536].ClearContents For a = 2 To Sheets.Count Set s1 = Sheets(a) For b = 2 To s1.[w65536].End(3).Row c = c + 1 Cells(c + 1, ""a"") = s1.[b1] Cells(c + 1, ""b"") = s1.[b8] For sut = 1 To 14 Cells(c + 1, sut + 2) = s1.Cells(b, sut + 22) Next Next Next  " "Sub AKTAR() Set s1 = [Sayfa1] Set s2 = [Sayfa2] s1.Select s1_son = s1.[A65536].End(3).Row S2_SON = s2.[A65536].End(3).Row For x = 2 To S2_SON For y = 2 To s1_son If s1.Cells(y, 1) = s2.Cells(x, 1) Then For z = 2 To 11 s2.Cells(x, z + 8) = s1.Cells(y, z) Next z Exit For End If Next y Next s2.Select " "Sub Spalte() Dim s As Integer Dim z As Integer Dim t As String Dim u As String s = ActiveCell.Column z = ActiveCell.Row t = Columns(s).Address(0, 0) u = Rows(z).Address(0, 0) MsgBox ""Spaltennummer: "" & s & Chr$(13) & Chr$(13) & ""Spaltenbuchstabe(n): "" & Left(t, InStr(t, "":"")  1) & Chr$(13) & Chr$(13) & ""Zeilennummer: "" & Left(u, InStr(u, "":"")  1) & Chr$(13) & Chr$(13) & ""Adresse: "" & Left(t, InStr(t, "":"")  1) & Left(u, InStr(u, "":"")  1), _ vbOKOnly, ""Adresse der aktiven Zelle ..."" " "Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim s As Integer Dim z As Integer Dim t As String Dim u As String s = ActiveCell.Column z = ActiveCell.Row t = Columns(s).Address(0, 0) u = Rows(z).Address(0, 0) MsgBox ""Sütun numarası: "" & s & Chr$(13) & Chr$(13) & ""Sütun Adı: "" & Left(t, InStr(t, "":"")  1) & Chr$(13) & Chr$(13) & ""Satır Numarası: "" & Left(u, InStr(u, "":"")  1) & Chr$(13) & Chr$(13) & ""Hücre Adresi: "" & Left(t, InStr(t, "":"")  1) & Left(u, InStr(u, "":"")  1), _ vbOKOnly, ""Ayrıntılı aktif hücre adresleri"" " "Sub Zelladresse() Worksheets(1).Select With ActiveCell MsgBox .Address MsgBox .Address(False) MsgBox .Address(, False) MsgBox .Address(False, False) MsgBox .Row MsgBox .Column MsgBox ""Zeile: "" & .Row & _ ""  Spalte:"" & .Column End With " "Bir alternatif, Sub test(yol As String, dosyaadi As String, sayfaadi, range As String) With ActiveSheet.Range(range) .FormulaArray = ""='"" & yol & ""\["" & dosyaadi & ""]"" & sayfaadi & ""'!"" & range .Value = .Value End With  çağırma örneği test (""C:\klasoradi"", ""kitap.xls"",""sayfa1"", ""A1"") kapalı c:\klasoradi\kitap.xls dosyasının sayfa1 sayfasındaki a1 hücresini alır. Bir diğer alternatif Applicaiton.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False Set kitap = Workbooks.Open (""c:\klasor\kitapadi.xls"") cells(1,1) = kitap.Worksheets(""sayfa1"").cells(1,1) Applicaiton.ScreenUpdating = True Application.EnableEvents = True Application.DisplayAlerts = True kapalı c:\klasor\kitapadi.xls sayfa1 sayfasındaki a1 hücresini alır." "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If ActiveCell.Column = 2 And ActiveCell.Row > 1 And ActiveCell.Row < 22 Then Kalender.Show " "Sub mukerrersil() Dim i, y, a As Integer a = WorksheetFunction.CountA(Range(""b1:b65000"")) For i = 1 To a For y = i + 1 To a If Cells(i, 1).Value = Cells(y, 1) Then Cells(i, 1).Value = Cells(i, 1).Value Cells(y, 1).Value = Cells(y, 1).Value Cells(y, 1).EntireRow.Delete End If Next y Next i " "Private Sub Worksheet_BeforeDoubleClick(ByVal Target _ As Range, Cancel As Boolean) Cancel = True If Target.Row = 1 Then Exit Sub If Target.Column <> 2 Then Exit Sub On Error Resume Next Application.EnableEvents = False Target.Value = Target.Value + 1 Application.EnableEvents = True If Err.Number <> 0 Then MsgBox ""Unable to add 1 to value in cell "" _ & Target.Address(0, 0) End If " "Private Sub Worksheet_BeforeDoubleClick(ByVal _ Target As Range, Cancel As Boolean) If Target.Column <> 2 Then Exit Sub If Not IsNumeric(Target) Then Exit Sub Cancel = True Dim i As Long, curv As Long, tov As Long curv = Target.Value tov = InputBox(""supply new total rows"", _ ""Rows input"", curv + 1) If tov < curv Then Exit Sub For i = curv + 1 To tov Cells(Target.Row + i  1, 1).EntireRow.Insert Cells(Target.Row + i  1, 3) = i Cells(Target.Row, 2) = i Next i " "Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) rowoffset = 0 Intersect(ActiveCell.EntireRow, Columns(""A"")).Value = ActiveCell.Row + rowoffset " "Sub test() Dim ra As Range, rb As Range For Each rb In [B1:B100] For Each ra In [A1:A100] If InStr(1, ra, rb) > 0 And rb <> """" Then ra.ClearContents Next ra Next rb " "Sub mukerrersil() Dim i, y, a As Integer a = WorksheetFunction.CountA(Range(""b1:b65000"")) For i = 1 To a For y = i + 1 To a If Cells(i, 1).Value = Cells(y, 1) Then Cells(i, 1).Value = Cells(i, 1).Value Cells(y, 1).Value = Cells(y, 1).Value Cells(y, 1).EntireRow.Delete End If Next y Next i " "Sub aktar() Application.ScreenUpdating = False Dim s(2) Set s(1) = Sheets(""ATÖLYE RAPORU"") Set s(2) = Sheets(""BAKIM RAPORU"") For a = 1 To 2 For b = 3 To s(a).[a65536].End(3).Row Set s3 = Sheets("""" & s(a).Cells(b, ""b"")) sonsat = s3.[a65536].End(3).Row + 1 If s(a).Cells(b, ""d"") = ""x"" Then GoTo 10 s3.Cells(sonsat, ""a"") = s(a).Cells(b, ""a"") s3.Cells(sonsat, ""b"") = s(a).Cells(b, ""c"") s(a).Cells(b, ""d"") = ""x"" s3.[a3:b65536].Sort Key1:=s3.[a3] 10 Next: Next s(1).Select MsgBox ""VERİLER AKTARILDI"" " "Sub Test() Dim MyRng As Range Dim NoB As Long NoB = Cells(65536, 2).End(xlUp).Row For Each MyRng In Range(""B2:B"" & NoB) If MyRng.Offset(0, 1) = """" Then MyRng.Offset(0, 1) = MyRng Next " "Option Explicit Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Column <> 2 Then Exit Sub If Target.Row = 1 Then Exit Sub If Left(Target.Offset(0, 1), 1) = ""~"" Then Exit Sub If Left(Target.Offset(0, 1), 1) = ""~"" Then Exit Sub If Left(Target.Offset(0, 1), 1) = ""=Row()1"" Then Exit Sub Target.Offset(0, 1).Formula = ""=Row()1"" " "Sub xlslistele() Dim pir As Integer With Application.FileSearch .LookIn = Range(""B1"").Value .Filename = "".xls"" .Execute For pir = 1 To .FoundFiles.Count Cells(pir + 1, 1).Value = Dir(.FoundFiles(pir)) Next pir End With " "Sub clock() If ThisWorkbook.Worksheets(1).Range(""B1"").Value = ""X"" Then Exit Sub ThisWorkbook.Worksheets(1).Range(""A1"").Value = Format(Now, ""hh:mm:ss AM/PM"") Application.OnTime Now + TimeSerial(0, 0, 1), ""clock"" " "Sub ResetTest1() For Each n In Range(""B1:G13"") If n.Value <> 0 Then n.Value = 0 End If Next n " "Private Sub Workbook_Open() ActiveSheet.Unprotect If [b2] = """" Then [b2] = Date ActiveSheet.Protect " "Modüle Function MakroStart() Application.Volatile Tut  Sub Tut() MsgBox (""Tuuuuuuuuut"")  'C2 ye =EĞER(B2>10;MakroStart();""Nix"") yaz 'B2 ye 11 yaz makro çalışsın" "alt+f11 den sonra çalışma kitabı bölümüne Kod: Private Sub Workbook_BeforeClose(Cancel As Boolean) Start = False  Private Sub Workbook_Open() Zeitmakro Zeit = Time Start = True  sonra makro bölümüne Kod: Public Zeit As Date Public Start As Boolean Sub Zeitmakro() Application.OnTime Now + TimeValue(""00:00:01""), ""Zielmakro""  Sub Zielmakro() Range(""B2"").Value = Format(Time, ""hh:mm:ss"") Range(""B3"").Value = Format(Time  Zeit, ""hh:mm:ss"") If Start = True Then Call Zeitmakro  " "Sub EnterInfo() Dim i As Integer Dim cel As Range 'Set cel = [B3] Set cel = ActiveCell For i = 1 To 10 cel(i).Value = [B1].Value  1 + i Next i cel(i).Value = ""=SUM(R[10]C:R[1]C)"" " "Option Explicit Dim bln As Boolean Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim wks As Worksheet Dim strName As String Dim rng As Range Dim StAr() Dim InI As Integer Set rng = Sheets(""Eingabe"").Range(""B3"") 'hier ""Auslesezelle"" für neuen TabBlattNamen anpassen If Target.Address = rng.Address Then bln = True If bln = True And Target.Address <> rng.Address Then If Len(rng) < 1 Or Len(rng) > 31 Then MsgBox ""Bitte min. 1 und max. 31 Zeichen eingeben !"" bln = False Exit Sub End If StAr = Array("":"", ""/"", ""\"", ""?"", ""["", ""]"") For InI = 0 To UBound(StAr) If InStr(1, rng, StAr(InI), 0) > 0 Then MsgBox ""Sonderzeichen ' "" & StAr(InI) & "" ' nicht zulässig !"" bln = False Exit Sub End If Next InI For Each wks In ActiveWorkbook.Worksheets If UCase(wks.Name) = UCase(rng) Then MsgBox ""Es existiert bereits ein Tabellenblatt mit diesem Namen !"" bln = False Exit Sub End If Next Sheets.Add.Move after:=Sheets(""Eingabe"") ActiveSheet.Name = rng.Value Sheets(""Eingabe"").Select bln = False End If " "Sub Nodefil() Feuil1.ScrollArea = ""B4:H23""  Sub Okdefil() ' pour libérer le défilement Feuil1.ScrollArea = """" " "Sub Test() Dim i As Long, No As Long For i = 5 To Cells(65536, 2).End(xlUp).Row If Cells(i, 2) <> Empty Then No = No + 1 Cells(i, 1) = No Else Cells(i, 1) = Empty End If Next  " "Sayfanın kod bölümüne 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 " " ‘Kullanımı : A1 e sayı yaz başka bir hücreye =bas_top(A1) Function bas_top(hucre As Range) As Integer Dim intI% For intI = 1 To Len(hucre) bas_top = bas_top + CInt(Mid(hucre, intI, 1)) Next " "Private Declare Function IsCharAlpha Lib ""user32"" Alias ""IsCharAlphaA"" (ByVal cChar As Byte) As Long Private Declare Function IsCharAlphaNumeric Lib ""user32"" Alias ""IsCharAlphaNumericA"" (ByVal cChar As Byte) As Long Private Declare Function IsCharLower Lib ""user32"" Alias ""IsCharLowerA"" (ByVal cChar As Byte) As Long Private Declare Function IsCharUpper Lib ""user32"" Alias ""IsCharUpperA"" (ByVal cChar As Byte) As Long Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) Dim strSave As String If IsCharAlphaNumeric(KeyAscii) Then strSave = "" Sayısal"" If IsCharAlpha(KeyAscii) Then strSave = ""Bu karakter"" If IsCharLower(KeyAscii) Then strSave = strSave & "" Küçük"" If IsCharUpper(KeyAscii) Then strSave = strSave & "" Büyük"" MsgBox ""Bastığın tuş: "" & Chr$(KeyAscii) & Chr(10) & strSave " "Sub PrtPvw() ActiveSheet.PrintPreview False ‘Değişikliğe izin vermez True verir.’ ActiveWindow.View = xlNormalView " "Private Sub CommandButton1_Click() Me.Hide Sheets(""Sayfa1"").Select ActiveWindow.SelectedSheets.PrintPreview Me.Show " Application.Dialogs(xlDialogPrint).Show "Sub PrtPvw() ActiveSheet.PrintPreview False '""False""==> ‘Değişikliğe izin vermez True verir.’ ActiveWindow.View = xlNormalView " "Private Sub Workbook_BeforePrint(Cancel As Boolean) Cancel = True " "Private Sub TextBox1_Change() TextBox1.Value = UCase(TextBox1.Value) Dim i As Integer ListBox1.Clear For i = 1 To Worksheets.Count  9 If Left(Worksheets(i).Name, Len(TextBox1)) = TextBox1 Then ListBox1.AddItem Worksheets(i).Name End If Next " "user formundaki kapat tuşunun altına aşağıdaki kodu yazıp dener misin ? visual basic kodu:  Dismi = ActiveWorkbook.Name ActiveWorkbook.SaveCopyAs ""C:\caria1\maltakipyedek\ "" & Dismi ActiveWorkbook.Save Unload Me Windows(2).Activate With Workbooks(""maltakip.xls"") .Close False End With" "Sub AddSaveAsNewWorkbook() Dim Wk As Workbook Set Wk = Workbooks.Add Application.DisplayAlerts = False Wk.SaveAs Filename:=""C:/MyData/SalesData.xls"" " "öncelikle ""İzin"" isimli dosyanızdaki bir module aşağıdaki kodu yazın. visual basic kodu: Sub ac() UserForm1.Show  Daha sonra ""personel"" isimli dosyanızda bulunan userformun üzerindeki command butonada aşağıdaki kodu yazın. Private Sub CommandButton1_Click() Unload Me Application.Run ""izin.xls!ac""  " Workbook (“KİTAP.XLS”).Worksheets(“Tablo1”).Range(“D8”).Clear "Private Sub UserForm_Initialize() For i = 1 To 20 ActiveSheet.Range(""A1"").Formula = _ ""='C:\Yeni Klasör (2)\[Deneme.xls]Sayfa1'!C"" & i UserForm1.ComboBox1.AddItem (Range(""A1"").Value) Next i Range(""A1"").Value = """" " "Sub FileOpened() Dim MyFile As String MyFile = ""C:\den\A.xls"" On Error GoTo FileInUse Open MyFile For Binary Access Read Lock Read As #1 Close #1 MsgBox ""Dosya daha önceden kullanımda değil, açabilirsiniz !"" Workbooks.Open MyFile Exit Sub FileInUse: MsgBox ""Dosya şu anda başkası tarafından kullanılmakta !""  " "Private Declare Function FindWindow Lib ""user32"" Alias ""FindWindowA"" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SetWindowPos Lib ""user32"" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Const Gizle = &H80 Const Goster = &H40 Private Sub CommandButton1_Click() Dim hWnd1 As Long hWnd1 = FindWindow(""Shell_traywnd"", """") Call SetWindowPos(hWnd1, 0, 0, 0, 0, 0, Gizle)  Private Sub CommandButton2_Click() Dim hWnd1 As Long hWnd1 = FindWindow(""Shell_traywnd"", """") Call SetWindowPos(hWnd1, 0, 0, 0, 0, 0, Goster) " "Option Explicit Dim handleW1 As Long Private Declare Function FindWindowA Lib ""user32"" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Private Declare Function SetWindowPos Lib ""user32"" _ (ByVal handleW1 As Long, _ ByVal handleW1InsertWhere As Long, ByVal w As Long, _ ByVal x As Long, ByVal y As Long, ByVal z As Long, _ ByVal wFlags As Long) As Long Const TOGGLE_HIDEWINDOW = &H80 Const TOGGLE_UNHIDEWINDOW = &H40 Sub masque() handleW1 = FindWindowA(""Shell_traywnd"", """") Call SetWindowPos(handleW1, 0, 0, 0, 0, 0, TOGGLE_HIDEWINDOW)  Sub affiche() Call SetWindowPos(handleW1, 0, 0, 0, 0, 0, TOGGLE_UNHIDEWINDOW) " "Option Explicit Private Declare Sub keybd_event Lib ""user32"" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Const VK_CONTROL = &H11 Const KEYEVENTF_KEYUP = &H2 Const VK_ESCAPE = &H1B Sub baslat_ac() Call keybd_event(VK_CONTROL, 0, 0, 0) Call keybd_event(VK_ESCAPE, 0, 0, 0) Call keybd_event(VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0) Call keybd_event(VK_CONTROL, 0, KEYEVENTF_KEYUP, 0) " "Option Explicit Private Declare Function FindWindow Lib ""user32"" Alias ""FindWindowA"" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindow Lib ""user32"" (ByVal hwnd As Long, _ ByVal wCmd As Long) As Long Private Declare Function GetWindowRect Lib ""user32"" (ByVal hwnd As _ Long, lpRect As RECT) As Long Private Declare Function ReleaseCapture Lib ""user32"" () As Long Private Declare Function SendMessage Lib ""user32"" Alias ""SendMessageA"" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function CreateRectRgn Lib ""gdi32"" (ByVal X1 As Long, _ ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 FensterRegion&, Region& Private Hauptfensternummer&, Clientfensternummer& Private dummy As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Const GW_CHILD = 5 Private Const WM_NCLBUTTONDOWN = &HA1 Private Const HTCAPTION = 2 Private Sub UserForm_Initialize() Call pirullah  Sub pirullah() Dim Abmessung As RECT Dim Abmessung1 As RECT Dim Pos1x&, Pos1y&, Pos2x&, Pos2y& If FensterRegion <> 0 Then Exit Sub UserForm1.BorderStyle = fmBorderStyleSingle Call Fensternummer(UserForm1, Abmessung, Abmessung1) Pos1x = 0 Pos1y = (Abmessung1.Top  Abmessung.Top) Pos2x = Abmessung.Right  Abmessung.Left Pos2y = Abmessung.Bottom  Abmessung.Top Region = CreateRectRgn(Pos1x, Pos1y, Pos2x, Pos2y) FensterRegion = SetWindowRgn(Hauptfensternummer, Region, True)  Private Sub Fensternummer(Form As Object, Abmessung As RECT, Abmessung1 As RECT) Dim Fenstername$, Suchstring$ Suchstring = ""UserForm ohne Titelzeile"" Fenstername = Form.Caption Form.Caption = Suchstring Hauptfensternummer = FindWindow(vbNullString, Suchstring) Form.Caption = Fenstername Clientfensternummer = GetWindow(Hauptfensternummer, GW_CHILD) dummy = GetWindowRect(Hauptfensternummer, Abmessung) dummy = GetWindowRect(Clientfensternummer, Abmessung1)  Private Sub CommanButton1_Click() Unload Me " "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  Private Sub CommandButton1_Click() Unload Me " "Private Sub UserForm_Activate() 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 If LCase(Sheets(i).Name) <> (""ana sayfa"") _ And LCase(Sheets(i).Name) <> (""toplam"") _ And LCase(Sheets(i).Name) <> (""stok"") _ And LCase(Sheets(i).Name) <> (""sayfa1"") Then ComboBox1.AddItem Sheets(i).Name End If Next Sheets(""ana sayfa"").Move Before:=Sheets(2) " "Option Explicit Declare Function Beep Lib ""Kernel32"" (ByVal Fq As Long, ByVal Tm As Long) As Long Sub Warnung() Beep 392, 200 Beep 494, 100 Beep 588, 200 Beep 740, 100 Beep 880, 400 Beep 740, 100 Beep 880, 900 " "‘DoEvents kullanırsanız bekleme süresince program kilitlenmez. Dim basla Dim bekle basla = Timer bekle = 2 While Timer < basla + bekle DoEvents '2 saniye bekle Wend" "Sub MsgBarreEtat() barreEtatEnregistrée = Application.DisplayStatusBar Application.DisplayStatusBar = True Application.StatusBar = ""Création du tarif catalogue.....Veuillez patienter, SVP....."" '....exécution d'une macro (généralement long)..... Application.Wait Now + TimeValue(""00:00:04"") Application.StatusBar = False Application.DisplayStatusBar = barreEtatEnregistrée  Sub MsgHeure() mheure = Time MsgBox (""Il est: "" & mheure) " "Sub Pause() Application.OnTime Now+TimeValue(""00:00:01""), ""NextMacro"" " "Sub bekletmeli_mesaj() MsgBox ""Selamun Aleyküm OK !"" saatsimdi = Hour(Now()) dakikasimdi = Minute(Now()) saniyesimdi = Second(Now()) + 10 zamansayaci = TimeSerial(saatsimdi, dakikasimdi, saniyesimdi) Application.Wait zamansayaci Beep MsgBox ""Ve Aleyküm Selam! Kusura bakma 10 saniye sonra oldu ama."" " "Sub StatusBarExample() Application.ScreenUpdating = False ' turns off screen updating Application.DisplayStatusBar = True ' makes sure that the statusbar is visible 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 ' gives control of the statusbar back to the programme " "Sub LanceProgramme() ValRetour = Shell(""C:\WINDOWS\EXPLORER.EXE"", 1) Application.Wait Now + TimeValue(""00:00:04"") SendKeys ""%{F4}"", True ' Envoie Alt+F4 pour fermer l'application EXPLORER. " "Sub Lanc_Explorateur() Shell ""explorer.exe"", vbMaximizedFocus " "Aşağıdaki kodu thisworkbook sayfasına kopyalayarak deneyin. Private Sub Workbook_SheetActivate(ByVal Sh As Object) deg=IIf(ActiveSheet.Name = ""Sayfa1"", True, False) With Application .FixedDecimal =deg .FixedDecimalPlaces = 2 End With  bu işlemi sayfa üzerinde buton ile yapmak istiyorsanız aşağıdaki kodları deneyebilirsiniz. Sub Button1_Click() If ActiveSheet.Name = ""Sayfa1"" Then With Application .FixedDecimal = True .FixedDecimalPlaces = 2 End With Else With Application .FixedDecimal = False .FixedDecimalPlaces = 2 End With End If MsgBox Application.FixedDecimal  " "Sayfa1'in kod bölümüne: Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 19 And Target.Row = 8 Then [S1] = [S1] + 1 End If Call Islemler  ChDirMkDir.xls'nin Module1'ine; Kod: Sub Islemler() Application.DisplayAlerts = 0 On Error Resume Next VerilecekAd = Left(Sheets(""Sayfa1"").Range(""S8""), 3) & 241 + Sheets(""Sayfa1"").Range(""S1"") MkDir ""C:\Veriyedekle"" MkDir ""C:\Veriyedekle\"" & VerilecekAd Workbooks.Add ChDir ""C:\Veriyedekle\"" & VerilecekAd VerilecekAd = VerilecekAd & "".xls"" ActiveWorkbook.SaveAs VerilecekAd ActiveWorkbook.Close False Application.DisplayAlerts = 1  " "Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set MyIsect = Application.Intersect(Target, Range(""A1:B5"")) If Not MyIsect Is Nothing Then UserForm1.Show " "Option Explicit 'Belirlenen hücre aralıklarında çift tıklama ile x işareti koyar ve kaldırır Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim RaBereich As Range Set RaBereich = Range(""B3:P16,B19:P22"") If Intersect(Target, RaBereich) Is Nothing Then Exit Sub Application.EnableEvents = False Cancel = True If Target.Value = ""X"" Then Target.Value = """" Else Target.Value = ""X"" End If Application.EnableEvents = True Set RaBereich = Nothing " "Sub Yaz() ActiveSheet.PageSetup.PrintArea = ""$a$1:$h$30"" ActiveSheet.PrintOut From:=1, Copies:=1, preview:=False, Collate:=True " "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) = CLng(nums) nums = """" Next i " " Belirli Bir Süre ekranda bekleyen ve daha sonra kapan userform. Private Sub UserForm_Activate() TimeDebut = Timer DoEvents While Timer < TimeDebut + 10 Wend Unload Me  'Süreli UserForm2 Private Sub UserForm_Activate() Application.Wait Now + TimeSerial(0, 0, 3) Unload Me  " "Sub sayfasil() Application.DisplayAlerts = False For a = Sheets.Count To 1 Step 1 ad = Sheets(a).Name If IsNumeric(ad) = True And ad < 32 Then Sheets(a).Delete Next " "Sub DateinamenAuflisten() Dim Dateiname As String, i As Integer Dateiname = Dir$(""c:\.xls"") ‘uzantısını değiştirebilirsiniz .doc gibi veya c:\windows\ bu yolla da klasör içi de olabilir. Do While Dateiname <> """" ActiveCell.Offset(i, 0) = Dateiname i = i + 1 Dateiname = Dir$() Loop " "Sub GereksizSayfaSil() Application.DisplayAlerts = False For Each ws In Worksheets If ws.Name = ""a"" Or ws.Name = ""b"" Or ws.Name = ""c"" Then GoTo sonraki ws.Delete sonraki: Next Application.DisplayAlerts = True " "Sub GereksizSayfaSil() Application.DisplayAlerts = False For Each ws In Worksheets If ws.Name = ""a"" Or ws.Name = ""b"" Or ws.Name = ""c"" Then GoTo sonraki ws.Delete sonraki: Next Application.DisplayAlerts = True " "Pek çok sayfa olan dosyamızdaki örnek olarak a , b ve c adlı sayfalar haricindekileri silmek istersek; Kod: Sub GereksizSayfaSil() Application.DisplayAlerts = False For Each ws In Worksheets If ws.Name = ""a"" Or ws.Name = ""b"" Or ws.Name = ""c"" Then GoTo sonraki ws.Delete sonraki: Next Application.DisplayAlerts = True  " "Her zaman söylediğim gibi geliştirmek sizin elinizde sutun B:B DEĞİLDE C:C OLABİLİR GİBİ Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Target, Range(""B:B"")) Is Nothing Then MsgBox ""Buraya istediğiniz uyarıyı yazıyorsunuz!"", vbOKOnly, ""www.excel.web.tr"" End If  Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Target, Range(""B:B"")) Is Nothing Then MsgBox ""Buraya istediğiniz uyarıyı yazıyorsunuz!"", vbOKOnly, ""www.excel.web.tr"" End If  " Application.OnTime TimeValue("12:00:00"), "makro adı" "Private Declare Function GetComputerName Lib ""kernel32"" Alias ""GetComputerNameA"" (ByVal lpBuffer As String, nSize As Long) As Long Sub ComputerName() Dim lngTemp As Long, strPCName As String strPCName = Space(256) lngTemp = GetComputerName(strPCName, Len(strPCName)) MsgBox strPCName " "Option Explicit Declare Function Beep Lib ""Kernel32"" (ByVal Fq As Long, ByVal Tm As Long) As Long Sub Warnung() Beep 392, 200 Beep 494, 100 Beep 588, 200 Beep 740, 100 Beep 880, 400 Beep 740, 100 Beep 880, 900 " "Sub say() c = 0 For k = 3 To 5 'sütun numaraları, istediğiniz gibi ayarlayın For ara = 2 To WorksheetFunction.CountA(Columns(k)) If Cells(ara, k) Like """" & [e2] & """" Then c = c + 1 Next ara Next k [f2] = c 'neticenin yazdırılacağı hücreyi değiştirmek gerekebilir.. f2 yerine ist.hücre adresini girin  " "Sadece C kolonundaki bir hücreye veri girişi olursa veya çift tıklanırsa bu durumda çalışacak makronuzu aşağıdaki iki kodun ""......."" yazan yerine kopyalayın. çift tıklama ile çalıştırmak için Kod: Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If ActiveCell.Column = 3 Then '........ End If  hücredeki değer değişince çalıştırmak için Kod: Private Sub Worksheet_Change(ByVal Target As Range) If ActiveCell.Column = 3 Then '........ End If  her iki koduda ilgili sayfanın kod sayfasına yazınız. " "Yapacağınız işlem nümerik ise Macro1'i, alfanümerik ise Macro2'yi bir deneyin,işinizi görür sanırım. Kod: Sub Macro1() eklenecek = ActiveCell.Offset(1, 0) ActiveCell.Value = ActiveCell.Value + eklenecek  Sub Macro2() eklenecek = ActiveCell.Offset(1, 0) ActiveCell.Value = ActiveCell.Value & eklenecek  " "koddaki test.xls i gerekli isimle degistin basla kacinci sayfadan baslanacagini tane basladan sonra kac tane sayfa kopyalanacagini gosterir. Kod: Sub kopyala() Dim kitap As String Dim tane As Integer Dim basla As Integer basla = 1 tane = 2 kitap = ActiveWorkbook.Name For x = 1 To tane Workbooks(kitap).Sheets(basla).Move _ Before:=Workbooks(""Test.xls"").Sheets(1) Next  not: soru basliginizi seceken ""makro hakkinda"" gibi cok amator bir baslik secmektense, "" bir kitaptaki sayfalari baska bir kitaba tasimak"" gibi ilk okundugunda anlasilacak sorulardan secmek cok daha hizli cevap almanizi saglar. aklinizda bulunsun. makro forumunda bir sorunun ""makro hakkinda"" olmamasi zaten imkansizdir." "Sub deneme() Dim i As Integer For i = 1 To Worksheets.Count Worksheets(i).[a1].Value = Worksheets(""sayfa1"").[a1] Next i  bu kod ile sayfa1 deki a1 hücresindeki veriyi diğer sayfalara atabilrsin" "Sub kont() baksut = ""AI"" kontsut = ""AL"" son = Cells(65536, baksut).End(3).Row For x = 1 To son  1 For y = x + 1 To son If Cells(x, baksut) = Cells(y, baksut) And Cells(y, kontsut) = """" Then Cells(y, kontsut) = Cells(x, kontsut) Next y Next x " "Sub Dialog_51() Application.Dialogs(xlDialogOptionsView).Show  Sub Dialog_52() Application.Dialogs(xlDialogOutline).Show  Sub Dialog_53() Application.Dialogs(xlDialogPageSetup).Show  Sub Dialog_54() Application.Dialogs(xlDialogParse).Show  Sub Dialog_55() Application.Dialogs(xlDialogPasteSpecial).Show  Sub Dialog_56() Application.Dialogs(xlDialogPatterns).Show  Sub Dialog_57() Application.Dialogs(xlDialogPrint).Show  Sub Dialog_58() Application.Dialogs(xlDialogPrinterSetup).Show  Sub Dialog_59() Application.Dialogs(xlDialogPrintPreview).Show  Sub Dialog_60() Application.Dialogs(xlDialogProperties).Show  Sub Dialog_61() Application.Dialogs(xlDialogProtectDocument).Show  Sub Dialog_62() Application.Dialogs(xlDialogProtectSharing).Show  Sub Dialog_63() Application.Dialogs(xlDialogPublishAsWebPage).Show  Sub Dialog_64() Application.Dialogs(xlDialogReplaceFont).Show  Sub Dialog_65() Application.Dialogs(xlDialogRowHeight).Show  Sub Dialog_66() Application.Dialogs(xlDialogRun).Show  Sub Dialog_67() Application.Dialogs(xlDialogSaveAs).Show  Sub Dialog_68() Application.Dialogs(xlDialogSaveWorkbook).Show  Sub Dialog_69() Application.Dialogs(xlDialogSaveWorkspace).Show  Sub Dialog_70() Application.Dialogs(xlDialogScenarioAdd).Show  Sub Dialog_71() Application.Dialogs(xlDialogScenarioCells).Show  Sub Dialog_72() Application.Dialogs(xlDialogScenarioMerge).Show  Sub Dialog_73() Application.Dialogs(xlDialogSelectSpecial).Show  Sub Dialog_74() Application.Dialogs(xlDialogSetBackgroundPicture).Show  Sub Dialog_75() Application.Dialogs(xlDialogSetPrintTitles).Show  Sub Dialog_76() Application.Dialogs(xlDialogShowToolbar).Show  Sub Dialog_77() Application.Dialogs(xlDialogSort).Show  Sub Dialog_78() Application.Dialogs(xlDialogStandardFont).Show  Sub Dialog_79() Application.Dialogs(xlDialogStandardWidth).Show  Sub Dialog_80() Application.Dialogs(xlDialogStyle).Show  Sub Dialog_81() Application.Dialogs(xlDialogSummaryInfo).Show  Sub Dialog_82() Application.Dialogs(xlDialogTable).Show  Sub Dialog_83() Application.Dialogs(xlDialogTextToColumns).Show  Sub Dialog_84() Application.Dialogs(xlDialogUnhide).Show  Sub Dialog_85() Application.Dialogs(xlDialogWebOptionsEncoding).Show  Sub Dialog_86() Application.Dialogs(xlDialogWebOptionsFiles).Show  Sub Dialog_87() Application.Dialogs(xlDialogWebOptionsFonts).Show  Sub Dialog_88() Application.Dialogs(xlDialogWebOptionsGeneral).Show  Sub Dialog_89() Application.Dialogs(xlDialogWebOptionsPictures).Show  Sub Dialog_90() Application.Dialogs(xlDialogWorkbookAdd).Show  Sub Dialog_91() Application.Dialogs(xlDialogWorkbookCopy).Show  Sub Dialog_92() Application.Dialogs(xlDialogWorkbookInsert).Show  Sub Dialog_93() Application.Dialogs(xlDialogWorkbookMove).Show  Sub Dialog_94() Application.Dialogs(xlDialogWorkbookName).Show  Sub Dialog_95() Application.Dialogs(xlDialogWorkbookNew).Show  Sub Dialog_96() Application.Dialogs(xlDialogWorkbookOptions).Show  Sub Dialog_97() Application.Dialogs(xlDialogWorkbookProtect).Show  Sub Dialog_98() Application.Dialogs(xlDialogWorkbookUnhide).Show  Sub Dialog_99() Application.Dialogs(xlDialogWorkgroup).Show  Sub Dialog_100() Application.Dialogs(xlDialogWorkspace).Show  Sub Dialog_101() Application.Dialogs(xlDialogZoom).Show " "For i = 1 To Cells(65536, 1).End(xlUp).Row Cells(i, 2) = UBound(Split(Cells(i, 1), "","")) + 1 Next i " "A1hucresine =YUVARLA(A1;5) 'B2hucresine =YUVARLA(B2;5) 'C3hücresine =YUVARLA(C3;5) Sub yuvarla() [A1] = Round((Range(""A1"").Value) / 50000)  50000 [B2] = Round((Range(""B2"").Value) / 50000)  50000 [C3] = Round((Range(""C3"").Value) / 50000)  50000 " " ‘Kodlarınızın 2.satırdan başladığını kabul ettim, 1.satırdan başlamaması menfatiniz icabıdır ’Veriler Sheet1 de A sütununda isimler, B sütununda değerleri, ’Sonuçlar sheet2 ye A ve B sütununa yazılıyor. Sub a() Dim isim, deger As Variant Dim rng As Range Dim i, z As Integer i = 2 z = 1 Do If Cells(i, 1).Value = """" Then GoTo bitti If Range([A1], [A10000]).Find(What:=Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows).Row < i Then GoTo devam2 ReDim isim(z) ReDim deger(z) isim(z) = Cells.Find(What:=Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows).Value deger(z) = Cells(i, 1).Offset(0, 1).Value hcr = i Do On Error Resume Next Set rng = Range(Cells(hcr, 1), [A10000]).FindNext If rng.Row = hcr Then GoTo devam hcr = rng.Row deger(z) = deger(z) + rng.Offset(0, 1).Value Loop devam: Sheets(2).Cells(z, 1).Value = isim(z) Sheets(2).Cells(z, 2).Value = deger(z) z = z + 1 devam2: i = i + 1 Loop bitti: " "Sub KorumaKaldir() Dim ws As Worksheet For Each ws In Worksheets ws.Unprotect (""a"") Next  Sub KorumaKoy() Dim ws As Worksheet For Each ws In Worksheets ws.Protect (""a"") Next " "UserForm un Initialize olayına da yazabilirsiniz Private Sub CommandButton1_Click() Dim Ctr As Control Dim Say As Integer Say = 0 For Each Ctr In Controls If TypeName(Ctr) = ""TextBox"" Then Say = Say + 1 With Controls(""TextBox"" & (Say)).Font .Bold = 1 .Size = 12 .Name = ""Verdana"" .Italic = 1 End With Next " "UserForm un Initialize olayına da yazabilirsiniz Public Ctr As Control, Say As Integer Private Sub CommandButton1_Click() Say = 0 For Each Ctr In Controls If TypeName(Ctr) = ""TextBox"" Then Say = Say + 1 With Controls(""TextBox"" & (Say)) .Font.Bold = 1 .Font.Size = 12 .Font.Name = ""Verdana"" .Font.Italic = 1 .BackColor = &HC0FFC0 .ForeColor = &HFF& End With Next " "Sub Dialog_15() Application.Dialogs(xlDialogConsolidate).Show " "Private Sub CommandButton1_Click() For a=1 To sheets.count For Each hucre In sheets(a).[a1:e20] If hucre.Interior.Color = vbYellow Then If hucre.MergeCells = True Then sheets(a).select hucre.Select Selection.ClearContents Else hucre.ClearContents End If End If Next Next " "Sub Verbundene_Zellen() Dim cell As Range For Each cell In ActiveSheet.UsedRange If cell.MergeCells = True Then cell.Interior.ColorIndex = 3 Next " "Sub BackgroundColors() For Each cell In Range(""a1:a10"") If Not IsError(cell.Value) Then With cell.Interior Select Case cell.Value Case Is = Empty .ColorIndex = 10 Case Is = ""?"" .ColorIndex = 6 Case Else .ColorIndex = 0 'xlAutomatic End Select End With Else cell.Interior.ColorIndex = xlAutomatic End If Next cell " "Sub dene() For i = 2 To 1200 If Cells(i, 1) = """" Then Range(Cells(i  1, 1), Cells(i  1, 5)).Copy Cells(i, 1).PasteSpecial End If Next i " "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 " "Sub sütungizle() Dim i As Integer For i = 1 To 15 If Sheets(""Sayfa1"").Cells(i, 1).Value <> """" Then Column(i).Hidden = False Else Sheets(""Sayfa1"").Column(i).Hidden = True End If Next i " "Sub listele() For x = [b65526].End(3).Row To 2 Step 1 If Cells(x, 2).Value <= Empty Then Rows(x).Delete Next " "Sub bossatirsil() For a = 1 To Sheets.Count sat = Sheets(a).Cells.SpecialCells(xlCellTypeLastCell).Row sut = Sheets(a).Cells.SpecialCells(xlCellTypeLastCell).Column For b = sat To 1 Step 1 If WorksheetFunction.CountA(Sheets(a).Rows(b)) = 0 Then Sheets(a).Rows(b).Delete Next For c = sut To 1 Step 1 If WorksheetFunction.CountA(Sheets(a).Columns(c)) = 0 Then Sheets(a).Columns(c).Delete Next Next " "Sub sil() For x = [b65526].End(3).Row To 2 Step 1 If Cells(x, 2).Value <= Empty Then Rows(x).Delete Next " "Sub Gizle() For Each t In Range(""C9:C85"").Cells If t.Value = """" Then 'boş hücreleri gizler t.EntireRow.Hidden = True End If Next t  Sub Göster() For Each t In Range(""C9:C85"").Cells If t.Value = """" Then 'boş hücreleri gösterir t.EntireRow.Hidden = False End If Next t  " "Sub Bul_Sil() Dim hucre As Range For Each hucre In Range(""B5:B25"") Application.StatusBar = hucre.Address(False, False) '_______1 nci ALTERNATİF (GİZLEME)_______ If hucre.Value = """" Then hucre.EntireRow.Hidden = True '_______2 nci ALTERNATİF (SİLME)_______ 'If hucre.Value = """" Then hucre.Delete Shift:=xlUp Next hucre Application.StatusBar = False " "Private Sub UserForm_Initialize() dolu_son_satır = Sheets(""Sevkiyat"").Cells(65536, ""A"").End(xlUp).Row ListBox1.RowSource = ""Sevkiyat!A6:I"" & dolu_son_satır ListBox1.ColumnHeads = True ListBox1.ColumnCount = 9 ListBox1.ListIndex = 0 Satirsayisi = ListBox1.ListCount Label12.Caption = Satirsayisi  " "Sub auto_close() Range(""A:A"").Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.EntireRow.Delete Range(""A1"").Select " "Sub DeleteEmptyRows() LastRow = 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 " "Option Explicit Sub Leerzeilenlöschen() Range(""A:A"").SpecialCells(xlCellTypeBlanks).EntireRow.Delete " "Sub DeleteEmptyRows() LastRow = 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 " "Sub Ayarla() Dim Ayin_Ilk_Gunu As Date, Ayin_Son_Gunu As Date, Hedef As Range, Adres As String Ayin_Ilk_Gunu = DateSerial(Year(Now), Month(Now), 1) Ayin_Son_Gunu = DateSerial(Year(Now), Month(Now) + 1, 1)  1 On Error Resume Next ActiveWorkbook.Names(""Bayramlar"").Delete On Error GoTo 0 ActiveWorkbook.Names.Add Name:=""Bayramlar"", RefersToR1C1:= _ ""={"" & CDbl(CDate(""23.04.2007"")) & "";"" & CDbl(CDate(""19.05.2007"")) & "";"" & CDbl(CDate(""23.10.2007"")) & "";"" & CDbl(CDate(""24.10.2007"")) & "";"" & CDbl(CDate(""25.10.2007"")) & "";"" & _ CDbl(CDate(""29.10.2007"")) & "";"" & CDbl(CDate(""31.12.2007"")) & "";"" & CDbl(CDate(""01.01.2008"")) & "";"" & CDbl(CDate(""02.01.2008"")) & "";"" & CDbl(CDate(""03.01.2008"")) & ""}"" Set Hedef = Range(""A5"") Hedef = Ayin_Ilk_Gunu Hedef.NumberFormat = ""DD"" With Hedef Adres = .Address(True, False) .Select .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:= _ ""=VE("" & Adres & ""<>"";YADA(DEĞİL(EHATALIYSA(DÜŞEYARA("" & Adres & "";Bayramlar;1;0)));HAFTANINGÜNÜ("" & Adres & "";2)=6;HAFTANINGÜNÜ("" & Adres & "";2)=7))"" .FormatConditions(1).Interior.ColorIndex = 3 End With With Hedef(2, 1) .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:= _ ""=VE("" & Adres & ""<>"";YADA(DEĞİL(EHATALIYSA(DÜŞEYARA("" & Adres & "";Bayramlar;1;0)));HAFTANINGÜNÜ("" & Adres & "";2)=6;HAFTANINGÜNÜ("" & Adres & "";2)=7))"" .FormatConditions(1).Interior.ColorIndex = 3 End With Hedef.DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:=xlDay, _ Step:=1, stop:=CDbl(Ayin_Son_Gunu), Trend:=False Hedef.AutoFill Destination:=Range(Hedef, Hedef.End(xlToRight)), Type:=xlFillDefault Hedef(2, 1) = Format(Hedef(1, 1), ""DDD"") Hedef(2, 1).AutoFill Destination:=Range(Hedef(2, 1), Hedef.End(xlToRight)(2, 1)), Type:=xlFillDefault Range(Hedef(2, 1).EntireColumn, Hedef.End(xlToRight)(2, 1).EntireColumn).Columns.AutoFit Hedef(3, 1).Formula = ""=IF(AND(OR(WEEKDAY("" & Adres & "",2)=1,WEEKDAY("" & Adres & "",2)=3,WEEKDAY("" & Adres & "",2)=5),ISERROR(VLOOKUP("" & Adres & "",Bayramlar,1,0))),10,IF(AND(OR(WEEKDAY("" & Adres & "",2)=2,WEEKDAY("" & Adres & "",2)=4),ISERROR(VLOOKUP("" & Adres & "",Bayramlar,1,0))),4,0))"" Hedef(3, 1).AutoFill Destination:=Range(Hedef(3, 1), Hedef.End(xlToRight)(3, 1)), Type:=xlFillDefault Set Hedef = Nothing " " ‘Formülü A1 e kadar =NSAT((A1HAFTANINGÜNÜ(A1;2)TARİH(YIL(A1+4HAFTANINGÜNÜ(A1;2));1;10))/7)" "Sub Test() ActiveSheet.UsedRange.Select Application.CommandBars.FindControl(ID:=1849).Execute " "Sub Test2() For i = 1 To Worksheets.Count Sheets(i).Select Sheets(i).UsedRange.Select Application.CommandBars.FindControl(ID:=1849).Execute Next  " "Sub DoBox() ActiveSheet.Cells.Find What:="""", LookAt:=xlWhole Application.CommandBars(""Worksheet Menu Bar"").FindControl( _ ID:=1849, recursive:=True).Execute " "Option Compare Binary Private Sub CheckBox4_Click() If CheckBox4.Value = True Then CheckBox3.Enabled = False  Private Sub CommandButton1_Click() If TextBox1.Text = """" Then Exit Sub If CheckBox1.Value = True Then look = 1 Else look = 2 If CheckBox3.Value = True Then bas = 1 Else bas = 2 ListBox1.Clear Set c = Range(""a:a"").Find(TextBox1, LookIn:=xlValues, MatchCase:=CheckBox2.Value, LookAt:=look, SearchDirection:=bas) If Not c Is Nothing Then firstAddress = c.Address ListBox1.AddItem ListBox1.List(0, 0) = c.Address ListBox1.List(0, 1) = c basla: Set c = Range(""a:a"").FindNext(c) If Not c Is Nothing And c.Address <> firstAddress Then a = a + 1 ListBox1.AddItem ListBox1.List(a, 0) = c.Address ListBox1.List(a, 1) = c GoTo basla End If End If If CheckBox4.Value = 0 Then Exit Sub If ListBox1.ListCount > 0 Then For x = 0 To ListBox1.ListCount  2 For y = x + 1 To ListBox1.ListCount  1 If Val(Replace(ListBox1.List(x, 0), ""$A$"", """")) > Val(Replace(ListBox1.List(y, 0), ""$A$"", """")) Then Call swap(x, y) Next y, x End If  Private Sub ListBox1_Click() Range(ListBox1.List(ListBox1.ListIndex, 0)).Select  Sub swap(ind1, ind2) Set l = ListBox1 ara = l.List(ind1, 0) l.List(ind1, 0) = l.List(ind2, 0) l.List(ind2, 0) = ara ara = l.List(ind1, 1) l.List(ind1, 1) = l.List(ind2, 1) l.List(ind2, 1) = ara " "Private Sub Worksheet_Change(ByVal Target As Range) Dim Bul As Range, Adres On Error GoTo HATA If Target.Column = 1 And Not Target = """" Then Set Bul = Range(""A:A"").Find(Target, LookAt:=xlWhole) Adres = Bul.Address Set Bul = Range(""A:A"").FindNext(Bul) If Not Bul.Address = Adres Then MsgBox Target & "" değeri daha önce girilmiş"" Target.Select End If End If HATA: " "Sub Dialog_32() Application.Dialogs(xlDialogFormulaFind).Show " "Private Sub CommandButton1_Click() Application.CommandBars.FindControl(ID:=1849).Execute " "Private Sub ComboBox1_Change() ListBox1.Clear son = Cells(65536, 1).End(xlUp).Row For i = 1 To son If Cells(i, 7).Value = ComboBox1.Value Then Cells(i, 1).Select c = c + 1 For y = 1 To 10 ListBox1.AddItem ListBox1.List(c  1, y  1) = Cells(i, y + 1).Value Next End If Next  Private Sub ListBox1_Click()  Private Sub UserForm_Initialize() ComboBox1.AddItem ""İl Sosyal Hizmetler Müdürlüğü"" ComboBox1.AddItem ""Gözde Birsöz Çocuk Yuvası Müdürlüğü"" ComboBox1.AddItem ""75. Yıl Huzurevi Müdürlüğü"" ComboBox1.AddItem ""Aile Danışma Merkezi Müdürlüğü"" ListBox1.ColumnCount = 10  " "Private Sub CommandButton1_Click() 'bul For Each hucre In Range(""a2:a"" & WorksheetFunction.CountA(Range(""a1:a65000""))) If StrConv(hucre.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then hucre.Select TextBox1 = ActiveCell.Offset(0, 1).Value TextBox2 = ActiveCell.Offset(0, 2).Value TextBox3 = ActiveCell.Offset(0, 3).Value End If Next  Private Sub CommandButton2_Click() 'değiştir ActiveCell.Offset(0, 1).Value = TextBox1.Value ActiveCell.Offset(0, 2).Value = TextBox2.Value ActiveCell.Offset(0, 3).Value = TextBox3.Value  Private Sub CommandButton3_Click() 'sil satır = ActiveCell.Row Rows(satır).Delete Shift:=xlUp 'say = WorksheetFunction.CountA(Range(""A2:A65000"")) For i = 1 To WorksheetFunction.CountA(Range(""a2:a65000"")) Cells(i + 1, 1) = i Next  Private Sub CommandButton4_Click() 'kaydet Dim bak As Range Dim say As Integer For Each bak In Range(""A1:A"" & WorksheetFunction.CountA(Range(""A1:A65000""))) If bak.Value = cbAd.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(cbAd.Value, vbUpperCase) Then MsgBox ""Bu isimde bir kaydınız bulundu"" Exit Sub End If Next bak b = WorksheetFunction.CountA(Sheets(""sayfa1"").Range(""A:A"")) Sheets(""sayfa1"").Range(""a"" & b + 1).Select ActiveCell = ComboBox1.Value ActiveCell.Offset(0, 1) = TextBox1.Value ActiveCell.Offset(0, 2) = TextBox2.Value ActiveCell.Offset(0, 3) = TextBox3.Value  Private Sub UserForm_Initialize() b = WorksheetFunction.CountA(Range(""A2:A6500"")) ComboBox1.RowSource = ""sayfa1!a2:a"" & b " "Option Explicit Sub AddBullets() Dim Bullet As String Dim Dash As String Dim Cel As Range Dim Str As String Dim i As Long Bullet = ""• "" Dash = ""  "" 'select which cells to perform an action on For Each Cel In Selection Str = Cel.Value 'If there is already a bullet there then put a dash in its place If Left(Str, Len(Bullet)) = Bullet Then Str = Right(Str, Len(Str)  2) Cel.Value = Dash & Str Else 'If there is already a dash there then trim back to normal text If Left(Str, Len(Dash)) = Dash Then Str = Trim(Cel.Value) i = Len(Str)  1 If i >= 0 Then Cel.Value = Trim(Right(Str, i)) End If Else 'Otherwise add the bullet Cel.Value = Bullet & Str End If End If 'Go to the next cell in the selection and do the same thing Next Cel " "Sub Bul_Renklendir() Dim neyi As String, rng As Range, alan As Range neyi = Application.InputBox(""A1:D20 hücrelerinde, bulmak istediğiniz veri"", , """") Set alan = Range(""A1:D20"") alan.Interior.ColorIndex = xlNone For Each rng In alan If StrConv(rng, vbProperCase) = StrConv(neyi, vbProperCase) Then rng.Interior.ColorIndex = 35 End If Next rng Set alan = Nothing " "Private Sub CommandButton1_Click() For Each hucre In Range(""a2:a"" & WorksheetFunction.CountA(Range(""a1:a65000""))) If StrConv(hucre.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then hucre.Select TextBox1 = ActiveCell.Offset(0, 1).Value TextBox2 = ActiveCell.Offset(0, 2).Value TextBox3 = ActiveCell.Offset(0, 3).Value End If Next  Private Sub CommandButton2_Click() ActiveCell.Offset(0, 1).Value = TextBox1.Value ActiveCell.Offset(0, 2).Value = TextBox2.Value ActiveCell.Offset(0, 3).Value = TextBox3.Value  Private Sub CommandButton3_Click() satır = ActiveCell.Row Rows(satır).Delete Shift:=xlUp 'say = WorksheetFunction.CountA(Range(""A2:A65000"")) For i = 1 To WorksheetFunction.CountA(Range(""a2:a65000"")) Cells(i + 1, 1) = i Next  Private Sub CommandButton4_Click() b = WorksheetFunction.CountA(Sheets(""sayfa1"").Range(""A:A"")) Sheets(""sayfa1"").Range(""a"" & b + 1).Select ActiveCell = ComboBox1.Value ActiveCell.Offset(0, 1) = TextBox1.Value ActiveCell.Offset(0, 2) = TextBox2.Value ActiveCell.Offset(0, 3) = TextBox3.Value  Private Sub UserForm_Initialize() b = WorksheetFunction.CountA(Range(""A2:A6500"")) ComboBox1.RowSource = ""sayfa1!a2:a"" & b " "Dim comb() As New Class1 Dim index As Integer Private Sub ComboBox1_Click() index = ComboBox1.ListIndex + 1  Private Sub CommandButton1_Click() End  Private Sub CommandButton2_Click() For a = 1 To 13 Controls(""combobox"" & a).RowSource = """" Cells(index, a) = Controls(""combobox"" & a) If IsNumeric(Controls(""combobox"" & a)) = True Then Cells(index, a) = Controls(""combobox"" & a)  1 Next Call UserForm_Initialize  Private Sub UserForm_Initialize() For a = 1 To 13 ReDim Preserve comb(13) Set comb(a).comb = Controls(""combobox"" & a) adres = Range(Cells(1, a), Cells(Cells(65536, 1).End(3).Row, a)).Address Controls(""combobox"" & a).RowSource = adres Next  'classmodüle Public WithEvents comb As MSForms.ComboBox Dim a As Integer Private Sub comb_Click() If a = 1 Then Exit Sub For a = 1 To 13 If UserForm1.Controls(""combobox"" & a).Name <> comb.Name Then UserForm1.Controls(""combobox"" & a).ListIndex = comb.ListIndex Next  Private Sub comb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) a = 1 " "Declare Function sndPlaySound Lib ""winmm.dll"" _ Alias ""sndPlaySoundA"" ( _ ByVal SoundName As String, _ ByVal Flags As Long) As Long Sub PlayWav(ByVal WavFileName As String) Call sndPlaySound(WavFileName, 0)  Sub TestWav() Call PlayWav(ThisWorkbook.Path + ""\pir.wav"") " "Sub Markierung() Dim Mark_Bereich Mark_Bereich = Selection.Address(False, False) MsgBox Mark_Bereich " "Thisworkbooka Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim Phad As String Phad = ThisWorkbook.Path ActiveWorkbook.SaveCopyAs Filename:=Phad & ""\"" & Format(Now, ""DDMMYY_hhmm"") & ""_Backup_Beispielmappe_113.XLS"" " "Sub EditionCopierOK() Application.CommandBars(1).Controls(2).Controls(4).Enabled = True  Sub EditionCopierNo() Application.CommandBars(""Edit"").FindControl(ID:=19).Enabled = False  Sub menuOutilsOptNo() Application.CommandBars(""Tools"").FindControl(ID:=522).Enabled = False  Sub menuOutilsOptok() Application.CommandBars(""Tools"").FindControl(ID:=522).Enabled = True " " sheets(""sayfa2"").PrintOut Sn tb belki işinize yarar birde bunu deneyin a1 hüresine yazdığınız rakan kadar sayfa çıktısı alabilirsiniz Sub Test() Sheets(""sayfa2"").PrintOut From:=1, To:=[a1].Value End Su" "BU KOD BUTONLARDAN VERDİĞİNİZ KOMUTLARI YERİNE GETİRMEDEN ÖNCE KULLANICIYA UYARI VERİR Dim cevap cevap = MsgBox(""Kaydı Silmek İstediğinize Eminmisiniz ? Evet Dersen Veri Kalıcı Olarak Silinecek ! "", vbYesNo + vbQuestion + vbDefaultcmdsil + vbApplicationModal, ""Kayıt Silinecek"") If cevap = vbNo Then End End If " "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  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  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) = ""Itemno: "" & 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 " Sheets("Liste").Rows(Cells(2, 1) & ":" & Cells(2, 1)).Delete Shift:=xlUp "BU KOMUT BUTONU AŞŞAĞI YUKARI HAREKET ETTİRİR(ENTERE BASTIKÇA) Private Sub CommandButton1_Click() Sheets(""sayfa2"").Select Range(""A1"").Show  Private Sub Worksheet_SelectionChange(ByVal Target As Range) CommandButton1.Top = ActiveCell.Rows.Top  " "Private Sub CommandButton1_Click() Dim NbreEnreg As Integer With UserForm1 .ComboBox1.RowSource = ""A1:A9"" NbreEnreg = .ComboBox1.ListCount .ComboBox1.ListRows = NbreEnreg .Show 'bu satırı silebilirsiniz End With " "Sorunu ikitürlü anladım. 1.Hücreye yazdığın dğerleri textboxlara getirmek. Kod: Private Sub UserForm_Initialize() TextBox1.Text = Range(""b1"").Text TextBox2.Text = Range(""b2"").Text TextBox3.Text = Range(""b3"").Text TextBox4.Text = Range(""b4"").Text TextBox5.Text = Range(""b5"").Text  2.TextBpxa Yazdığın değerleri İlgili hücrelere aktarmak. Kod: Private Sub CommandButton1_Click() Range(""b1"").Select ActiveCell.Formula = TextBox1 Range(""b2"").Select ActiveCell.Formula = TextBox2 Range(""b3"").Select ActiveCell.Formula = TextBox3 Range(""b4"").Select ActiveCell.Formula = TextBox4 Range(""b5"").Select ActiveCell.Formula = TextBox5 " "Sorunu ikitürlü anladım. 1.Hücreye yazdığın dğerleri textboxlara getirmek. Kod: Private Sub UserForm_Initialize() TextBox1.Text = Range(""b1"").Text TextBox2.Text = Range(""b2"").Text TextBox3.Text = Range(""b3"").Text TextBox4.Text = Range(""b4"").Text TextBox5.Text = Range(""b5"").Text  2.TextBpxa Yazdığın değerleri İlgili hücrelere aktarmak.Kod: Private Sub CommandButton1_Click() Range(""b1"").Select ActiveCell.Formula = TextBox1 Range(""b2"").Select ActiveCell.Formula = TextBox2 Range(""b3"").Select ActiveCell.Formula = TextBox3 Range(""b4"").Select ActiveCell.Formula = TextBox4 Range(""b5"").Select ActiveCell.Formula = TextBox5  " "EN BAŞA DÖN Private Sub CommandButton1_Click() TextBox1 = Cells(2, 1) ComboBox1 = Cells(2, 2) TextBox2 = Cells(2, 3) TextBox3 = Cells(2, 4)  'EN SONA GİT Private Sub CommandButton4_Click() Dim say As Integer say = WorksheetFunction.CountA(Range(""A1:A65000"")) TextBox1 = Cells(say, 1) ComboBox1 = Cells(say, 2) TextBox2 = Cells(say, 3) TextBox3 = Cells(say, 4)  'BİR,BİR GERİ GİT Private Sub CommandButton2_Click() If TextBox1 = 1 Then Exit Sub Else TextBox1 = TextBox1  1 ComboBox1 = Cells(TextBox1 + 1, 2) TextBox2 = Cells(TextBox1 + 1, 3) TextBox3 = Cells(TextBox1 + 1, 4) End If  'BİR,BİR İLERİ GİT Private Sub CommandButton3_Click() Dim say As Integer say = WorksheetFunction.CountA(Range(""A1:A65000"")) If TextBox1 = say Then Exit Sub Else TextBox1 = TextBox1 + 1 ComboBox1 = Cells(TextBox1 + 1, 2) TextBox2 = Cells(TextBox1 + 1, 3) TextBox3 = Cells(TextBox1 + 1, 4) End If  " "Sub Set_Protection() On Error GoTo errorHandler Dim myDoc As Worksheet Dim cel As Range Set myDoc = ActiveSheet myDoc.Unprotect For Each cel In myDoc.UsedRange If Not cel.HasFormula And _ Not TypeName(cel.Value) = ""Date"" And _ Application.IsNumber(cel) Then cel.Locked = False cel.Font.ColorIndex = 5 Else cel.Locked = True cel.Font.ColorIndex = xlColorIndexAutomatic End If Next myDoc.Protect Exit Sub errorHandler: MsgBox Error " "Sub AfficheBoutons() Dim NewBarreOutil As CommandBar Dim NewBouton As CommandBarButton Dim i As Integer, IconOn As Integer, IconOff As Integer 'Supprime la barre si elle existe déjà On Error Resume Next Application.CommandBars(""BarBouton"").Delete On Error GoTo 0 Set NewBarreOutil = Application.CommandBars.Add _ (Name:=""BarBouton"", temporary:=True) NewBarreOutil.Visible = True IconOn = 1 IconOff = 200 For i = IconOn To IconOff Set NewBouton = NewBarreOutil.Controls.Add _ (Type:=msoControlButton, ID:=2950) NewBouton.FaceId = i NewBouton.Caption = ""FaceID = "" & i Next i NewBarreOutil.Width = 700 NewBarreOutil.Left = 50 NewBarreOutil.Top = 120  Sub SupMenuBar() Application.CommandBars(""Worksheet Menu Bar"").Enabled = False " "Private Sub UserForm_Activate() Do If UserForms.Count < 1 Then Exit Sub DoEvents If TypeName(ActiveControl) = ""CommandButton"" Then _ Label1.Caption = ActiveControl.Caption Loop " "Sub Düğme1_Tıklat() Dim a Dim x a = ActiveSheet.Shapes.Count For x = 1 To a ActiveSheet.Shapes(x).Visible = False Next " "Private Sub CommandButton1_Click() CommandButton3.Enabled = False CommandButton4.Enabled = False CommandButton5.Enabled = False  Private Sub CommandButton2_Click() CommandButton3.Enabled = True CommandButton4.Enabled = True CommandButton5.Enabled = True " "Sub Shape_Index_Name() Dim myVar As Shapes Dim shp As Shape Set myVar = Sheets(1).Shapes For Each shp In myVar MsgBox ""Index = "" & shp.ZOrderPosition & vbCrLf & ""Name = "" _ & shp.Name Next " "Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.BackColor = vbYellow  Private Sub UserForm_Initialize() CommandButton1.Tag = CommandButton1.BackColor  Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.BackColor = CommandButton1.Tag " "Sub Auto_Open() ActiveWindow.Zoom = 85  'Dosyayı kaydedin. Mesela Kucult.XLS ismini verin. 'Dosyayı C:\Windows\Application Data\Microsoft\Excel\Xlstart klasörüne kopyalayın." "Sub ButunPencerelerMinimize() Dim Pencere As Window For Each Pencere In Windows If Pencere.Visible = False Then Pencere.Visible = True Pencere.WindowState = xlMinimized Next  " "Sub ToggleCase() Dim Upr, Lwr, Ppr Set OriginalCell = ActiveCell Set OriginalSelection = Selection If IsEmpty(ActiveCell) Then GoTo NoneFound On Error GoTo Limiting If OriginalCell = OriginalSelection Then Selection.Select GoTo Converting Else Resume Next End If Limiting: On Error GoTo NoneFound Selection.SpecialCells(xlCellTypeConstants, 3).Select Converting: Application.StatusBar = ""Ändere Gross und Kleinschreibung..."" For Each DCell In Selection.Cells Upr = UCase(DCell) Lwr = LCase(DCell) If Upr = DCell.Value Then DCell.Value = Lwr Else DCell.Value = Upr End If Next DCell Application.StatusBar = False Exit Sub NoneFound: MsgBox ""Alle Zellen der aktuelllen Auswahl enthalten Formeln oder sindleer!"", vbExclamation, "" Fehler aufgetreten"" OriginalSelection.Select OriginalCell.Activate " "Sub Cree_Repert() Dim Repert As String Repert = Dir(""c:\test\"", vbDirectory) If Repert = """" Then MkDir ""c:\test"" End If " "Sub Liste_Repert() Dim Repert As String Repert = Dir(""c:\"", vbDirectory) Do While Repert <> """" 'Si Repert est un dossier. If GetAttr(""c:\"" & Repert) = vbDirectory Then UserForm1.ListBox1.AddItem Repert End If Repert = Dir Loop " "Sub ExcelDateienZählen() With Application.FileSearch .NewSearch .LookIn = ""C:\"" .Filename = "".xls"" .Execute MsgBox .FoundFiles.Count End With " "Sub lfdNr() Dim Nr% Dim dName$ Dim Zielordner$, Dateiname$ 'Hier den Pfad verändern Zielordner = ""c:\"" 'Hier den Dateinamen verändern Dateiname = ""lfdNr"" dName = Zielordner & Dateiname & "".ini"" Close On Error Resume Next Open dName For Input As #1 If Err > 0 Then Nr = 1 Close Open dName For Output As #1 Print #1, Nr Close Exit Sub Else Input #1, Nr Close Open dName For Output As #1 Print #1, Nr + 1 Close End If ActiveCell.Value = Nr " "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 " "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  " "Sub Add_Totals() For Each NumRange In Columns(""C"").SpecialCells(xlConstants, xlNumbers).Areas SumAddr = NumRange.Address(False, False) NumRange.Offset(NumRange.Count, 0).Resize(1, 1).Formula = ""=SUM("" & SumAddr & "")"" Next NumRange " "Sub Add_Totals() For Each NumRange In Columns(""C"").SpecialCells(xlConstants, xlNumbers).Areas SumAddr = NumRange.Address(False, False) NumRange.Offset(NumRange.Count, 0).Resize(1, 1).Formula = ""=SUM("" & SumAddr & "")"" Next NumRange " "Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Application.Intersect(Target, Range(""C:C"")) Is Nothing Then Target(1).Value = UCase(Target(1).Value) End If Application.EnableEvents = True " "Sub bidahabossatgizle() For i = 6 To 160 If Range(""c"" & i) = """" Then _ Range(""c"" & i).EntireRow.Hidden = True Next" "Sub aktar() Dim sonsat As Long, sat As Long, i As Long, sut As Byte Sheets(""2007"").Select Sheets(""PARCA"").Range(""A3:G65536"").ClearContents sonsat = Cells(65536, ""A"").End(xlUp).Row sat = 3 If sonsat < 3 Then Exit Sub For i = 3 To sonsat If WorksheetFunction.CountIf(Sheets(""PARCA"").Range(""C3:C65536""), Cells(i, ""C"")) = 0 Then For sut = 1 To 7 Sheets(""PARCA"").Cells(sat, sut).Value = Cells(i, sut).Value Next sut sat = sat + 1 End If Next i Sheets(""PARCA"").Select MsgBox ""İŞLEM TAMAM"" " "Sayfanın kod bölümüne 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 " "Sub NomClasseur() Dim Chr As String 'déclare la variable Chr = Range(""Sayfa1!C1"") 'Feuille Essai et cellule C1 ChDrive ""C"" 'si C n'est pas le disque par défaut ChDir ""C:\"" ActiveWorkbook.SaveAs Filename:=(Chr) " "Sub NomClasseur1() Dim Month As String  3 'seulement les 3 premières lettres Dim Year As String Month = Range(""Feuil1!C1"") Year = Right(Range(""Feuil1!C2""), 2) 'pour ne renvoyer que 01 de 2001 ChDrive ""C"" ChDir ""C:\ajeter\"" ActiveWorkbook.SaveAs Filename:=(Month) & (Year) " "Private Sub Worksheet_Calculate() Static DblWert If Range(""C10"") = 100 Then If Range(""C10"") = DblWert Then Exit Sub MsgBox ""Jetzt ist der Wert in A1 100!"" End If DblWert = Range(""C10"") " "Private Sub Worksheet_Change(ByVal Target As Range) Range(""D1"").Value = WorksheetFunction.CountBlank(Range(""C5:C15"")) " "Sub BlendeAus() Range(""C5:C20"").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True " "Sayfanın kod böümüne Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range(""C8:C18"")) Is Nothing Then Application.CommandBars(""Cell"").ShowPopup End If " "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range(""C8:C18"")) Is Nothing Then Application.CommandBars(""Cell"").ShowPopup End If " "Sub Makro1() Sheets(""Sayfa1"").Copy ActiveWorkbook.SaveAs Filename:=""C:\Documents And Settings\ocamsul\Belgelerim\[a1]  " "Private Declare Function GetVersionEx Lib ""kernel32"" _ Alias ""GetVersionExA"" (lpVersionInformation As OSVERSIONINFO) As Long Private Declare Sub keybd_event Lib ""user32"" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Declare Function GetKeyboardState Lib ""user32"" _ (pbKeyState As Byte) As Long Private Declare Function SetKeyboardState Lib ""user32"" _ (lppbKeyState As Byte) As Long Private Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String  128 ' Maintenance string for PSS usage End Type Const VK_CAPITAL = &H14 Const KEYEVENTF_EXTENDEDKEY = &H1 Const KEYEVENTF_KEYUP = &H2 Const VER_PLATFORM_WIN32_NT = 2 Const VER_PLATFORM_WIN32_WINDOWS = 1 Dim Keys(0 To 255) As Byte Sub SetCapsOn() Dim o As OSVERSIONINFO Dim NumLockState As Boolean Dim ScrollLockState As Boolean Dim CapsLockState As Boolean ' CapsLock handling: o.dwOSVersionInfoSize = Len(o) GetVersionEx o CapsLockState = Keys(VK_CAPITAL) If CapsLockState <> True Then 'Turn capslock on If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then '===== Win95 Keys(VK_CAPITAL) = 1 SetKeyboardState Keys(0) ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then '===== WinNT 'Simulate Key Press keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0 'Simulate Key Release keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY _ Or KEYEVENTF_KEYUP, 0 End If End If " "Option Explicit Public Declare Function SendCDcmd Lib ""winmm.dll"" _ Alias ""mciSendStringA"" ( _ ByVal lpstrCommand As String, _ ByVal lpstrReturnString As String, _ ByVal uReturnLength As Long, _ ByVal hwndCallback As Long) As Long Dim lRet As Long Public Sub EjectCD() lRet = SendCDcmd(""set CDAudio door open"", vbNullString, 127, 0)  Public Sub CloseCD() lRet = SendCDcmd(""set CDAudio door closed"", vbNullString, 127, 0) " "Private Declare Function mciExecute Lib ""winmm.dll"" (ByVal _ lpstrCommand As String) As Long Public Sub Ap_001_Open() Call mciExecute(""Set CDaudio door open"")  Public Sub Ap_001_Close() Call mciExecute(""Set CDaudio door closed"") " "Option Base 1 Public Declare Function mciSendString Lib ""winmm.dll"" Alias ""mciSendStringA"" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Sub main() Dim Now As String Dim a(2) As String a(1) = ""set cdaudio door open"" a(2) = ""set cdaudio door closed"" total = 1 For I = 1 To (total  2) If Int(I / 2) = I / 2 Then Now = vbString(a(2), 0) Else Now = vbString(a(1), 0) End If Next I  Function vbString(ByVal Command As String, ByVal hWnd As Long) As String Dim Buff As String Dim dwR As Long Buff = Space$(100) ' Create a buffer dwR = mciSendString(Command, ByVal Buff, Len(Buff), hWnd) vbString = Buff " "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range(""A1:A10"")) Is Nothing Then Target.Font.Name = ""Marlett"" If Target = vbNullString Then Target = ""a"" Else Target = vbNullString End If End If " "Private Sub CheckBox1_Click() [A1] = CheckBox1  20 + 120 " "Private Sub UserForm_Initialize() Range(""a1"") = 120  Private Sub CheckBox1_Click() If Me.CheckBox1.Value = False Then Range(""a1"") = 120 Else Range(""a1"") = 100 End If " "Aktif sayfaya 1 tane checkbox ve kod bölümüne aşağıdaki kodları Option Explicit Private Sub CheckBox1_Click() Range(""F2"").Value = CheckBox1.Value  'Modüle Option Explicit Sub CheckboxEinAus() With Sheets(""Tabelle1"").OLEObjects(""CheckBox1"") .Object.Value = Not .Object.Value End With " "Private Sub CommandButton1_Click() If CheckBox1 = True Then Sheets(""Sayfa1"").PrintOut ElseIf CheckBox2 = True Then Sheets(""Sayfa2"").PrintOut ElseIf CheckBox3 = True Then Sheets(""Sayfa3"").PrintOut ElseIf CheckBox4 = True Then Sheets(""Sayfa4"").PrintOut End If " "Sub MsgAscii() Dim sayi1 As Integer For sayi1 = 1 To 255 msg = msg & (sayi1) & Chr(58) & Chr(sayi1) & Space(1) Next sayi1 MsgBox msg, 64, Chr(83) & Chr(252) & Chr(108) & Chr(101) _ & Chr(121) & Chr(109) & Chr(97) & Chr(110) & Chr(32) & Chr(85) _ & Chr(90) & Chr(85) & Chr(78) & Chr(75) & Chr(214) & Chr(80) & _ Chr(82) & Chr(220) " "Option Explicit Private mcolUndoObjects As Collection Private mUndoObject As clsUndoObject Public Function AddAndProcessObject(oObj As Object, sProperty As String, vValue As Variant) As Boolean Set mUndoObject = New clsUndoObject With mUndoObject Set .ObjectToChange = oObj .NewValue = vValue .PropertyToChange = sProperty mcolUndoObjects.Add mUndoObject If .ExecuteCommand = True Then AddAndProcessObject = True Else AddAndProcessObject = False End If End With  Private Sub Class_Initialize() Set mcolUndoObjects = New Collection  Private Sub Class_Terminate() ResetUndo  Public Sub ResetUndo() While mcolUndoObjects.Count > 0 mcolUndoObjects.Remove (1) Wend Set mUndoObject = Nothing  Public Sub UndoAll() Dim lCount As Long ' On Error Resume Next For lCount = mcolUndoObjects.Count To 1 Step 1 Set mUndoObject = mcolUndoObjects(lCount) mUndoObject.UndoChange Set mUndoObject = Nothing Next ResetUndo  Public Sub UndoLast() Dim lCount As Long ' On Error Resume Next If mcolUndoObjects.Count >= 1 Then Set mUndoObject = mcolUndoObjects(mcolUndoObjects.Count) mUndoObject.UndoChange mcolUndoObjects.Remove mcolUndoObjects.Count Set mUndoObject = Nothing Else ResetUndo End If  Public Function UndoCount() As Long UndoCount = mcolUndoObjects.Count " "Bir tane classmodule ekleyin adı AppEventClass olsun. Option Explicit Public WithEvents App As Application Private Sub App_NewWorkbook(ByVal Wb As Workbook) MsgBox ""A new workbook is created!""  Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean) MsgBox ""A workbook is closed!""  Private Sub App_WorkbookBeforePrint(ByVal Wb As Workbook, Cancel As Boolean) MsgBox ""A workbook is printed!""  Private Sub App_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean) MsgBox ""A workbook is saved!""  Private Sub App_WorkbookOpen(ByVal Wb As Workbook) MsgBox ""A workbook is opened!""  " "Bir tane classmodule ekleyin adı EventClass olsun. Option Explicit Public WithEvents App As Application Private Sub App_NewWorkbook(ByVal Wb As Excel.Workbook) MsgBox ""Application Event: New Workbook: "" & Wb.Name  Private Sub App_SheetActivate(ByVal Sh As Object) MsgBox ""Application Event: SheetActivate: "" & Sh.Name  Private Sub App_WorkbookOpen(ByVal Wb As Excel.Workbook) MsgBox ""Application Event: WorkbookOpen: "" & Wb.Name " "Private Sub UserForm_Activate() For i = 6 To 1000 If Sheets(""İNŞAAT TABLO"").Cells(i, 1) = """" Then GoTo 10: UserForm2.ComboBox1.AddItem (Sheets(""İNŞAAT TABLO"").Cells(i, 1)) 10: Next " "Toplama sonucunu alacağınızı Texbox3 kabul edersek aşağıdaki kodu Textbox3'in içine yazınız. Kod: Private Sub TextBox3_Enter() TextBox3 = CInt(TextBox1) + CInt(TextBox2)  veya Kod: Private Sub TextBox3_Enter() TextBox3 = Val(TextBox1) + Val(TextBox2)  ondalıklı sayılarıda toplaması için Kod: Private Sub TextBox3_Enter() TextBox3 = Ccur(TextBox1) + Ccur(TextBox2)  " "Private Sub UserForm_Initialize() For x = 2 To Cells(65536, 1).End(xlUp).Row If WorksheetFunction.CountIf(Range(""a2:a"" & x), Cells(x, 1)) = 1 Then ComboBox1.AddItem Cells(x, 1).Value End If Next  " "Private Sub ComboBox1_Change() Call MyCheck  Private Sub UserForm_Initialize() Call MyCheck  Private Sub MyCheck() If ComboBox1 = Empty Then MultiPage1.Visible = False Else MultiPage1.Visible = True End If " " MultiPage1.Visible = True If ComboBox1 = """" Then MultiPage1.Visible = False" "Private Sub CmbUrun_Change() Set no = Worksheets(""tümüs"").Range(""A1:CZ200"") Set ara = Cells.Find(What:=CmbUrun.Value, After:=ActiveCell, LookIn:=xlFormulas) If Not ara Is Nothing Then ilk = ara.Address ara.Select End If LblStok1 = ActiveCell.Offset(0, 1) " "Private Sub UserForm_Initialize() ComboBox1.ListRows = 5 ComboBox1.Text = ""PERSONEL SEÇİNİZ..."" ComboBox1.AddItem ""DENEME 1"" ComboBox1.AddItem ""DENEME 2"" ComboBox1.AddItem ""DENEME 3"" ComboBox1.AddItem ""DENEME 4"" ComboBox1.AddItem ""DENEME 5"" With ComboBox1 .SelStart = 0 .SelLength = Len(ComboBox1) End With  " "Private Sub ComboBox1_Change() On Error Resume Next ComboBox2.Value = Sheets(""Sayfa1"").Cells([Sayfa1!b1:b65536].Find(ComboBox1.Value).Row, 1)  Private Sub ComboBox2_Change() On Error Resume Next ComboBox1.Value = Sheets(""Sayfa1"").Cells([Sayfa1!a1:a65536].Find(ComboBox2.Value).Row, 2) " "1. Sayfa ismine sag tikla ""KODU GÖRÜNTÜLE"" seç 2. Yeni Form Seç 3. Form üzerine açilir kutu ekle 4. sayfaya geri dön 5. açilir kutuda bulunmasini istedigin verileri hücrelere yaz 6. hücreleri seç ve ekle ad tanimla Örnegin ISIMLER olsun 7. Kod görüntüleyiciye geri dön 8. Çizdigin açilir kutuyu seç 9. PROPERTIES den ROW SOURCE kutusuna ISIMLER yaz 10 comboboxa çift tikla CHANGE olayina range(""c1"").value = combobox1.value yazarsan seçtigin deger c1 hücresine aktarilir" "For b = 2 To Sheets(""veri"").Cells(65536, 5).End(xlUp).Row If WorksheetFunction.CountIf(Sheets(""veri"").Range(""e2:e"" & b), Sheets(""veri"").Cells(b, 5)) = 1 Then ComboBox1.AddItem Sheets(""veri"").Cells(b, 5).Value End If Next" "Option Explicit Private Declare Function SendMessage Lib ""user32"" Alias ""SendMessageA"" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Const CB_SHOWDRPDOWN = &H14F Private Sub Combo1_GotFocus() SendMessage Combo1.hwnd, CB_SHOWDRPDOWN, True, ByVal 0& " "B2"" hücresinin değeri ""1"" ise ComboBox2 de ""A"" seçili B2"" hücresinin değeri ""2"" ise ComboBox2 de ""B"" seçili B2"" hücresinin değeri ""3"" ise ComboBox2 de ""C"" seçili Private Sub UserForm_Initialize() ComboBox2.AddItem ""A"" ComboBox2.AddItem ""B"" ComboBox2.AddItem ""C"" Select Case Sheets(""Sheet ismi"").Range(""B2"") Case 1 ComboBox2 = ""A"" Case 2 ComboBox2 = ""B"" Case 3 ComboBox2 = ""C"" End Select  'diğer seçenek Private Sub UserForm_Initialize() 'form yüklendiğinde Me.ComboBox2.ListIndex = Range(""b2"")1  Private Sub UserForm_Activate() 'form aktif olduğunda Me.ComboBox2.ListIndex = Range(""b2"")  1 " "Private Sub CommandButton3_Click() Select Case ComboBox1.ListIndex Case 0 CommandButton1_Click Case 1 CommandButton2_Click . . End Select " "Private Sub ComboBox1_Change() TextBox1.Text = Application.VLookup( _ ComboBox1.Value, Range(""D8:E11""), 2, False) " "combo1 de yıllar 'combo2 de aylar (1,2,...12) '31 tanede textbox oldugunu varsaydim. 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  " "Private Sub ComboBox1_Change() ComboBox1 = büyük(ComboBox1)  Function büyük(veri) Dim a As Integer Dim b As String For a = 1 To Len(veri) If Mid(veri, a, 1) = ""i"" Then b = ""İ"" ElseIf Mid(veri, a, 1) = ""ı"" Then b = ""I"" Else b = Mid(UCase(veri), a, 1) End If büyük = büyük & b Next " "Private Sub UserForm_Initialize() With ComboBox1 .AddItem ""Kubilay"" .AddItem ""Aşkın"" .AddItem ""Karabulut"" End With " "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 " "FORMA EKLEDİĞİNİZ COMBOBOXA AYLARI YAZDIRIR 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  " "Private Sub ComboBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) MsgBox ""EL İLE VERİ GİRİLEMEZ"" ComboBox1 = """" " "Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) MsgBox ""EL İLE VERİ GİRİLEMEZ""  " "Userformun initialize olayına aşağıdaki kodu ilave edin. Bu kod en altta bulunan comboboxa sayfa isimlerini alacaktır. visual basic kodu:  Private Sub UserForm_Initialize() For sayfa = 1 To Worksheets.Count ComboBox1.AddItem Sheets(sayfa).Name Next sayfa   Sayfa isimlerini seçeceğiniz combobox ada aşağıdaki kodu yazın. Bu kod comboboxtan seçilen sayfaya gidecektir. Böylece tüm işlemler comboboxtan seçilen sayfa üzerinde yapılacaktır. visual basic kodu:  Private Sub ComboBox1_Click() Sheets(ComboBox1.Value).Select  " "Private Sub UserForm_Initialize() ComboBox1.RowSource = ""LISTE!A1:A31"" " "Private Sub UserForm_Initialize() Dim ComboListe As Variant, i As Long ComboListe = Benzersiz_Liste(Range(""A2:A500""), True) For i = 1 To UBound(ComboListe) ComboBox1.AddItem ComboListe(i) Next i  Private Function Benzersiz_Liste(Aralik As Range, DuzListe As Boolean) As Variant Dim Hucre As Range, Benzersiz As New Collection, Say As Long, Dizi() As Variant Application.Volatile On Error Resume Next For Each Hucre In Aralik If Hucre.Formula <> """" Then Benzersiz.Add Hucre.Value, CStr(Hucre.Value) End If Next Hucre Benzersiz_Liste = """" If Benzersiz.Count > 0 Then ReDim Dizi(1 To Benzersiz.Count) For Say = 1 To Benzersiz.Count Dizi(Say) = Benzersiz(Say) Next Say Benzersiz_Liste = Dizi If Not DuzListe Then Benzersiz_Liste = Application.WorksheetFunction.Transpose(Benzersiz_Liste) End If End If On Error GoTo 0 " "Private Sub ComboBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) ComboBox1 = Empty " "Private Sub UserForm_Initialize() With UserForm1.ComboBox1 .AddItem ""izinli"" .AddItem ""kaçak"" .AddItem ""mazeretsiz"" .AddItem ""geç"" End With  " "Private Sub CommandButton1_Click() For i = 1 To 10 UserForm1.Controls(""ComboBox"" & i).Text = i Next i " "A ve G Sütun aralığının Combobox1'e girilen tarihe göre listelenmesi Private Sub CommandButton1_Click() Dim x As Date For i = 2 To Sheets(""EVRAK DEFTERİ"").Cells(65536, 1).End(xlUp).Row x = Sheets(""EVRAK DEFTERİ"").Cells(i, 3) If x >= CDate(ComboBox1.Value) And x <= CDate(ComboBox2.Value) Then listbox1.additem Sheets(""EVRAK DEFTERİ"").Cells(i, 1) & """" & Sheets(""EVRAK DEFTERİ"").Cells(i, 2) & """" & Sheets(""EVRAK DEFTERİ"").Cells(i, 3) & """" & Sheets(""EVRAK DEFTERİ"").Cells(i, 4) & """" & Sheets(""EVRAK DEFTERİ"").Cells(i, 5) End If Next i  'ListBox1'in Sütun ayarlarını; 'ColumnCount Özelliğini İstediğiniz sütun sayısını yazın. 'ColumnWidths Özelliğini Sütun Genişliği.70;80;55...gibi (Kafana Göre ayarlarsın) 'UserForm Çalışırken Sayfaya Müdahale etmek istersen. 'UserFormu tıklat ShowModal özelliğini False yap." ActiveSheet.Cells(ComboBox1.ListIndex + 1, "k") = TextBox1.Value "Private Sub ComboBox1_Change() If ComboBox1.Value = """" Then Dim hucre As Range Me.ListBox1.RowSource = """" For Each hucre In Range(""h2:h"" & Range(""h65536"").End(xlUp).Row) If hucre.Value = """" Then Me.ListBox1.AddItem Range(""B"" & hucre.Row).Value End If Next End If " "Private Sub CommandButton1_Click() Dim i, b As Integer Dim indexsec For i = 0 To ComboBox1.ListCount On Error Resume Next combo = combo & ""Veri: "" & _ ComboBox1.List(i, 0) & ""  İndex'i:"" & i & vbCrLf Next i indexsec = InputBox(""Lütfen Aşağıdaki deger veya İndexlerden bir"" _ & ""deger seçin"" & combo, ""Combobox değer seç"") If indexsec = """" Then Exit Sub If IsNumeric(indexsec) = True Then If indexsec > ComboBox1.ListCount Then MsgBox ""Bu İndex Numarası listede yok"" Exit Sub End If ComboBox1.Value = ComboBox1.List(indexsec, 0) Else For b = 0 To ComboBox1.ListCount On Error Resume Next If ComboBox1.List(b, 0) = Trim(indexsec) Then MsgBox ""Yazdığınız Veri "" & b & "" Nolu Veridir  "" & ComboBox1.List(b, 0) ComboBox1.Value = ComboBox1.List(b, 0) Exit Sub End If Next b End If " "Private Sub UserForm_Initialize() Sheets(""İŞYERİ SABİT BİLGİLER"").Activate TextBox12.Text = Range(""b18"").Text TextBox13.Text = Range(""e18"").Text TextBox14.Text = Range(""b19"").Text TextBox15.Text = Range(""e19"").Text  Sheets(""İŞYERİ SABİT BİLGİLER"").Activate Range(""b18"").Select ActiveCell.Formula = TextBox12 Range(""e18"").Select ActiveCell.Formula = TextBox13 Range(""b19"").Select ActiveCell.Formula = TextBox14 Range(""e19"").Select ActiveCell.Formula = TextBox15  'B18 Hücresinde 06:30 Yazılı 'E18 Hücresinde 15:30 Yazılı 'B19 Hücresinde 23:00 Yazılı Private Sub UserForm_Initialize() For i = 1 To 8 ComboBox1.AddItem Format(Cells(i, 1), ""hh:mm"") Next " "Private Sub cb1_Change() Worksheets(cb1.Text).Select UserForm1.Hide Unload UserForm1  Private Sub UserForm_Initialize() Dim ws As Worksheet For Each ws In Worksheets Me.cb1.AddItem ws.Name Next " "Option Explicit Private Sub ComboBox1_Change() Worksheets(ComboBox1.Text).Select UserForm1.Hide Unload UserForm1  Private Sub UserForm_Initialize() Dim ws As Worksheet For Each ws In Worksheets Me:ComboBox1.AddItem ws.Name Next " "Public satir As Integer Private Sub ComboBox1_Change() satir = ComboBox1.ListIndex + 1  Private Sub CommandButton1_Click() Cells(satir, 1).EntireRow.Delete " "For a = 1 To [b65536].End(3).Row If WorksheetFunction.CountIf(Range(""a1:a"" & a), Cells(a, ""b"")) > 1 Then GoTo 10 c = c + 1 ComboBox2.AddItem Cells(a, ""b"") deg2 = ComboBox2.List(c  1, 0) If IsNumeric(ComboBox2.List(c  1, 0)) = True Then deg2 = ComboBox2.List(c  1, 0)  1 For b = 0 To c  2 deg1 = ComboBox2.List(b, 0) If IsNumeric(ComboBox2.List(b, 0)) = True Then deg1 = ComboBox2.List(b, 0)  1 If deg1 > deg2 Then deg = ComboBox2.List(c  1, 0) ComboBox2.List(c  1, 0) = ComboBox2.List(b, 0) ComboBox2.List(b, 0) = deg End If Next" "Private Sub ListBox1_Click() On Error Resume Next cells(ListBox1.Column(5),""a"").Select  " ListBox1.RowSource = combobox1.text & "!A1:R15" "Private Sub UserForm_Initialize() ComboBox1.RowSource = ""Sayfa2!A1:A20""  Private Sub ComboBox1_Change() sat = ComboBox1.ListIndex + 1 Cells(sat, ""a"").Select " mesaj = MsgBox(ComboBox1.Value & " degerini girdiniz !", ,"Başlık") "Combobox ile seçince aktarsın diyorsanız Private Sub ComboBox1_Change() Worksheets(""sayfa1"").Range(""a1"") = ComboBox1.Value " "Private Sub ComboBox1_Click() TextBox1 = ComboBox1.Column(0) TextBox2 = ComboBox1.Column(1) TextBox3 = ComboBox1.Column(2)  Private Sub UserForm_Activate() With UserForm1.ComboBox1 .AddItem ""masa"" .AddItem ""sıra"" .AddItem ""sandalye"" End With " "Private Sub UserForm_Initialize() With ComboBox1 .AddItem ""pir"" .AddItem ""Mahmut"" .AddItem ""Bayram"" End With " "Sub SchaltflächeInTabellenEinfügen() Dim Tabelle As Worksheet For Each Tabelle In ActiveWorkbook.Worksheets Tabelle.Activate Tabelle.Buttons.Add(96, 15, 93, 24).Select Selection.Name = ""Datum"" Selection.Characters.Text = ""Datum"" Selection.OnAction = ""Datum2"" Range(""A1"").Select Next Tabelle " "Sub command_add() Dim cmdB As CommandBar Set cmdB = CommandBars.Add(""MyToolbar"", temporary:=True) With cmdB .Left = 50 .Top = 100 .Visible = True End With " "Dim x As Integer For x = 1 To 127 Cells(x, 1) = Application.CommandBars(x).Name Cells(x, 2) = Application.CommandBars(x).NameLocal Next x" "Private Sub CommandButton1_Click() sifre = InputBox(""Kodların çalışması için şifre gerekiyor"", _ ""Yetkili Kişi"", ""Şifreyi buraya yazınız."") If sifre = ""excel"" Then 'şifre MsgBox ""Şifre doğrulandı"", vbInformation, _ ""Şifre Doğru"" 'buraya kodlarınızı yapıştırınız ' "" "" Else MsgBox ""Yanlış şifre girdiniz."" & Chr(13) & _ ""Kod çalışması iptal edildi"", vbCritical, ""Yanlış şifre"" Cancel = True End If " "Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.Top = CommandButton1.Top + 20 " "Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.BackColor = vbYellow  Private Sub UserForm_Initialize() CommandButton1.Tag = CommandButton1.BackColor  Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.BackColor = CommandButton1.Tag " "Userformunuzun üzerindeki combobox'ınızda görünmesini istediğiniz sabit değerler için formunuzun code bölümüne; Kod: Private Sub UserForm_Initialize() With ComboBox1 .AddItem ""Kubilay"" .AddItem ""Aşkın"" .AddItem ""Karabulut"" End With  " "Sub ac() sPath = ""C:\My Documents\"" On Error Resume Next For Each cell In Range(""A1"", Range(""a1"").End(xlDown)) Workbooks.Open Filename:=sPath & cell.Value & "".xls"" Next On Error GoTo 0 For Each cell In Range(""A1"", Range(""a1"").End(xlDown)) Workbook" "Sub lstProprieteFichier() lg = 1 Worksheets.Add For Each LstPro In ActiveWorkbook.BuiltinDocumentProperties Cells(lg, 1).Value = LstPro.Name On Error Resume Next Cells(lg, 2).Value = ActiveWorkbook.BuiltinDocumentProperties.Item(LstPro.Name) lg = lg + 1 Next Columns(""A:A"").EntireColumn.AutoFit Range(""B10:B12"").NumberFormat = ""[$F800]dddd, mmmm dd, yyyy"" " "Private Sub Workbook_Open () Range(""A1"").Value = Range(""A1"").Value + 1 " "Option Explicit Dim FileDir As String Dim Filenumber As String Const FilePath = ""C:"" Private Sub cmdSave_Click() On Error Resume Next Filenumber = InputBox(""Oluşturulacak kitabın ismi?"", ""pir"") If Filenumber = """" Then MsgBox ""HATA"", vbOKOnly, ""pir"" Exit Sub End If FileDir = FilePath & Filenumber & "".xls"" SaveAs Filename:=FileDir On Error GoTo 0  " "Private Sub Workbook_Open() 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 RegistrierungsNr.:"", ""Testphase abgelaufen, Reg.Nr. erforderlich"") If passwort <> ""36"" Then MsgBox "" Das Kennwort ist ungültig,"" & Chr(13) & Chr(13) & ""der Vorgang wird abgebrochen !"" ThisWorkbook.Close End If MsgBox (""Registrierung erfolgreich"") Application.DisplayAlerts = True End If " "Private Sub Workbook_Open() Dim passwort As String passwort = InputBox(""Bitte geben Sie das Passwort"" & Chr(13) & Chr(13) & "" für das Einfügen von Kommentaren ein:"", ""Passwortabfrage für das Einfügen von Kommentaren"") If passwort <> ""36"" Then MsgBox "" Das Kennwort ist ungültig,"" & Chr(13) & Chr(13) & ""Sie dürfen keine Kommentare einfügen !"" Application.CommandBars(""Worksheet Menu Bar"").Controls(""Einfügen"").Controls(""Kommentar"").Enabled = False Application.CommandBars(""Cell"").Controls(""Kommentar einfügen"").Enabled = False Exit Sub Else Application.CommandBars(""Worksheet Menu Bar"").Controls(""Einfügen"").Controls(""Kommentar"").Enabled = True Application.CommandBars(""Cell""

;2));1;-10))/7)" Bul komutu aktif sayfada "Sub Test() ActiveSheet.UsedRange.Select Application.CommandBars.FindControl(ID:=1849).Execute End Sub" Bul komutu bütün sayfalarda "Sub Test2() For i = 1 To Worksheets.Count Sheets(i).Select Sheets(i).UsedRange.Select Application.CommandBars.FindControl(ID:=1849).Execute Next End Sub " Bul makrosu "Sub DoBox() ActiveSheet.Cells.Find What:="""", LookAt:=xlWhole Application.CommandBars(""Worksheet Menu Bar"").FindControl( _ ID:=1849, recursive:=True).Execute End Sub" Bul makrosu "Option Compare Binary Private Sub CheckBox4_Click() If CheckBox4.Value = True Then CheckBox3.Enabled = False End Sub Private Sub CommandButton1_Click() If TextBox1.Text = """" Then Exit Sub If CheckBox1.Value = True Then look = 1 Else look = 2 If CheckBox3.Value = True Then bas = 1 Else bas = 2 ListBox1.Clear Set c = Range(""a:a"").Find(TextBox1, LookIn:=xlValues, MatchCase:=CheckBox2.Value, LookAt:=look, SearchDirection:=bas) If Not c Is Nothing Then firstAddress = c.Address ListBox1.AddItem ListBox1.List(0, 0) = c.Address ListBox1.List(0, 1) = c basla: Set c = Range(""a:a"").FindNext(c) If Not c Is Nothing And c.Address <> firstAddress Then a = a + 1 ListBox1.AddItem ListBox1.List(a, 0) = c.Address ListBox1.List(a, 1) = c GoTo basla End If End If If CheckBox4.Value = 0 Then Exit Sub If ListBox1.ListCount > 0 Then For x = 0 To ListBox1.ListCount - 2 For y = x + 1 To ListBox1.ListCount - 1 If Val(Replace(ListBox1.List(x, 0), ""$A$"", """")) > Val(Replace(ListBox1.List(y, 0), ""$A$"", """")) Then Call swap(x, y) Next y, x End If End Sub Private Sub ListBox1_Click() Range(ListBox1.List(ListBox1.ListIndex, 0)).Select End Sub Sub swap(ind1, ind2) Set l = ListBox1 ara = l.List(ind1, 0) l.List(ind1, 0) = l.List(ind2, 0) l.List(ind2, 0) = ara ara = l.List(ind1, 1) l.List(ind1, 1) = l.List(ind2, 1) l.List(ind2, 1) = ara End Sub" Bul mesaj ver aynısı var diye "Private Sub Worksheet_Change(ByVal Target As Range) Dim Bul As Range, Adres On Error GoTo HATA If Target.Column = 1 And Not Target = """" Then Set Bul = Range(""A:A"").Find(Target, LookAt:=xlWhole) Adres = Bul.Address Set Bul = Range(""A:A"").FindNext(Bul) If Not Bul.Address = Adres Then MsgBox Target & "" değeri daha önce girilmiş"" Target.Select End If End If HATA: End Sub" Bul penceresi "Sub Dialog_32() Application.Dialogs(xlDialogFormulaFind).Show End Sub" Bul penceresinin açılması "Private Sub CommandButton1_Click() Application.CommandBars.FindControl(ID:=1849).Execute End Sub" Bul ve lİstele "Private Sub ComboBox1_Change() ListBox1.Clear son = Cells(65536, 1).End(xlUp).Row For i = 1 To son If Cells(i, 7).Value = ComboBox1.Value Then Cells(i, 1).Select c = c + 1 For y = 1 To 10 ListBox1.AddItem ListBox1.List(c - 1, y - 1) = Cells(i, y + 1).Value Next End If Next End Sub Private Sub ListBox1_Click() End Sub Private Sub UserForm_Initialize() ComboBox1.AddItem ""İl Sosyal Hizmetler Müdürlüğü"" ComboBox1.AddItem ""Gözde Birsöz Çocuk Yuvası Müdürlüğü"" ComboBox1.AddItem ""75. Yıl Huzurevi Müdürlüğü"" ComboBox1.AddItem ""Aile Danışma Merkezi Müdürlüğü"" ListBox1.ColumnCount = 10 End Sub " Bul-değiştir-sil-kaydet makrosu "Private Sub CommandButton1_Click() 'bul For Each hucre In Range(""a2:a"" & WorksheetFunction.CountA(Range(""a1:a65000""))) If StrConv(hucre.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then hucre.Select TextBox1 = ActiveCell.Offset(0, 1).Value TextBox2 = ActiveCell.Offset(0, 2).Value TextBox3 = ActiveCell.Offset(0, 3).Value End If Next End Sub Private Sub CommandButton2_Click() 'değiştir ActiveCell.Offset(0, 1).Value = TextBox1.Value ActiveCell.Offset(0, 2).Value = TextBox2.Value ActiveCell.Offset(0, 3).Value = TextBox3.Value End Sub Private Sub CommandButton3_Click() 'sil satır = ActiveCell.Row Rows(satır).Delete Shift:=xlUp 'say = WorksheetFunction.CountA(Range(""A2:A65000"")) For i = 1 To WorksheetFunction.CountA(Range(""a2:a65000"")) Cells(i + 1, 1) = i Next End Sub Private Sub CommandButton4_Click() 'kaydet Dim bak As Range Dim say As Integer For Each bak In Range(""A1:A"" & WorksheetFunction.CountA(Range(""A1:A65000""))) If bak.Value = cbAd.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(cbAd.Value, vbUpperCase) Then MsgBox ""Bu isimde bir kaydınız bulundu"" Exit Sub End If Next bak b = WorksheetFunction.CountA(Sheets(""sayfa1"").Range(""A:A"")) Sheets(""sayfa1"").Range(""a"" & b + 1).Select ActiveCell = ComboBox1.Value ActiveCell.Offset(0, 1) = TextBox1.Value ActiveCell.Offset(0, 2) = TextBox2.Value ActiveCell.Offset(0, 3) = TextBox3.Value End Sub Private Sub UserForm_Initialize() b = WorksheetFunction.CountA(Range(""A2:A6500"")) ComboBox1.RowSource = ""sayfa1!a2:a"" & b End Sub" Bullets (işaret) ekleme silme "Option Explicit Sub AddBullets() Dim Bullet As String Dim Dash As String Dim Cel As Range Dim Str As String Dim i As Long Bullet = ""• "" Dash = "" - "" 'select which cells to perform an action on For Each Cel In Selection Str = Cel.Value 'If there is already a bullet there then put a dash in its place If Left(Str, Len(Bullet)) = Bullet Then Str = Right(Str, Len(Str) - 2) Cel.Value = Dash & Str Else 'If there is already a dash there then trim back to normal text If Left(Str, Len(Dash)) = Dash Then Str = Trim(Cel.Value) i = Len(Str) - 1 If i >= 0 Then Cel.Value = Trim(Right(Str, i)) End If Else 'Otherwise add the bullet Cel.Value = Bullet & Str End If End If 'Go to the next cell in the selection and do the same thing Next Cel End Sub" Bul-renklendir(hücre aralıklı) "Sub Bul_Renklendir() Dim neyi As String, rng As Range, alan As Range neyi = Application.InputBox(""A1:D20 hücrelerinde, bulmak istediğiniz veri"", , """") Set alan = Range(""A1:D20"") alan.Interior.ColorIndex = xlNone For Each rng In alan If StrConv(rng, vbProperCase) = StrConv(neyi, vbProperCase) Then rng.Interior.ColorIndex = 35 End If Next rng Set alan = Nothing End Sub" Bul-sil-değiştir-kaydet kodları "Private Sub CommandButton1_Click() For Each hucre In Range(""a2:a"" & WorksheetFunction.CountA(Range(""a1:a65000""))) If StrConv(hucre.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then hucre.Select TextBox1 = ActiveCell.Offset(0, 1).Value TextBox2 = ActiveCell.Offset(0, 2).Value TextBox3 = ActiveCell.Offset(0, 3).Value End If Next End Sub Private Sub CommandButton2_Click() ActiveCell.Offset(0, 1).Value = TextBox1.Value ActiveCell.Offset(0, 2).Value = TextBox2.Value ActiveCell.Offset(0, 3).Value = TextBox3.Value End Sub Private Sub CommandButton3_Click() satır = ActiveCell.Row Rows(satır).Delete Shift:=xlUp 'say = WorksheetFunction.CountA(Range(""A2:A65000"")) For i = 1 To WorksheetFunction.CountA(Range(""a2:a65000"")) Cells(i + 1, 1) = i Next End Sub Private Sub CommandButton4_Click() b = WorksheetFunction.CountA(Sheets(""sayfa1"").Range(""A:A"")) Sheets(""sayfa1"").Range(""a"" & b + 1).Select ActiveCell = ComboBox1.Value ActiveCell.Offset(0, 1) = TextBox1.Value ActiveCell.Offset(0, 2) = TextBox2.Value ActiveCell.Offset(0, 3) = TextBox3.Value End Sub Private Sub UserForm_Initialize() b = WorksheetFunction.CountA(Range(""A2:A6500"")) ComboBox1.RowSource = ""sayfa1!a2:a"" & b End Sub" Bul-sil-değiştir-kaydet kodları2 "Dim comb() As New Class1 Dim index As Integer Private Sub ComboBox1_Click() index = ComboBox1.ListIndex + 1 End Sub Private Sub CommandButton1_Click() End End Sub Private Sub CommandButton2_Click() For a = 1 To 13 Controls(""combobox"" & a).RowSource = """" Cells(index, a) = Controls(""combobox"" & a) If IsNumeric(Controls(""combobox"" & a)) = True Then Cells(index, a) = Controls(""combobox"" & a) * 1 Next Call UserForm_Initialize End Sub Private Sub UserForm_Initialize() For a = 1 To 13 ReDim Preserve comb(13) Set comb(a).comb = Controls(""combobox"" & a) adres = Range(Cells(1, a), Cells(Cells(65536, 1).End(3).Row, a)).Address Controls(""combobox"" & a).RowSource = adres Next End Sub 'classmodüle Public WithEvents comb As MSForms.ComboBox Dim a As Integer Private Sub comb_Click() If a = 1 Then Exit Sub For a = 1 To 13 If UserForm1.Controls(""combobox"" & a).Name <> comb.Name Then UserForm1.Controls(""combobox"" & a).ListIndex = comb.ListIndex Next End Sub Private Sub comb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) a = 1 End Sub" Bulunduğun dizinde wav dosyası çalmak için "Declare Function sndPlaySound Lib ""winmm.dll"" _ Alias ""sndPlaySoundA"" ( _ ByVal SoundName As String, _ ByVal Flags As Long) As Long Sub PlayWav(ByVal WavFileName As String) Call sndPlaySound(WavFileName, 0) End Sub Sub TestWav() Call PlayWav(ThisWorkbook.Path + ""\pir.wav"") End Sub" Bulunulan hücrenin adresi (örnek g3) "Sub Markierung() Dim Mark_Bereich Mark_Bereich = Selection.Address(False, False) MsgBox Mark_Bereich End Sub" Bulunulan klasöre tarihli yedek alır "Thisworkbooka Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim Phad As String Phad = ThisWorkbook.Path ActiveWorkbook.SaveCopyAs Filename:=Phad & ""\"" & Format(Now, ""DD-MM-YY_hh-mm"") & ""_Backup_Beispielmappe_113.XLS"" End Sub" Buton ekle-kaldır "Sub EditionCopierOK() Application.CommandBars(1).Controls(2).Controls(4).Enabled = True End Sub Sub EditionCopierNo() Application.CommandBars(""Edit"").FindControl(ID:=19).Enabled = False End Sub Sub menuOutilsOptNo() Application.CommandBars(""Tools"").FindControl(ID:=522).Enabled = False End Sub Sub menuOutilsOptok() Application.CommandBars(""Tools"").FindControl(ID:=522).Enabled = True End Sub" Buton İle dİĞer sayfayi yazdirmak " sheets(""sayfa2"").PrintOut Sn tb belki işinize yarar birde bunu deneyin a1 hüresine yazdığınız rakan kadar sayfa çıktısı alabilirsiniz Sub Test() Sheets(""sayfa2"").PrintOut From:=1, To:=[a1].Value End Su" Buton komutlarina uyari ekleme "BU KOD BUTONLARDAN VERDİĞİNİZ KOMUTLARI YERİNE GETİRMEDEN ÖNCE KULLANICIYA UYARI VERİR Dim cevap cevap = MsgBox(""Kaydı Silmek İstediğinize Eminmisiniz ? Evet Dersen Veri Kalıcı Olarak Silinecek ! "", vbYesNo + vbQuestion + vbDefaultcmdsil + vbApplicationModal, ""Kayıt Silinecek"") If cevap = vbNo Then End End If " Buton resimleri "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" Buton yardimiyla kayit olan satiri sİlme Sheets("Liste").Rows(Cells(2, 1) & ":" & Cells(2, 1)).Delete Shift:=xlUp Butona hareket verİr "BU KOMUT BUTONU AŞŞAĞI YUKARI HAREKET ETTİRİR(ENTERE BASTIKÇA) Private Sub CommandButton1_Click() Sheets(""sayfa2"").Select Range(""A1"").Show End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) CommandButton1.Top = ActiveCell.Rows.Top End Sub " Butona tıklayınca comboboxa veri aldırma "Private Sub CommandButton1_Click() Dim NbreEnreg As Integer With UserForm1 .ComboBox1.RowSource = ""A1:A9"" NbreEnreg = .ComboBox1.ListCount .ComboBox1.ListRows = NbreEnreg .Show 'bu satırı silebilirsiniz End With End Sub" Butonala text box aÇarak verİ aktarimi "Sorunu ikitürlü anladım. 1.Hücreye yazdığın dğerleri textboxlara getirmek. Kod: Private Sub UserForm_Initialize() TextBox1.Text = Range(""b1"").Text TextBox2.Text = Range(""b2"").Text TextBox3.Text = Range(""b3"").Text TextBox4.Text = Range(""b4"").Text TextBox5.Text = Range(""b5"").Text End Sub 2.TextBpxa Yazdığın değerleri İlgili hücrelere aktarmak. Kod: Private Sub CommandButton1_Click() Range(""b1"").Select ActiveCell.Formula = TextBox1 Range(""b2"").Select ActiveCell.Formula = TextBox2 Range(""b3"").Select ActiveCell.Formula = TextBox3 Range(""b4"").Select ActiveCell.Formula = TextBox4 Range(""b5"").Select ActiveCell.Formula = TextBox5 End Sub" Butonala text box aÇarak verİ aktarimi. "Sorunu ikitürlü anladım. 1.Hücreye yazdığın dğerleri textboxlara getirmek. Kod: Private Sub UserForm_Initialize() TextBox1.Text = Range(""b1"").Text TextBox2.Text = Range(""b2"").Text TextBox3.Text = Range(""b3"").Text TextBox4.Text = Range(""b4"").Text TextBox5.Text = Range(""b5"").Text End Sub 2.TextBpxa Yazdığın değerleri İlgili hücrelere aktarmak.Kod: Private Sub CommandButton1_Click() Range(""b1"").Select ActiveCell.Formula = TextBox1 Range(""b2"").Select ActiveCell.Formula = TextBox2 Range(""b3"").Select ActiveCell.Formula = TextBox3 Range(""b4"").Select ActiveCell.Formula = TextBox4 Range(""b5"").Select ActiveCell.Formula = TextBox5 End Sub " Butonda verİ kaydirma "EN BAŞA DÖN Private Sub CommandButton1_Click() TextBox1 = Cells(2, 1) ComboBox1 = Cells(2, 2) TextBox2 = Cells(2, 3) TextBox3 = Cells(2, 4) End Sub 'EN SONA GİT Private Sub CommandButton4_Click() Dim say As Integer say = WorksheetFunction.CountA(Range(""A1:A65000"")) TextBox1 = Cells(say, 1) ComboBox1 = Cells(say, 2) TextBox2 = Cells(say, 3) TextBox3 = Cells(say, 4) End Sub 'BİR,BİR GERİ GİT Private Sub CommandButton2_Click() If TextBox1 = 1 Then Exit Sub Else TextBox1 = TextBox1 - 1 ComboBox1 = Cells(TextBox1 + 1, 2) TextBox2 = Cells(TextBox1 + 1, 3) TextBox3 = Cells(TextBox1 + 1, 4) End If End Sub 'BİR,BİR İLERİ GİT Private Sub CommandButton3_Click() Dim say As Integer say = WorksheetFunction.CountA(Range(""A1:A65000"")) If TextBox1 = say Then Exit Sub Else TextBox1 = TextBox1 + 1 ComboBox1 = Cells(TextBox1 + 1, 2) TextBox2 = Cells(TextBox1 + 1, 3) TextBox3 = Cells(TextBox1 + 1, 4) End If End Sub " Butonla sayfa koruması yapma "Sub Set_Protection() On Error GoTo errorHandler Dim myDoc As Worksheet Dim cel As Range Set myDoc = ActiveSheet myDoc.Unprotect For Each cel In myDoc.UsedRange If Not cel.HasFormula And _ Not TypeName(cel.Value) = ""Date"" And _ Application.IsNumber(cel) Then cel.Locked = False cel.Font.ColorIndex = 5 Else cel.Locked = True cel.Font.ColorIndex = xlColorIndexAutomatic End If Next myDoc.Protect Exit Sub errorHandler: MsgBox Error End Sub" Butonları ve numaralarını görün "Sub AfficheBoutons() Dim NewBarreOutil As CommandBar Dim NewBouton As CommandBarButton Dim i As Integer, IconOn As Integer, IconOff As Integer 'Supprime la barre si elle existe déjà On Error Resume Next Application.CommandBars(""BarBouton"").Delete On Error GoTo 0 Set NewBarreOutil = Application.CommandBars.Add _ (Name:=""BarBouton"", temporary:=True) NewBarreOutil.Visible = True IconOn = 1 IconOff = 200 For i = IconOn To IconOff Set NewBouton = NewBarreOutil.Controls.Add _ (Type:=msoControlButton, ID:=2950) NewBouton.FaceId = i NewBouton.Caption = ""FaceID = "" & i Next i NewBarreOutil.Width = 700 NewBarreOutil.Left = 50 NewBarreOutil.Top = 120 End Sub Sub SupMenuBar() Application.CommandBars(""Worksheet Menu Bar"").Enabled = False End Sub" Butonların değerini labele yazdırma "Private Sub UserForm_Activate() Do If UserForms.Count < 1 Then Exit Sub DoEvents If TypeName(ActiveControl) = ""CommandButton"" Then _ Label1.Caption = ActiveControl.Caption Loop End Sub" Butonların gizlenmesi "Sub Düğme1_Tıklat() Dim a Dim x a = ActiveSheet.Shapes.Count For x = 1 To a ActiveSheet.Shapes(x).Visible = False Next End Sub" Butonu kullanıma açma-kapama "Private Sub CommandButton1_Click() CommandButton3.Enabled = False CommandButton4.Enabled = False CommandButton5.Enabled = False End Sub Private Sub CommandButton2_Click() CommandButton3.Enabled = True CommandButton4.Enabled = True CommandButton5.Enabled = True End Sub" Butonun adını söyler "Sub Shape_Index_Name() Dim myVar As Shapes Dim shp As Shape Set myVar = Sheets(1).Shapes For Each shp In myVar MsgBox ""Index = "" & shp.ZOrderPosition & vbCrLf & ""Name = "" _ & shp.Name Next End Sub" Button'lara fare ile geldiğimde renk değiştirmesi "Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.BackColor = vbYellow End Sub Private Sub UserForm_Initialize() CommandButton1.Tag = CommandButton1.BackColor End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.BackColor = CommandButton1.Tag End Sub" Bütün excel dosyalarının %85 ile açılması "Sub Auto_Open() ActiveWindow.Zoom = 85 End Sub 'Dosyayı kaydedin. Mesela Kucult.XLS ismini verin. 'Dosyayı C:\Windows\Application Data\Microsoft\Excel\Xlstart klasörüne kopyalayın." Bütün pencereler minimize "Sub ButunPencerelerMinimize() Dim Pencere As Window For Each Pencere In Windows If Pencere.Visible = False Then Pencere.Visible = True Pencere.WindowState = xlMinimized Next End Sub " Büyük-küçük harf dönüştürür, dönüştürülen hücreleri belirtir. (Toggle) "Sub ToggleCase() Dim Upr, Lwr, Ppr Set OriginalCell = ActiveCell Set OriginalSelection = Selection If IsEmpty(ActiveCell) Then GoTo NoneFound On Error GoTo Limiting If OriginalCell = OriginalSelection Then Selection.Select GoTo Converting Else Resume Next End If Limiting: On Error GoTo NoneFound Selection.SpecialCells(xlCellTypeConstants, 3).Select Converting: Application.StatusBar = ""Ändere Gross- und Kleinschreibung "" For Each DCell In Selection.Cells Upr = UCase(DCell) Lwr = LCase(DCell) If Upr = DCell.Value Then DCell.Value = Lwr Else DCell.Value = Upr End If Next DCell Application.StatusBar = False Exit Sub NoneFound: MsgBox ""Alle Zellen der aktuelllen Auswahl enthalten Formeln oder sindleer!"", vbExclamation, "" Fehler aufgetreten"" OriginalSelection.Select OriginalCell.Activate End Sub" C de test isimli klasör oluşturur "Sub Cree_Repert() Dim Repert As String Repert = Dir(""c:\test\"", vbDirectory) If Repert = """" Then MkDir ""c:\test"" End If End Sub" C dizindeki klasörleri listboxta listeler "Sub Liste_Repert() Dim Repert As String Repert = Dir(""c:\"", vbDirectory) Do While Repert <> """" 'Si Repert est un dossier. If GetAttr(""c:\"" & Repert) = vbDirectory Then UserForm1.ListBox1.AddItem Repert End If Repert = Dir Loop End Sub" C dizininde xls dosya sayısı "Sub ExcelDateienZählen() With Application.FileSearch .NewSearch .LookIn = ""C:\"" .Filename = ""*.xls"" .Execute MsgBox .FoundFiles.Count End With End Sub" C klasöründe .Ini dosyası oluşturur, aktif ve açık excel dosya sayısını içine yazar "Sub lfdNr() Dim Nr% Dim dName$ Dim Zielordner$, Dateiname$ 'Hier den Pfad verändern Zielordner = ""c:\"" 'Hier den Dateinamen verändern Dateiname = ""lfdNr"" dName = Zielordner & Dateiname & "".ini"" Close On Error Resume Next Open dName For Input As #1 If Err > 0 Then Nr = 1 Close Open dName For Output As #1 Print #1, Nr Close Exit Sub Else Input #1, Nr Close Open dName For Output As #1 Print #1, Nr + 1 Close End If ActiveCell.Value = Nr End Sub" C kolonuna tıklayınca genişler, başka hücreye tıklayınca daralır "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" C sÜtunu bos olan bÜtÜn satİrlarİ sİlmek "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 " C sütununda aralıklı olanları toplar "Sub Add_Totals() For Each NumRange In Columns(""C"").SpecialCells(xlConstants, xlNumbers).Areas SumAddr = NumRange.Address(False, False) NumRange.Offset(NumRange.Count, 0).Resize(1, 1).Formula = ""=SUM("" & SumAddr & "")"" Next NumRange End Sub" C sütununda aralıklı toplam alır "Sub Add_Totals() For Each NumRange In Columns(""C"").SpecialCells(xlConstants, xlNumbers).Areas SumAddr = NumRange.Address(False, False) NumRange.Offset(NumRange.Count, 0).Resize(1, 1).Formula = ""=SUM("" & SumAddr & "")"" Next NumRange End Sub" C sütununda büyük harf "Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Application.Intersect(Target, Range(""C:C"")) Is Nothing Then Target(1).Value = UCase(Target(1).Value) End If Application.EnableEvents = 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" C sütunundakileri karşılaştırıp kaç tane olduğunu bulur ve diğer sayfaya aktarır "Sub aktar() Dim sonsat As Long, sat As Long, i As Long, sut As Byte Sheets(""2007"").Select Sheets(""PARCA"").Range(""A3:G65536"").ClearContents sonsat = Cells(65536, ""A"").End(xlUp).Row sat = 3 If sonsat < 3 Then Exit Sub For i = 3 To sonsat If WorksheetFunction.CountIf(Sheets(""PARCA"").Range(""C3:C65536""), Cells(i, ""C"")) = 0 Then For sut = 1 To 7 Sheets(""PARCA"").Cells(sat, sut).Value = Cells(i, sut).Value Next sut sat = sat + 1 End If Next i Sheets(""PARCA"").Select MsgBox ""İŞLEM TAMAM"" End Sub" C sütununun otomatik genişlemesi ve daralması "Sayfanın kod bölümüne 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" C1 hücre ismi ile kitap oluşturma "Sub NomClasseur() Dim Chr As String 'déclare la variable Chr = Range(""Sayfa1!C1"") 'Feuille Essai et cellule C1 ChDrive ""C"" 'si C n'est pas le disque par défaut ChDir ""C:\"" ActiveWorkbook.SaveAs Filename:=(Chr) End Sub" C1 hücresini sağdan 3 say, c2 ile birleştir farklı kaydet ve aç "Sub NomClasseur1() Dim Month As String * 3 'seulement les 3 premières lettres Dim Year As String Month = Range(""Feuil1!C1"") Year = Right(Range(""Feuil1!C2""), 2) 'pour ne renvoyer que 01 de 2001 ChDrive ""C"" ChDir ""C:\ajeter\"" ActiveWorkbook.SaveAs Filename:=(Month) & (Year) End Sub" C10 100 ise mesaj ver "Private Sub Worksheet_Calculate() Static DblWert If Range(""C10"") = 100 Then If Range(""C10"") = DblWert Then Exit Sub MsgBox ""Jetzt ist der Wert in A1 100!"" End If DblWert = Range(""C10"") End Sub" C5 İle c15 arasindakİ boŞ hÜcrelerİ saymak ve d1 e yazdirmak İstİyorum "Private Sub Worksheet_Change(ByVal Target As Range) Range(""D1"").Value = WorksheetFunction.CountBlank(Range(""C5:C15"")) End Sub" C5:c20 arasındaki sıra numaraları arasındaki boşlukları alır "Sub BlendeAus() Range(""C5:C20"").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True End Sub" C8:c18 arası hücrelerinde sola tıklayınca sağ fare menüsü çıksın "Sayfanın kod böümüne Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range(""C8:C18"")) Is Nothing Then Application.CommandBars(""Cell"").ShowPopup End If End Sub" C8:c18 arasına tıklayınca sağ fare menüsü açılır "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range(""C8:C18"")) Is Nothing Then Application.CommandBars(""Cell"").ShowPopup End If End Sub" Calİsma sayfasİnİn yedegİnİ alma "Sub Makro1() Sheets(""Sayfa1"").Copy ActiveWorkbook.SaveAs Filename:=""C:\Documents And Settings\ocamsul\Belgelerim\[a1] End Sub " Capslock u açtırma (ışığını yakma) "Private Declare Function GetVersionEx Lib ""kernel32"" _ Alias ""GetVersionExA"" (lpVersionInformation As OSVERSIONINFO) As Long Private Declare Sub keybd_event Lib ""user32"" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Declare Function GetKeyboardState Lib ""user32"" _ (pbKeyState As Byte) As Long Private Declare Function SetKeyboardState Lib ""user32"" _ (lppbKeyState As Byte) As Long Private Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 ' Maintenance string for PSS usage End Type Const VK_CAPITAL = &H14 Const KEYEVENTF_EXTENDEDKEY = &H1 Const KEYEVENTF_KEYUP = &H2 Const VER_PLATFORM_WIN32_NT = 2 Const VER_PLATFORM_WIN32_WINDOWS = 1 Dim Keys(0 To 255) As Byte Sub SetCapsOn() Dim o As OSVERSIONINFO Dim NumLockState As Boolean Dim ScrollLockState As Boolean Dim CapsLockState As Boolean ' CapsLock handling: o.dwOSVersionInfoSize = Len(o) GetVersionEx o CapsLockState = Keys(VK_CAPITAL) If CapsLockState <> True Then 'Turn capslock on If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then '===== Win95 Keys(VK_CAPITAL) = 1 SetKeyboardState Keys(0) ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then '===== WinNT 'Simulate Key Press keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0 'Simulate Key Release keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY _ Or KEYEVENTF_KEYUP, 0 End If End If End Sub" Cd açıp kapatma "Option Explicit Public Declare Function SendCDcmd Lib ""winmm.dll"" _ Alias ""mciSendStringA"" ( _ ByVal lpstrCommand As String, _ ByVal lpstrReturnString As String, _ ByVal uReturnLength As Long, _ ByVal hwndCallback As Long) As Long Dim lRet As Long Public Sub EjectCD() lRet = SendCDcmd(""set CDAudio door open"", vbNullString, 127, 0) End Sub Public Sub CloseCD() lRet = SendCDcmd(""set CDAudio door closed"", vbNullString, 127, 0) End Sub" Cd açma kapama "Private Declare Function mciExecute Lib ""winmm.dll"" (ByVal _ lpstrCommand As String) As Long Public Sub Ap_001_Open() Call mciExecute(""Set CDaudio door open"") End Sub Public Sub Ap_001_Close() Call mciExecute(""Set CDaudio door closed"") End Sub" Cd açma kapama 2 "Option Base 1 Public Declare Function mciSendString Lib ""winmm.dll"" Alias ""mciSendStringA"" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Sub main() Dim Now As String Dim a(2) As String a(1) = ""set cdaudio door open"" a(2) = ""set cdaudio door closed"" total = 1 For I = 1 To (total * 2) If Int(I / 2) = I / 2 Then Now = vbString(a(2), 0) Else Now = vbString(a(1), 0) End If Next I End Sub Function vbString(ByVal Command As String, ByVal hWnd As Long) As String Dim Buff As String Dim dwR As Long Buff = Space$(100) ' Create a buffer dwR = mciSendString(Command, ByVal Buff, Len(Buff), hWnd) vbString = Buff End Function" Check atma A1:A10 hücreleri "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range(""A1:A10"")) Is Nothing Then Target.Font.Name = ""Marlett"" If Target = vbNullString Then Target = ""a"" Else Target = vbNullString End If End If End Sub" Checkbox onaylı İse a1 hücresine 100 yazsın 1 "Private Sub CheckBox1_Click() [A1] = CheckBox1 * 20 + 120 End Sub" Checkbox onaylı İse a1 hücresine 100 yazsın 2 "Private Sub UserForm_Initialize() Range(""a1"") = 120 End Sub Private Sub CheckBox1_Click() If Me.CheckBox1.Value = False Then Range(""a1"") = 120 Else Range(""a1"") = 100 End If End Sub" Checkbox u işaretlettirme "Aktif sayfaya 1 tane checkbox ve kod bölümüne aşağıdaki kodları Option Explicit Private Sub CheckBox1_Click() Range(""F2"").Value = CheckBox1.Value End Sub 'Modüle Option Explicit Sub CheckboxEinAus() With Sheets(""Tabelle1"").OLEObjects(""CheckBox1"") .Object.Value = Not .Object.Value End With End Sub" Checkboxla sayfa yazdırma "Private Sub CommandButton1_Click() If CheckBox1 = True Then Sheets(""Sayfa1"").PrintOut ElseIf CheckBox2 = True Then Sheets(""Sayfa2"").PrintOut ElseIf CheckBox3 = True Then Sheets(""Sayfa3"").PrintOut ElseIf CheckBox4 = True Then Sheets(""Sayfa4"").PrintOut End If End Sub" Chr ne demektir "Sub MsgAscii() Dim sayi1 As Integer For sayi1 = 1 To 255 msg = msg & (sayi1) & Chr(58) & Chr(sayi1) & Space(1) Next sayi1 MsgBox msg, 64, Chr(83) & Chr(252) & Chr(108) & Chr(101) _ & Chr(121) & Chr(109) & Chr(97) & Chr(110) & Chr(32) & Chr(85) _ & Chr(90) & Chr(85) & Chr(78) & Chr(75) & Chr(214) & Chr(80) & _ Chr(82) & Chr(220) End Sub" Class modullegeri alma "Option Explicit Private mcolUndoObjects As Collection Private mUndoObject As clsUndoObject Public Function AddAndProcessObject(oObj As Object, sProperty As String, vValue As Variant) As Boolean Set mUndoObject = New clsUndoObject With mUndoObject Set .ObjectToChange = oObj .NewValue = vValue .PropertyToChange = sProperty mcolUndoObjects.Add mUndoObject If .ExecuteCommand = True Then AddAndProcessObject = True Else AddAndProcessObject = False End If End With End Function Private Sub Class_Initialize() Set mcolUndoObjects = New Collection End Sub Private Sub Class_Terminate() ResetUndo End Sub Public Sub ResetUndo() While mcolUndoObjects.Count > 0 mcolUndoObjects.Remove (1) Wend Set mUndoObject = Nothing End Sub Public Sub UndoAll() Dim lCount As Long ' On Error Resume Next For lCount = mcolUndoObjects.Count To 1 Step -1 Set mUndoObject = mcolUndoObjects(lCount) mUndoObject.UndoChange Set mUndoObject = Nothing Next ResetUndo End Sub Public Sub UndoLast() Dim lCount As Long ' On Error Resume Next If mcolUndoObjects.Count >= 1 Then Set mUndoObject = mcolUndoObjects(mcolUndoObjects.Count) mUndoObject.UndoChange mcolUndoObjects.Remove mcolUndoObjects.Count Set mUndoObject = Nothing Else ResetUndo End If End Sub Public Function UndoCount() As Long UndoCount = mcolUndoObjects.Count End Function" Classmodüle ile yapılan işlemi mesajla öğrenme "Bir tane classmodule ekleyin adı AppEventClass olsun. Option Explicit Public WithEvents App As Application Private Sub App_NewWorkbook(ByVal Wb As Workbook) MsgBox ""A new workbook is created!"" End Sub Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean) MsgBox ""A workbook is closed!"" End Sub Private Sub App_WorkbookBeforePrint(ByVal Wb As Workbook, Cancel As Boolean) MsgBox ""A workbook is printed!"" End Sub Private Sub App_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean) MsgBox ""A workbook is saved!"" End Sub Private Sub App_WorkbookOpen(ByVal Wb As Workbook) MsgBox ""A workbook is opened!"" End Sub " Classmodüle ile yapılan işlemi mesajla öğrenme2 "Bir tane classmodule ekleyin adı EventClass olsun. Option Explicit Public WithEvents App As Application Private Sub App_NewWorkbook(ByVal Wb As Excel.Workbook) MsgBox ""Application Event: New Workbook: "" & Wb.Name End Sub Private Sub App_SheetActivate(ByVal Sh As Object) MsgBox ""Application Event: SheetActivate: "" & Sh.Name End Sub Private Sub App_WorkbookOpen(ByVal Wb As Excel.Workbook) MsgBox ""Application Event: WorkbookOpen: "" & Wb.Name End Sub" Combobox a a verİlerİ alamiyorum.. "Private Sub UserForm_Activate() For i = 6 To 1000 If Sheets(""İNŞAAT TABLO"").Cells(i, 1) = """" Then GoTo 10: UserForm2.ComboBox1.AddItem (Sheets(""İNŞAAT TABLO"").Cells(i, 1)) 10: Next End Sub" Combobox a gİrİlen sayilari dİĞer combo boxta toplatmak "Toplama sonucunu alacağınızı Texbox3 kabul edersek aşağıdaki kodu Textbox3'in içine yazınız. Kod: Private Sub TextBox3_Enter() TextBox3 = CInt(TextBox1) + CInt(TextBox2) End Sub veya Kod: Private Sub TextBox3_Enter() TextBox3 = Val(TextBox1) + Val(TextBox2) End Sub ondalıklı sayılarıda toplaması için Kod: Private Sub TextBox3_Enter() TextBox3 = Ccur(TextBox1) + Ccur(TextBox2) End Sub " Combobox benzersiz kayıt "Private Sub UserForm_Initialize() For x = 2 To Cells(65536, 1).End(xlUp).Row If WorksheetFunction.CountIf(Range(""a2:a"" & x), Cells(x, 1)) = 1 Then ComboBox1.AddItem Cells(x, 1).Value End If Next End Sub " Combobox boş iken multipage görünür "Private Sub ComboBox1_Change() Call MyCheck End Sub Private Sub UserForm_Initialize() Call MyCheck End Sub Private Sub MyCheck() If ComboBox1 = Empty Then MultiPage1.Visible = False Else MultiPage1.Visible = True End If End Sub" Combobox boş iken multipage görünür-görünmez " MultiPage1.Visible = True If ComboBox1 = """" Then MultiPage1.Visible = False" Combobox change ÖzellİĞİnde arama yapmak "Private Sub CmbUrun_Change() Set no = Worksheets(""tümüs"").Range(""A1:CZ200"") Set ara = Cells.Find(What:=CmbUrun.Value, After:=ActiveCell, LookIn:=xlFormulas) If Not ara Is Nothing Then ilk = ara.Address ara.Select End If LblStok1 = ActiveCell.Offset(0, 1) End Sub" Combobox İÇerİĞİndekİ textİn seÇİlİ olmasi "Private Sub UserForm_Initialize() ComboBox1.ListRows = 5 ComboBox1.Text = ""PERSONEL SEÇİNİZ "" ComboBox1.AddItem ""DENEME 1"" ComboBox1.AddItem ""DENEME 2"" ComboBox1.AddItem ""DENEME 3"" ComboBox1.AddItem ""DENEME 4"" ComboBox1.AddItem ""DENEME 5"" With ComboBox1 .SelStart = 0 .SelLength = Len(ComboBox1) End With End Sub " Combobox ile yapılan karşılaştırma örneği "Private Sub ComboBox1_Change() On Error Resume Next ComboBox2.Value = Sheets(""Sayfa1"").Cells([Sayfa1!b1:b65536].Find(ComboBox1.Value).Row, 1) End Sub Private Sub ComboBox2_Change() On Error Resume Next ComboBox1.Value = Sheets(""Sayfa1"").Cells([Sayfa1!a1:a65536].Find(ComboBox2.Value).Row, 2) End Sub" Combobox kullanımı "1. Sayfa ismine sag tikla ""KODU GÖRÜNTÜLE"" seç 2. Yeni Form Seç 3. Form üzerine açilir kutu ekle 4. sayfaya geri dön 5. açilir kutuda bulunmasini istedigin verileri hücrelere yaz 6. hücreleri seç ve ekle ad tanimla Örnegin ISIMLER olsun 7. Kod görüntüleyiciye geri dön 8. Çizdigin açilir kutuyu seç 9. PROPERTIES den ROW SOURCE kutusuna ISIMLER yaz 10 comboboxa çift tikla CHANGE olayina range(""c1"").value = combobox1.value yazarsan seçtigin deger c1 hücresine aktarilir" Combobox mükerrer iptali "For b = 2 To Sheets(""veri"").Cells(65536, 5).End(xlUp).Row If WorksheetFunction.CountIf(Sheets(""veri"").Range(""e2:e"" & b), Sheets(""veri"").Cells(b, 5)) = 1 Then ComboBox1.AddItem Sheets(""veri"").Cells(b, 5).Value End If Next" Combobox otomatik açılması.Tıklamaya son "Option Explicit Private Declare Function SendMessage Lib ""user32"" Alias ""SendMessageA"" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Const CB_SHOWDRPDOWN = &H14F Private Sub Combo1_GotFocus() SendMessage Combo1.hwnd, CB_SHOWDRPDOWN, True, ByVal 0& End Sub" Combobox' ta bir değerin hazır seçili olarak gelmesi "B2"" hücresinin değeri ""1"" ise -------ComboBox2 de ""A"" seçili B2"" hücresinin değeri ""2"" ise -------ComboBox2 de ""B"" seçili B2"" hücresinin değeri ""3"" ise -------ComboBox2 de ""C"" seçili Private Sub UserForm_Initialize() ComboBox2.AddItem ""A"" ComboBox2.AddItem ""B"" ComboBox2.AddItem ""C"" Select Case Sheets(""Sheet ismi"").Range(""B2"") Case 1 ComboBox2 = ""A"" Case 2 ComboBox2 = ""B"" Case 3 ComboBox2 = ""C"" End Select End Sub 'diğer seçenek Private Sub UserForm_Initialize() 'form yüklendiğinde Me.ComboBox2.ListIndex = Range(""b2"")-1 End Sub Private Sub UserForm_Activate() 'form aktif olduğunda Me.ComboBox2.ListIndex = Range(""b2"") - 1 End Sub" Combobox taki isme göre commandbutton çalıştırma "Private Sub CommandButton3_Click() Select Case ComboBox1.ListIndex Case 0 CommandButton1_Click Case 1 CommandButton2_Click . . End Select End Sub" ComboBox vlookup "Private Sub ComboBox1_Change() TextBox1.Text = Application.VLookup( _ ComboBox1.Value, Range(""D8:E11""), 2, False) End Sub" Combobox1 de yılı combobox2 de ayı seçince ayın günlerini textboxlara sırala "combo1 de yıllar 'combo2 de aylar (1,2, 12) '31 tanede textbox oldugunu varsaydim. 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 " Comboboxa aldığınız veri seçilince büyük hafre dönüşsün "Private Sub ComboBox1_Change() ComboBox1 = büyük(ComboBox1) End Sub Function büyük(veri) Dim a As Integer Dim b As String For a = 1 To Len(veri) If Mid(veri, a, 1) = ""i"" Then b = ""İ"" ElseIf Mid(veri, a, 1) = ""ı"" Then b = ""I"" Else b = Mid(UCase(veri), a, 1) End If büyük = büyük & b Next End Function" Combobox'a atanacak sabit değerler "Private Sub UserForm_Initialize() With ComboBox1 .AddItem ""Kubilay"" .AddItem ""Aşkın"" .AddItem ""Karabulut"" End With End Sub" 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" Combobox'a aylari yazdirir "FORMA EKLEDİĞİNİZ COMBOBOXA AYLARI YAZDIRIR 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 " Comboboxa el ile veri girişi yasak 1 "Private Sub ComboBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) MsgBox ""EL İLE VERİ GİRİLEMEZ"" ComboBox1 = """" End Sub" Comboboxa el ile veri girişi yasak 2 "Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) MsgBox ""EL İLE VERİ GİRİLEMEZ"" End Sub " Comboboxa gÖre kayit "Userformun initialize olayına aşağıdaki kodu ilave edin. Bu kod en altta bulunan comboboxa sayfa isimlerini alacaktır. visual basic kodu: Private Sub UserForm_Initialize() For sayfa = 1 To Worksheets.Count ComboBox1.AddItem Sheets(sayfa).Name Next sayfa End Sub Sayfa isimlerini seçeceğiniz combobox ada aşağıdaki kodu yazın. Bu kod comboboxtan seçilen sayfaya gidecektir. Böylece tüm işlemler comboboxtan seçilen sayfa üzerinde yapılacaktır. visual basic kodu: Private Sub ComboBox1_Click() Sheets(ComboBox1.Value).Select End Sub " Comboboxa sütundan veri aldırma "Private Sub UserForm_Initialize() ComboBox1.RowSource = ""LISTE!A1:A31"" End Sub" Comboboxda verilerin yalnızca birer kere görünmesi "Private Sub UserForm_Initialize() Dim ComboListe As Variant, i As Long ComboListe = Benzersiz_Liste(Range(""A2:A500""), True) For i = 1 To UBound(ComboListe) ComboBox1.AddItem ComboListe(i) Next i End Sub Private Function Benzersiz_Liste(Aralik As Range, DuzListe As Boolean) As Variant Dim Hucre As Range, Benzersiz As New Collection, Say As Long, Dizi() As Variant Application.Volatile On Error Resume Next For Each Hucre In Aralik If Hucre.Formula <> """" Then Benzersiz.Add Hucre.Value, CStr(Hucre.Value) End If Next Hucre Benzersiz_Liste = """" If Benzersiz.Count > 0 Then ReDim Dizi(1 To Benzersiz.Count) For Say = 1 To Benzersiz.Count Dizi(Say) = Benzersiz(Say) Next Say Benzersiz_Liste = Dizi If Not DuzListe Then Benzersiz_Liste = Application.WorksheetFunction.Transpose(Benzersiz_Liste) End If End If On Error GoTo 0 End Function" Combobox'in İÇİne yazi yazilamasin. "Private Sub ComboBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) ComboBox1 = Empty End Sub" Comboboxlara İsİm lİstesİ oluŞturma "Private Sub UserForm_Initialize() With UserForm1.ComboBox1 .AddItem ""izinli"" .AddItem ""kaçak"" .AddItem ""mazeretsiz"" .AddItem ""geç"" End With End Sub " Comboboxlara sıra numarası yazdırma "Private Sub CommandButton1_Click() For i = 1 To 10 UserForm1.Controls(""ComboBox"" & i).Text = i Next i End Sub" Comboboxlardaki 2 tarih aralıklarını süz listboxa aktar "A ve G Sütun aralığının Combobox1'e girilen tarihe göre listelenmesi Private Sub CommandButton1_Click() Dim x As Date For i = 2 To Sheets(""EVRAK DEFTERİ"").Cells(65536, 1).End(xlUp).Row x = Sheets(""EVRAK DEFTERİ"").Cells(i, 3) If x >= CDate(ComboBox1.Value) And x <= CDate(ComboBox2.Value) Then listbox1.additem Sheets(""EVRAK DEFTERİ"").Cells(i, 1) & ""-"" & Sheets(""EVRAK DEFTERİ"").Cells(i, 2) & ""-"" & Sheets(""EVRAK DEFTERİ"").Cells(i, 3) & ""-"" & Sheets(""EVRAK DEFTERİ"").Cells(i, 4) & ""-"" & Sheets(""EVRAK DEFTERİ"").Cells(i, 5) End If Next i End Sub 'ListBox1'in Sütun ayarlarını; 'ColumnCount Özelliğini İstediğiniz sütun sayısını yazın. 'ColumnWidths Özelliğini Sütun Genişliği.70;80;55 gibi (Kafana Göre ayarlarsın) 'UserForm Çalışırken Sayfaya Müdahale etmek istersen. 'UserFormu tıklat ShowModal özelliğini False yap." Comboboxta 2. Sırayı seçersen k2 ye ActiveSheet.Cells(ComboBox1.ListIndex + 1, "k") = TextBox1.Value Combobox'ta çıkanlar görünmesin "Private Sub ComboBox1_Change() If ComboBox1.Value = """" Then Dim hucre As Range Me.ListBox1.RowSource = """" For Each hucre In Range(""h2:h"" & Range(""h65536"").End(xlUp).Row) If hucre.Value = """" Then Me.ListBox1.AddItem Range(""B"" & hucre.Row).Value End If Next End If End Sub" Comboboxta değer seçmek "Private Sub CommandButton1_Click() Dim i, b As Integer Dim indexsec For i = 0 To ComboBox1.ListCount On Error Resume Next combo = combo & ""Veri: "" & _ ComboBox1.List(i, 0) & "" - İndex'i:"" & i & vbCrLf Next i indexsec = InputBox(""Lütfen Aşağıdaki deger veya İndexlerden bir"" _ & ""deger seçin"" & combo, ""Combobox değer seç"") If indexsec = """" Then Exit Sub If IsNumeric(indexsec) = True Then If indexsec > ComboBox1.ListCount Then MsgBox ""Bu İndex Numarası listede yok"" Exit Sub End If ComboBox1.Value = ComboBox1.List(indexsec, 0) Else For b = 0 To ComboBox1.ListCount On Error Resume Next If ComboBox1.List(b, 0) = Trim(indexsec) Then MsgBox ""Yazdığınız Veri "" & b & "" Nolu Veridir - "" & ComboBox1.List(b, 0) ComboBox1.Value = ComboBox1.List(b, 0) Exit Sub End If Next b End If End Sub" Comboboxta saat formatı "Private Sub UserForm_Initialize() Sheets(""İŞYERİ SABİT BİLGİLER"").Activate TextBox12.Text = Range(""b18"").Text TextBox13.Text = Range(""e18"").Text TextBox14.Text = Range(""b19"").Text TextBox15.Text = Range(""e19"").Text End Sub Sheets(""İŞYERİ SABİT BİLGİLER"").Activate Range(""b18"").Select ActiveCell.Formula = TextBox12 Range(""e18"").Select ActiveCell.Formula = TextBox13 Range(""b19"").Select ActiveCell.Formula = TextBox14 Range(""e19"").Select ActiveCell.Formula = TextBox15 End Sub 'B18 Hücresinde 06:30 Yazılı 'E18 Hücresinde 15:30 Yazılı 'B19 Hücresinde 23:00 Yazılı Private Sub UserForm_Initialize() For i = 1 To 8 ComboBox1.AddItem Format(Cells(i, 1), ""hh:mm"") Next End Sub" Comboboxta sayfaları listeleme ve seçilen sayfaya gitme "Private Sub cb1_Change() Worksheets(cb1.Text).Select UserForm1.Hide Unload UserForm1 End Sub Private Sub UserForm_Initialize() Dim ws As Worksheet For Each ws In Worksheets Me.cb1.AddItem ws.Name Next End Sub" Comboboxta seçilen sayfaya gitme "Option Explicit Private Sub ComboBox1_Change() Worksheets(ComboBox1.Text).Select UserForm1.Hide Unload UserForm1 End Sub Private Sub UserForm_Initialize() Dim ws As Worksheet For Each ws In Worksheets Me:ComboBox1.AddItem ws.Name Next End Sub" Comboboxta seçilen veriyi ve satırı silme "Public satir As Integer Private Sub ComboBox1_Change() satir = ComboBox1.ListIndex + 1 End Sub Private Sub CommandButton1_Click() Cells(satir, 1).EntireRow.Delete End Sub" Comboboxta siralama "For a = 1 To [b65536].End(3).Row If WorksheetFunction.CountIf(Range(""a1:a"" & a), Cells(a, ""b"")) > 1 Then GoTo 10 c = c + 1 ComboBox2.AddItem Cells(a, ""b"") deg2 = ComboBox2.List(c - 1, 0) If IsNumeric(ComboBox2.List(c - 1, 0)) = True Then deg2 = ComboBox2.List(c - 1, 0) * 1 For b = 0 To c - 2 deg1 = ComboBox2.List(b, 0) If IsNumeric(ComboBox2.List(b, 0)) = True Then deg1 = ComboBox2.List(b, 0) * 1 If deg1 > deg2 Then deg = ComboBox2.List(c - 1, 0) ComboBox2.List(c - 1, 0) = ComboBox2.List(b, 0) ComboBox2.List(b, 0) = deg End If Next" Comboboxtakİ bİlgİlerİn eŞİt olmasi halİnde lİstboxlanmasi "Private Sub ListBox1_Click() On Error Resume Next cells(ListBox1.Column(5),""a"").Select End Sub " Comboboxtakİ sayfayi lİstboxta gÖster ListBox1.RowSource = combobox1.text & "!A1:R15" Comboboxtaki sıraya göre sayfadan seçme 'veriler A sütununda "Private Sub UserForm_Initialize() ComboBox1.RowSource = ""Sayfa2!A1:A20"" End Sub Private Sub ComboBox1_Change() sat = ComboBox1.ListIndex + 1 Cells(sat, ""a"").Select End Sub" Comboboxtaki veriyi mesaj olarak versin mesaj = MsgBox(ComboBox1.Value & " degerini girdiniz !", ,"Başlık") Comboboxtan sayfaya aktarım "Combobox ile seçince aktarsın diyorsanız Private Sub ComboBox1_Change() Worksheets(""sayfa1"").Range(""a1"") = ComboBox1.Value End Sub" Comboboxtan textboxlara veri aktarma "Private Sub ComboBox1_Click() TextBox1 = ComboBox1.Column(0) TextBox2 = ComboBox1.Column(1) TextBox3 = ComboBox1.Column(2) End Sub Private Sub UserForm_Activate() With UserForm1.ComboBox1 .AddItem ""masa"" .AddItem ""sıra"" .AddItem ""sandalye"" End With End Sub" Comboxta liste tanımlama "Private Sub UserForm_Initialize() With ComboBox1 .AddItem ""pir"" .AddItem ""Mahmut"" .AddItem ""Bayram"" End With End Sub" Commadbuton oluşturma makrosu "Sub SchaltflächeInTabellenEinfügen() Dim Tabelle As Worksheet For Each Tabelle In ActiveWorkbook.Worksheets Tabelle.Activate Tabelle.Buttons.Add(96, 15, 93, 24).Select Selection.Name = ""Datum"" Selection.Characters.Text = ""Datum"" Selection.OnAction = ""Datum2"" Range(""A1"").Select Next Tabelle End Sub" Commandbar ekleme "Sub command_add() Dim cmdB As CommandBar Set cmdB = CommandBars.Add(""MyToolbar"", temporary:=True) With cmdB .Left = 50 .Top = 100 .Visible = True End With End Sub" Commandbarların tümünün adlarını ve türkçe karşılıkları "Dim x As Integer For x = 1 To 127 Cells(x, 1) = Application.CommandBars(x).Name Cells(x, 2) = Application.CommandBars(x).NameLocal Next x" Commandbuton a şifre ekleme "Private Sub CommandButton1_Click() sifre = InputBox(""Kodların çalışması için şifre gerekiyor"", _ ""Yetkili Kişi"", ""Şifreyi buraya yazınız."") If sifre = ""excel"" Then 'şifre MsgBox ""Şifre doğrulandı"", vbInformation, _ ""Şifre Doğru"" 'buraya kodlarınızı yapıştırınız ' "" "" Else MsgBox ""Yanlış şifre girdiniz."" & Chr(13) & _ ""Kod çalışması iptal edildi"", vbCritical, ""Yanlış şifre"" Cancel = True End If End Sub" Commandbutton artık tıklatmıyor, kaçıyor "Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.Top = CommandButton1.Top + 20 End Sub" Commandbuttonun üzerine gelince renklenmesi "Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.BackColor = vbYellow End Sub Private Sub UserForm_Initialize() CommandButton1.Tag = CommandButton1.BackColor End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) CommandButton1.BackColor = CommandButton1.Tag End Sub" Commobox'a atanacak sabİt "Userformunuzun üzerindeki combobox'ınızda görünmesini istediğiniz sabit değerler için formunuzun code bölümüne; Kod: Private Sub UserForm_Initialize() With ComboBox1 .AddItem ""Kubilay"" .AddItem ""Aşkın"" .AddItem ""Karabulut"" End With End Sub " ÇAlışma kitabı açıp a kolonundan veri alma "Sub ac() sPath = ""C:\My Documents\"" On Error Resume Next For Each cell In Range(""A1"", Range(""a1"").End(xlDown)) Workbooks.Open Filename:=sPath & cell.Value & "".xls"" Next On Error GoTo 0 For Each cell In Range(""A1"", Range(""a1"").End(xlDown)) Workbook" ÇAlışma kitabı bilgisi özellikleri "Sub lstProprieteFichier() lg = 1 Worksheets.Add For Each LstPro In ActiveWorkbook.BuiltinDocumentProperties Cells(lg, 1).Value = LstPro.Name On Error Resume Next Cells(lg, 2).Value = ActiveWorkbook.BuiltinDocumentProperties.Item(LstPro.Name) lg = lg + 1 Next Columns(""A:A"").EntireColumn.AutoFit Range(""B10:B12"").NumberFormat = ""[$-F800]dddd, mmmm dd, yyyy"" End Sub" ÇAlışma kitabı her açılışta a1 1 artar "Private Sub Workbook_Open () Range(""A1"").Value = Range(""A1"").Value + 1 End Sub" ÇAlışma kitabı kaydetme "Option Explicit Dim FileDir As String Dim Filenumber As String Const FilePath = ""C:"" Private Sub cmdSave_Click() On Error Resume Next Filenumber = InputBox(""Oluşturulacak kitabın ismi?"", ""pir"") If Filenumber = """" Then MsgBox ""HATA"", vbOKOnly, ""pir"" Exit Sub End If FileDir = FilePath & Filenumber & "".xls"" SaveAs Filename:=FileDir On Error GoTo 0 End Sub " ÇAlışma kitabına şifreli giriş "Private Sub Workbook_Open() 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 MsgBox "" Das Kennwort ist ungültig,"" & Chr(13) & Chr(13) & ""der Vorgang wird abgebrochen !"" ThisWorkbook.Close End If MsgBox (""Registrierung erfolgreich"") Application.DisplayAlerts = True End If End Sub" ÇAlışma kitabına şifreli giriş "Private Sub Workbook_Open() Dim passwort As String passwort = InputBox(""Bitte geben Sie das Passwort"" & Chr(13) & Chr(13) & "" für das Einfügen von Kommentaren ein:"", ""Passwortabfrage für das Einfügen von Kommentaren"") If passwort <> ""36"" Then MsgBox "" Das Kennwort ist ungültig,"" & Chr(13) & Chr(13) & ""Sie dürfen keine Kommentare einfügen !"" Application.CommandBars(""Worksheet Menu Bar"").Controls(""Einfügen"").Controls(""Kommentar"").Enabled = False Application.CommandBars(""Cell"").Controls(""Kommentar einfügen"").Enabled = False Exit Sub Else Application.CommandBars(""Worksheet Menu Bar"").Controls(""Einfügen"").Controls(""Kommentar"").Enabled = True Application.CommandBars(""Cell"").Controls(""Kommentar einfügen"").Enabled = True End If End Sub" ÇAlışma kitabındaki son kullanılmış hücre 1 ActiveCell.SpecialCells(xlLastCell).Select ÇAlışma kitabındaki son kullanılmış hücre 2 "Son kaldığınız hücreyi ""Static"" bir değişkene atayabilirsiniz. Static sonhucre as Range Sub Kontrol() set sonhucre = ""kontrol edilen hücre"" . End Sub 'geri döndüğünüzde sonhucre.select 'yazdığınızda bu hücre seçilecektir. " ÇAlışma kitabını diskete yedekler "Sub SaveWorkbookBackupToFloppyA() Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean If TypeName(ActiveWorkbook) = ""Nothing"" Then Exit Sub Set awb = ActiveWorkbook If awb.Path = """" Then Application.Dialogs(xlDialogSaveAs).Show Else BackupFileName = awb.Name OK = False On Error GoTo NotAbleToSave If Dir(""A:\"" & BackupFileName) <> """" Then Kill ""A:\"" & BackupFileName End If With awb Application.StatusBar = ""Saving this workbook "" .Save Application.StatusBar = ""Saving this workbook backup "" .SaveCopyAs ""A:\"" & BackupFileName OK = True End With End If NotAbleToSave: Set awb = Nothing Application.StatusBar = False If Not OK Then MsgBox ""Dosya Yedeklenemedi!"", vbExclamation, ThisWorkbook.Name End If End Sub" ÇAlışma kitabını günün tarihi ile kaydeder - varsa farklı kaydeder "Sub gününtarihi() Dim sFileName As String sFileName = Format(Now, ""dd_mm_yyyy"") + "".xls"" ActiveWorkbook.SaveAs sFileName End Sub " ÇAlışma kitabını hardiskinizin "c:\" bölümüne istediğiniz adla farklı kaydetmek "Sub Kayıtİsmi() ActiveWorkbook.SaveAs Filename:=""C:\Mahmut.xls"" End Sub " ÇAlışma kitabını kaydet "Sub kayıt() ActiveWorkbook.Save End Sub " ÇAlışma kitabını paylaştır penceresi "Sub Dialog_27() Application.Dialogs(xlDialogFileSharing).Show End Sub" ÇAlışma kitabını tam ekran yapıp küçültme "Sub InTheMiddle() Dim dWidth As Double, dHeight As Double With Application .WindowState = xlMaximized dWidth = .Width dHeight = .Height .WindowState = xlNormal .Top = dHeight / 4 .Height = dHeight / 2 .Left = dWidth / 4 .Width = dWidth / 2 End With End Sub" ÇAlışma kitabını uyarısız kapatma "Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.DisplayAlerts = False ActiveWorkbook.Save End Sub" Çalışma kitabının tümünü yazdırma "Sub PrintAll() ThisWorkbook.PrintOut End Sub" Çalışma kitabının yedeğini alıp kaydeder (bulunulan dizine)--- başına yedek yazar "Sub SaveNow() SaveWithBackup ThisWorkbook.Save End Sub Sub SaveWithBackup() On Error Resume Next Dim Proceed As Long Proceed = MsgBox(""Yedekleyip kaydetmek istiyor musunuz?"" & vbNewLine & _ ""Selecting No will save without Backup"", vbYesNo) If Proceed = vbYes Then Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.FullName, CreateBackup:=True Application.DisplayAlerts = True End If End Sub" ÇAlışma sayfanızda belli aralıktaki hücreler seçilemez "Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Not Application.Intersect(Target, Range(""A1:A100"")) Is Nothing Then Cells(ActiveCell.Row, 2).Select MsgBox ""Bu aralıktaki hücreler seçilemez!"" End If End Sub" ÇAlışma sayfanızdaki boş satırları siler "Sub BosSatirlariSil() Dim LastRow As Long, r As Long LastRow = ActiveSheet.UsedRange.Rows.Count LastRow = LastRow + ActiveSheet.UsedRange.Row - 1 Application.ScreenUpdating = False For r = LastRow To 1 Step -1 If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete Next r End Sub" ÇAlışma sayfanızı korur, otomatik süzler çalışır "Sub sayfayıkoru() ActiveSheet.Protect userinterfaceonly:=True ActiveSheet.EnableAutoFilter = True End Sub" ÇAliŞma kİtabi Şİfreleme "Sub auto_open() Static sayac As Integer Do If sayac = 3 Then ThisWorkbook.Close False Else If InputBox(""Şifreyi girin"") = ""Buraya koymak istediğiniz şifreyi yazacaksınız!"" Then GoTo devam Else sayac = sayac + 1 End If End If Loop devam: End Sub" ÇAliŞma kİtabimi ,sayfam İÇİnde yer alan bİr butonla kapamak "Sub kapat() ActiveWorkbook.Close End Sub" ÇAliŞma kİtabinda sheet1 İsİmlİ sayfa modulunun name ÖzellİĞİnİ mysh olarak deĞİŞtİrİr "Aşağıdaki kod, çalışma kitabında Sheet1 isimli sayfa modulunun Name özelliğini MySh olarak değiştirir. visual basic kodu: Sub Test() Dim MyMod As Object For Each MyMod In ThisWorkbook.VBProject.VBComponents If MyMod.Name = ""Sheet1"" Then MyMod.Name = ""MySh"" Next End Sub" ÇAliŞma kİtabinizin baŞliĞini İstedİĞİnİz Şekİlde deĞİŞtİrİn "Açıklama:Çalışma Kitabınızın Başlığını istediğiniz şekilde değiştirin Sub test() Application.Caption = ""pir"" ActiveWindow.Caption = ""excel.web.tr"" 'Incorrect MsgBox Application.Caption & "" "" & ActiveWindow.Caption 'Correct MsgBox Application.Caption End Sub" ÇAliŞma kİtabinizin satir ve sutun gİzleme "Sub gızle() For i = 1 To ActiveWorkbook.Sheets.Count Sheets(i).Select ActiveWindow.DisplayHeadings = False Next End Sub göstermesi için: Sub goster() For i = 1 To ActiveWorkbook.Sheets.Count Sheets(i).Select ActiveWindow.DisplayHeadings = true Next End Sub " ÇAliŞma sayfalarini ÇaliŞma kİtabi olarak kaydet "Sub SayfaKaydet() Dim sayfa As Worksheet For Each sayfa In Worksheets sayfa.Copy ActiveWorkbook.SaveAs ""C:\Documents and Settings\pir\Desktop\"" & sayfa.Name & "".xls"" ActiveWorkbook.Close False Next sayfa End Sub" ÇAliŞma sayfalarinizin İsİmlerİ de& "Module bölümüne; Global WCnt Global Sh(1 To 100) As Worksheet Global ShNames(1 To 100) As String 'workbooka; 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" ÇAliŞma sayfanizdakİ boŞ satirlari sİler "Çalışma Sayfanızdaki Boş Satırları Siler Sub BosSatirlariSil() Dim LastRow As Long, r As Long LastRow = ActiveSheet.UsedRange.Rows.Count LastRow = LastRow + ActiveSheet.UsedRange.Row - 1 Application.ScreenUpdating = False For r = LastRow To 1 Step -1 If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete Next r End Sub " ÇAliŞma sayfanizdakİ ÇaliŞma alaninizi belİrleyen ve İptal eden macrolar "Açıklama: Çalışma sayfanızdaki çalışma alanınızı belirleyen ve iptal eden macrolar. Kod: Sub LimiteDefilement() ActiveSheet.ScrollArea = ""A1:A10"" End Sub Sub RetablitDefilement() ActiveSheet.ScrollArea = """" End Sub " ÇAliŞma sayfanizdakİ hÜcrenİn deĞerlerİne gÖre hÜcreler renklerle dolar "Açıklama: Çalışma sayfanızdaki hücrenin değerlerine göre hücreler renklerle dolar Kod: Private Sub Worksheet_Change(ByVal Target As Range) Select Case Target Case "" "": Target.Interior.ColorIndex = 15 ' gri Case ""A"": Target.Interior.ColorIndex = 3 ' kırmızı Case ""B"": Target.Interior.ColorIndex = 3 Case ""A&B"": Target.Interior.ColorIndex = 3 Case ""-"": Target.Interior.ColorIndex = 4 ' yeşil Case Else: Target.Interior.ColorIndex = xlNone End Select End Sub " ÇAliŞma sayfanizi korur ancak otomatİk sÜzler ÇaliŞir "Açıklama: Çalışma Sayfanızı korur ancak otomatik süzler çalışır Kod: Sub sayfayıkoru() ActiveSheet.Protect userinterfaceonly:=True ActiveSheet.EnableAutoFilter = True End Sub " ÇAliŞma sayfasini korumaya alir "ÇALIŞMA SAYFASINI KORUMAYA ALIR Sub sayfayıkoru() ActiveSheet.Protect userinterfaceonly:=True ActiveSheet.EnableAutoFilter = True End Sub " ÇAliŞtiĞim sayfanin sadece ÇaliŞilan kisminin gÖrÜntÜlenmesİnİ nasil saĞlarim "Aşağıdaki makroyu bir butona bağlarsanız taramanıza gerek kalmadan gizleme yapabilirsiniz. Sub gizle() Columns(""K:IV"").Hidden = True Rows(""45:65536"").Hidden = True End Sub tekrar göstermek için ise Sub göster() Columns(""K:IV"").Hidden = False Rows(""45:65536"").Hidden = False End Sub " ÇIft fonksiyonlu commandbutton "Private Sub CommandButton1_Click() If CommandButton1.Caption = ""Çalıştır"" Then CommandButton1.Caption = ""Sorgu Gir"" CommandButton1.Font.Bold = True CommandButton1.Font.Size = 15 Else CommandButton1.Caption = ""Çalıştır"" CommandButton1.Font.Bold = False CommandButton1.Font.Size = 20 End If End Sub Private Sub UserForm_Initialize() CommandButton1.Caption = ""Sorgu Gir"" End Sub" ÇIft satırlı mesaj kutusu 1 MsgBox "Mesaj boxlarda satır başı yapamıyorum." & vbCrlf & "Bunun bir yolu olmalı !" & vbCrlf & "Acaba vbCrlf kullanırsam ne olur?", vbinformation ÇIft satırlı mesaj kutusu 2 "Yada Alt+Enter'in Ascii kodu olan chr(10) kullanılabilir. Sub A() MsgBox ""A"" & Chr(10) & ""B"" & Chr(10) & ""C"" & Chr(10) & ""D"" & Chr(10) End Sub" ÇIft satırlı mesaj kutusu 3 "Sub msg() MsgBox ""A"" & Chr(13) & ""B"" & Chr(13) & ""C"" & Chr(13) & ""D"" & Chr(13) End Sub" ÇIft tıklamayla aktif sayfa harici sayfaları gizleyip gösterme "Option Explicit Sub AusEin() Dim S As Integer For S = 2 To Worksheets.Count Worksheets(S).Visible = Not Worksheets(S).Visible Next End Sub" ÇIft tıklamayla aktif sayfaya koruma koyma "Private Sub Worksheet_Change(ByVal Target As Excel.Range) ActiveSheet.Protect ""abc"" End Sub" ÇIft tıklamayla hücreye saat ve tarihli açıklama ekleme "Private Sub Worksheet_Change(ByVal Target As Excel.Range) Target.NoteText ""Die Zelle wurde am "" & Format(Date, ""dd.mm.yy"") & "" um "" & Format(Now(), "" hh:mm:ss"") & "" durch "" & ActiveWorkbook.BuiltinDocumentProperties(7).Value & "" geändert."" End Sub" ÇIft tıklamayla sayfa3'e git "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) sayfa = Target.Cells.Value Sheets(""sayfa3"").Select End Sub" ÇIft tıklamayla tarih ve saat ekleme "Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) ActiveCell = Date & "", "" & Time End Sub" ÇIft tıklayarak açıklamaya tarih-saat eklemek "Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink) ' MsgBox ""destination: target.subaddress "" & Target.SubAddress ' MsgBox ""Source: Target.Range.Address "" & Target.Range.Address ' MsgBox ""Source: Target.Range.Value "" & Target.Range(1, 1).Value Range(Target.SubAddress) = Target.ActiveCell End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Cancel = True 'Get out of edit mode ActiveCell = Target.Text On Error Resume Next ActiveCell.AddComment On Error GoTo 0 ActiveCell.Comment.Visible = False ActiveCell.Comment.Text Text:=""Value from: "" & Target.Address(0, 0) _ & Chr(10) & Format(Now, ""ddmmmyyyy hh:mm:ss"") Cancel = True ' no further need to edit the cell End Sub" ÇIft_kayıtlari_arala "Sub çift_kayıtlari_arala() totalrows = ActiveSheet.UsedRange.Rows.Count For Row = totalrows To 2 Step -1 If Cells(Row, 1).Value <> Cells(Row - 1, 1).Value Then Rows(Row).Insert Next Row End Sub " ÇıKış makrosu "kullanici = Application.UserName saat = Format(Now, ""hh:mm:ss"") tarih = Format(Date, ""d mmmm yyyy dddd"") sor = MsgBox("" GÖRÜŞMEK ÜZERE "" & kullanici & Chr(10) & Chr(10) & _ ""WWW.XXX.COM / +90 312 111 11 11"" & Chr(10) & Chr(10) & _ ""Tarih : "" & tarih & Chr(10) & Chr(10) _ & ""Saat : "" & saat & Chr(10) & Chr(10) _ & ""XXX A.Ş. İyi Çalışmalar Diler."" & Chr(10) & Chr(10) & _ ""dosyanın kaydedilmesini istiyormusunuz?"", 4, """") If sor = vbYes Then ActiveWorkbook.Save ActiveWorkbook.Close Else Application.DisplayAlerts = False ActiveWorkbook.Close End If End Sub" ÇıKış yordamı "Private Sub Command1_Click() pir = MsgBox(""Çıkmak istediğinizden emin misiniz?"", vbQuestion + vbYesNo, ""Çıkış"") Select Case pir Case vbYes End End Select End Sub" ÇİFt kayit engelleme (makrolu ÇÖzÜm) "Aşağıdaki kodu sayfanın kod sayfasına kopyalayarak deneyin. visual basic kodu: Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Intersect(Target, [a:a]) Is Nothing Then Exit Sub say = WorksheetFunction.CountIf(Range(""a1:a"" & Target.Row - 1), Target) If say > 0 Then MsgBox ""BU KAYIT MEVCUTTUR"" Target.Select Target = """" End If End Sub" ÇİFt kayit engelleme. "Aşağıdaki kod sadece a sütunu için geçerli, buna birde e sütununu nasıl eklerim? Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, [a:a]) Is Nothing Or Target = 0 Then Exit Sub UserForm1.Show End Sub Kodu aşağıdaki gibi düzenleyin. visual basic kodu: Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 Or Target.Column = 5 Then say = WorksheetFunction.CountIf([m:m], Target) If say > 0 Then Exit Sub UserForm1.Show End If End Sub " Çift tıklama ile listboxtan silme "Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If ListBox1.ListIndex = -1 Then Exit Sub cevap = MsgBox(ListBox1.List(, 0) & "" nolu kaydı silmek istiyor musunuz?"", vbYesNo) If cevap = vbYes Then Range(Cells(ListBox1.List(, 0) + 1, 2), Cells(ListBox1.List(, 0) + 1, 6)).Delete shift:=xlUp [a65536].End(3).Delete shift:=xlUp Call UserForm_Activate End If End Sub" ÇİFt tikladiĞimda İstedİĞİm sayfaya gİtsİn "Hücreye Maus veya Tuşlarla Geldiğinide İstenilen sayfaya geçmesi için,bu kodları O sayfanın üzerinde sağ tuş ile Kod Görüntüle kısmına yazılacak.Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = ""$C$18"" Then Sheets(""Sayfa2"").Select End Sub " ÇİFt tikladiĞimda İstedİĞİm sayfaya gİtsİn. "Hücreye Maus veya Tuşlarla Geldiğinide İstenilen sayfaya geçmesi için,bu kodları O sayfanın üzerinde sağ tuş ile Kod Görüntüle kısmına yazılacak. Kod: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = ""$C$18"" Then Sheets(""Sayfa2"").Select End Sub " ÇöZünürlük bulma "Declare Function GetClipCursor Lib ""user32"" (lprc As RECT) As Long Type RECT gauche As Long haut As Long droit As Long bas As Long End Type Dim oGCC As RECT Sub dimEcran() GetClipCursor oGCC With oGCC MsgBox .droit & "" x "" & .bas End With End Sub" ÇöZünürlük bulma2 "Declare Function GetSystemMetrics32 Lib ""User32"" _ Alias ""GetSystemMetrics"" (ByVal nIndex As Long) As Long Sub DisplayMonitorInfo() Dim w As Long, h As Long w = GetSystemMetrics32(0) ' width in points h = GetSystemMetrics32(1) ' height in points MsgBox Format(w, ""#,##0"") & "" x "" & Format(h, ""#,##0""), _ vbInformation, ""Monitor Size (width x height)"" End Sub" ÇöZünürlük Öğrenme "Declare Function GetSystemMetrics Lib ""user32"" (ByVal nIndex As Long) As Long Sub Bild() MsgBox (""Çözünürlük Pixel Değerleri: "" & GetSystemMetrics(0) & "" x "" & GetSystemMetrics(1)) End Sub" D, e sütununda tek tıklamayla check atma "Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim iOffset As Integer On Error GoTo err_handler Application.EnableEvents = False If Not Application.Intersect(Target, Columns(""D:E"")) Is Nothing Then If Target.Column = 4 Then iOffset = 3 Else iOffset = 2 End If If IsEmpty(Target.Value) Then With Target .Font.Name = ""Wingdings"" .Value = Chr(252) End With Target.Offset(0, iOffset).Select Else Target.Value = """" Target.Offset(0, iOffset).Select End If End If err_handler: Application.EnableEvents = True End Sub" D2 hücresinde veri doğrulamalı açılır liste olsun açılır listenin otomatik genişlemesi daralması "Sayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Range) Zelle = Target.Address Select Case Zelle Case ""$D$2"" Range(""$D$2"").ColumnWidth = 52 'entspricht 369 Pixel Case Else Range(""$D$2"").ColumnWidth = 16.43 'entspricht 120 Pixel End Select End Sub" Daha Önce koruma yaptiĞim sayfanin koruma Şİfresİnİ nasil kirabİlİrİm " Excel içinde bir sayfaya şifre verdikten sonra bu şifreyi unuttuysanız aşağıdaki kodu uygulayıp bu sorunu çözebilirsiniz. Kod: 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" Dao ile 2 tarih arası "Dim dbs2 as Database Dim rst2 as Recordset Set dbs2 = OpenDatabase(datayolu) Set rst2 = dbs2.OpenRecordset(""Select * from cr Where tarih>=datevalue('"" & trh1.Value & ""') and tarih<=datevalue('"" & trh2.Value & ""')-1 and crkod='"" & Text1 & ""'order by tarih"") If rst2.RecordCount > 0 Then rst2.MoveLast rst2.MoveFirst i = 1 fg5.Rows = rst2.RecordCount + 1 While Not rst2.EOF If Not IsNull(rst2(""tutar"")) Then fg5.TextMatrix(i, 2) = rst2(""tutar"") i = i + 1 rst2.MoveNext Wend End If " Data form açma "Sub data_form() ActiveWorkbook.Names.Add Name:=""Database"", RefersTo:=""="" & Worksheets(1).Name & ""!"" & Range(""A15:F35"").Address Range(""A1:F11"").Select Worksheets(1).ShowDataForm End Sub" Dataform açma "Private Sub Workbook_Open() Sheets(""Sayfa1"").Select ActiveSheet.ShowDataForm End Sub" Decimal kontrol "Public Function DecControl(KeyAscii As Integer, Text As TextBox, ByVal NOOFDEC As Integer) As Integer If KeyAscii = 8 Then DecControl = KeyAscii Exit Function End If If NOOFDEC = 0 Then If InStr(1, ""0123456789-"", Chr(KeyAscii)) = 0 Then DecControl = 0 Exit Function Else DecControl = KeyAscii Exit Function End If Else If InStr(1, ""0123456789.-"", Chr(KeyAscii)) = 0 Then DecControl = 0 Exit Function End If End If If Len(Text) - Text.SelStart > NOOFDEC And Chr(KeyAscii) = ""."" Then DecControl = 0 Exit Function End If If KeyAscii <> 8 Then If InStr(1, Text, ""."") <> 0 And Chr(KeyAscii) = ""."" Then DecControl = 0 Exit Function End If Dim pos As Integer Dim RET As Integer pos = InStr(1, Text.Text, ""."") If pos = 0 Then If InStr(1, ""0123456789.-"", Chr(KeyAscii)) = 0 Then RET = 0 Else RET = KeyAscii End If Else 'IF AFTER DECIMAL If Text.SelStart + 1 > pos Then a = Len(Text.Text) - InStr(1, Text, ""."") If a >= NOOFDEC Then RET = 0 Else RET = KeyAscii End If Else RET = KeyAscii End If End If Else RET = KeyAscii End If DecControl = RET End Function" Değere bağlı olarak diğer sütunu değiştir. "Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim i As Long For i = 1 To WorksheetFunction.CountA(Range(""H:H"")) If Cells(i, 8).Value = ""A"" And Left(Cells(i, 9), 3) <> ""(-)"" Then Cells(i, 9) = ""(-)"" & Cells(i, 9).Value Cells(i, 9).HorizontalAlignment = xlRight End If Next i End Sub" Değerlerin aynen kopyalama "Sub aynideger() Dim Cel1 As Range, Cel2 As Range Set Cel1 = Range(""A1:B1"") Set Cel2 = Workbooks(""Kitap1"").Worksheets(""Sayfa1"").Range(""D5"") Cel1.Copy Cel2 End Sub" DeĞİŞen hÜcrelerİ gÖster "aşağıda bu çalışmayı gerçekleştirecek kodu ekliyorum. Bu kodu bir module içerisine değil Alt+F11 ile VBAyı açın. Project Explorerden ""This Workbook"" üzerine çift tıklayın ve kodu bu açılan sayfaya kopyalayın. Normal module sayfasına eklerseniz çalışmaz. Deneme sonrası sonucu bildirirseniz memnun olurum. Sonuca farklı şekilde giden arkadaşlar kodlarını paylaşırsa sevinirim. Kod: Private Sub yaz(deger, adres, yenideger) If deger = 0 Then yuzde = 1 ElseIf IsNumeric(deger) And IsNumeric(yenideger) Then yuzde = (deger - yenideger) / deger yuzde = yuzde * 100 * (-1) yuzde = FormatNumber(yuzde, 2) End If If deger < 1 Then deger = 0 Range(adres).ClearComments Range(adres).AddComment "" "" Range(adres).Comment.Visible = False Range(adres).Comment.Text Text:=""Eski Değer: "" & deger & Chr(10) & ""Değişim: %"" & yuzde End Sub Public Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) adres = Range(""IV1"").Value deger = Range(""IV2"").Value If adres > 0 Then yenideger = Range(adres).Value If deger <> yenideger Then Call yaz(deger, adres, yenideger) End If End If Range(""IV1"").Value = ActiveCell.Address Range(""IV2"").Value = ActiveCell.Value End Sub" Değişen hücreleri gösterme "Project Explorerden ""This Workbook"" üzerine çift tıklayın ve kodu bu açılan sayfaya kopyalayın. 'Normal module sayfasına eklerseniz çalışmaz. Private Sub yaz(deger, adres, yenideger) If deger = 0 Then yuzde = 1 ElseIf IsNumeric(deger) And IsNumeric(yenideger) Then yuzde = (deger - yenideger) / deger yuzde = yuzde * 100 * (-1) yuzde = FormatNumber(yuzde, 2) End If If deger < 1 Then deger = 0 Range(adres).ClearComments Range(adres).AddComment "" "" Range(adres).Comment.Visible = False Range(adres).Comment.Text Text:=""Eski Değer: "" & deger & Chr(10) & ""Değişim: %"" & yuzde End Sub Public Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) adres = Range(""IV1"").Value deger = Range(""IV2"").Value If adres > 0 Then yenideger = Range(adres).Value If deger <> yenideger Then Call yaz(deger, adres, yenideger) End If End If Range(""IV1"").Value = ActiveCell.Address Range(""IV2"").Value = ActiveCell.Value End Sub " Değişik kopyalama "Sub kopyala() Dim pir1 As Range, pir2 As Range Set pir1 = Range(""A1:B2"") Set pir2 = Range(""F1:G2"") pir2.Value = pir1.Value pir2.NumberFormat = pir1.NumberFormat End Sub" Değişikliklerin a kolonuna saat & tarihli kaydedilmesi "Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Me.Cells(Target.Row, 1) = Now '1 steht für Spalte A, für Spalte H waere es die 8 Application.EnableEvents = True End Sub" Değişken ve döngü ile 1 den 10 a kadar sayıların toplamı "Sub Accumulate() Dim n As Integer Dim t As Integer For n = 1 To 10 t = t + n Next n MsgBox "" The total is "" & t End Sub" Değişkene toplam atamak "Sub a() b = WorksheetFunction.Sum(Sheets(""sayfa1"").Range(""A1:A50"")) End Sub 'bu kodda b değişkenine A1:A50 arasındaki değerlerin toplamı atanmıştır." Değiştir penceresi "Sub Dialog_34() Application.Dialogs(xlDialogFormulaReplace).Show End Sub" Del tuşu 2. Sütunda çalışmasın "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 2 Then Application.OnKey ""{Del}"", """" Else Application.OnKey ""{Del}"" End If End Sub" Demo program yapma "Sub demo() Dim saat1 As Date Dim saat2 As Date saat1 = ""15/10/2005"" saat2 = Date If saat2 > saat1 Then MsgBox (""Süreniz dolmuş üzgünüm."") ActiveWorkbook.Close End If MsgBox (""Kullanım için "" & saat1 - saat2 & "" gününüz kalmıştır."") If sure1 = sure2 Then MsgBox ""Bu gün SON GÜN"" End If End Sub" Ders ortalamalarını hesaplamak "1 ADET COMBO '1 ADET COMMAND '4 ADET TEXT '5 ADET LABEL Private Sub Command1_Click() Label5.Caption = (Val(Text1) + Val(Text2) + Val(Text3) + Val(Text4)) / 4 End Sub Private Sub UserForm_Activate() Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" Combo1.AddItem ""DERSİNİZİN İSMİ"" End Sub Private Sub Text1_Change() If Val(Text1) > 100 Or 0 > Val(Text1) Then MsgBox ""GİRDİĞİNİZ SAYI 0 İLE 100 ARASI OLMALIDIR"" Text1.Text = """" End If End Sub Private Sub Text2_Change() If Val(Text2) > 100 Or Val(Text2) < 0 Then MsgBox ""GİRDİĞİNİZ SAYI 0 İLE 100 ARASI OLMALIDIR"" Text2.Text = """" End If End Sub Private Sub Text3_Change() If Val(Text3) > 100 Or 0 > Val(Text3) Then MsgBox ""GİRDİĞİNİZ SAYI 0 İLE 100 ARASI OLMALIDIR"" Text3.Text = """" End If End Sub Private Sub Text4_Change() If Val(Text4) > 100 Or 0 > Val(Text4) Then MsgBox ""GİRDİĞİNİZ SAYI 0 İLE 100 ARASI OLMALIDIR"" Text4.Text = """" End If End Sub" Deşiklik yapılan hücredeki eski değeri görme "Private Sub yaz(deger, adres, yenideger) If deger = 0 Then yuzde = 1 ElseIf IsNumeric(deger) And IsNumeric(yenideger) Then yuzde = (deger - yenideger) / deger yuzde = yuzde * 100 * (-1) yuzde = FormatNumber(yuzde, 2) End If If deger < 1 Then deger = 0 Range(adres).ClearComments Range(adres).AddComment "" "" Range(adres).Comment.Visible = False Range(adres).Comment.Text Text:=""Eski Değer: "" & deger & Chr(10) & ""Değişim: %"" & yuzde End Sub Public Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) adres = Range(""IV1"").Value deger = Range(""IV2"").Value If adres > 0 Then yenideger = Range(adres).Value If deger <> yenideger Then Call yaz(deger, adres, yenideger) End If End If Range(""IV1"").Value = ActiveCell.Address Range(""IV2"").Value = ActiveCell.Value End Sub" Detaylı karşılama, kapama "Sub Auto_Open() Application.StatusBar = "" LİDER GROUP ©2005 / - MALİYET ANALİZ LİSTELERİ -"" Sheets(""ANA SAYFA"").Select Range(""A1"").Select Dim kullanici As String Dim tarih As String Dim saat As String tarih = Now() kullanici = Application.UserName saat = Format(tarih, ""hh:mm:ss"") tarih = Format(tarih, ""d mmmm yyyy dddd"") MsgBox "" MERHABA "" & kullanici & "", HOŞ GELDİNİZ!"" & Chr(13) & Chr(13) & _ ""Tarih : "" & tarih & Chr(13) & Chr(13) _ & ""Saat : "" & saat & Chr(13) & Chr(13) _ & ""Kalite Yönetim Müdürlüğü İyi Çalışmalar Diler."" & Chr(13) & Chr(13), vbApplicationModal, "" LİDER GROUP 2005® "" End Sub Sub Auto_Close() Dim kullanici As String Dim tarih As String Dim saat As String tarih = Now() kullanici = Application.UserName saat = Format(tarih, ""hh:mm:ss"") tarih = Format(tarih, ""d mmmm yyyy dddd"") MsgBox "" GÖRÜŞMEK ÜZERE "" & kullanici & Chr(13) & Chr(13) & _ ""Tarih : "" & tarih & Chr(13) & Chr(13) _ & ""Saat : "" & saat & Chr(13) & Chr(13) _ & ""Kalite Yönetim Müdürlüğü İyi Çalışmalar Diler."" & Chr(13) & Chr(13), vbApplicationModal, "" LİDER GROUP 2005® "" ActiveWorkbook.Save Application.DisplayAlerts = False ActiveWorkbook.Close False Application.Quit End Sub" Dİger kİtaptakİ makroyu ÇaliŞtirmak "üzerindeki bir makinedeki bir excel kitabının içindeki makroyu kendi makinenizden çalıştırmak Kod: Application.Run ""\\makineadi\klasoradi\kitapadi.xls!makroadi"" eğer kitaplar aynı makine üzerinde ise Kod: Application.Run ""c:\klasoradi\kitapadi.xls!makroadi"" " Diğer çalışma kitabındaki modülden makro çalıştırma "Sub Essai() Run (""Kitap1.xls!Module1.MAkro1"") End Sub" Diğer formdaki command butonu çalıştırmak "Form2 VBA Public Sub Buton1_Click() Msgbox ""Merhaba"" End Sub 'Form1 VBA 'da Private Sub Buton1_Click() userform2.buton1_click End Sub " Diğer kitaptaki makroyu çalıştırma Application.Run "kitap2.xls!makro1" Dikdörtgen silme "Sub dortgen_sil() For Each Rectangle In ActiveSheet.Shapes Rectangle.Delete Next End Sub" Disket etiketlendirme "Declare Function SetVolumeLabel Lib ""kernel32"" Alias ""SetVolumeLabelA"" _ (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long Sub NommeDSK() retval = SetVolumeLabel(""a:\"", ""MaDisquette"") 'pour supprimer le label 'retval = SetVolumeLabel(""a:\"", vbNullString) End Sub" Disket formatlama "Private Declare Function SHFormatDrive Lib ""shell32"" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long Private Declare Function FindWindow Lib ""user32"" Alias ""FindWindowA"" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private hWnd As Long Const SHFMT_DRV_A = 0 Const SHFMT_DRV_B = 1 Const SHFMT_ID_DEFAULT = &HFFFF Const SHFMT_OPT_QUICKFORMAT = 0 Const SHFMT_OPT_FULLFORMAT = 1 Const SHFMT_OPT_SYSONLY = 2 Const SHFMT_ERROR = -1 Const SHFMT_CANCEL = -2 Const SHFMT_NOFORMAT = -3 Private Sub format() Dim Res As Long hWnd = FindWindow(vbNullString, Me.Caption) Res = SHFormatDrive(hWnd, SHFMT_DRV_A, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT) Select Case Res Case SHFMT_ERROR MsgBox ""Hata."", vbCritical Case SHFMT_CANCEL MsgBox ""İptal edildi."", vbInformation Case SHFMT_NOFORMAT MsgBox ""Formatlı değil."", vbInformation Case Else MsgBox ""Formatlama bitti."" End Select End Sub Private Sub CommandButton1_Click() format End Sub" Diskete yedekleme "Sub SaveWorkbookBackupToFloppyA() Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean If TypeName(ActiveWorkbook) = ""Nothing"" Then Exit Sub Set awb = ActiveWorkbook If awb.path = """" Then Application.Dialogs(xlDialogSaveAs).Show Else BackupFileName = awb.Name OK = False On Error GoTo NotAbleToSave If Dir(""A:"" & BackupFileName) <> """" Then Kill ""A:"" & BackupFileName End If With awb Application.StatusBar = ""Saving this workbook "" .Save Application.StatusBar = ""Saving this workbook backup "" .SaveCopyAs ""A:"" & BackupFileName OK = True End With End If NotAbleToSave: Set awb = Nothing Application.StatusBar = False If Not OK Then MsgBox ""Backup Copy Not Saved!"", vbExclamation, ThisWorkbook.Name End If End Sub" Disketten .Bat dosyası açma "Option Explicit '//The Shell function runs other programs asynchronously so what '//What you basically have to do is Open the existing Process '//for the running Application and, LOOP & WAIT for the processes return state '//ie when the specified process is in the signaled state '//or a timeout occurs. Private Declare Function OpenProcess Lib ""kernel32"" ( _ ByVal dwDesiredAccess As Long, _ ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) 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 GetExitCodeProcess Lib ""kernel32"" ( _ ByVal hProcess As Long, _ lpExitCode As Long) As Long '&HFFFF Private Const SYNCHRONIZE = &H100000 '// Note:SYNCHRONIZE Windows NT/2000 Private Const INFINITE = &HFFFF 'OR -1& '// INFINITE, the function’s time-out interval never elapses. Private Const STILL_ACTIVE = &H103 Public Function ShellAndWait(ByVal BatFile As String) ' ' Shells a new process and waits for it to complete. ' Calling application is totally non-responsive while ' new process executes. ' Dim PID As Long Dim hProcess As Long Dim nRet As Long '// Unlike other Functions Shell generates an error '// instead of returning a 0 so handling the error '// = Application NOT started. On Error Resume Next PID = Shell(BatFile, vbMinimizedNoFocus) If Err Then '// handle the error here and End MsgBox ""Could NOT exercute:= "" & BatFile End End If On Error GoTo 0 '// SYNCHRONIZE For Windows NT/2000: '// Enables using the process handle in any of the wait '// functions to wait for the process to terminate. '// obviously with NT you need access rights. hProcess = OpenProcess(SYNCHRONIZE, False, PID) '// Just set the dwMilliseconds to INFINITE to initiate a Loop nRet = WaitForSingleObject(hProcess, INFINITE) Do GetExitCodeProcess hProcess, nRet DoEvents Loop While nRet = STILL_ACTIVE CloseHandle hProcess End Function Sub OpenFileAndWait() Dim sApp As String '// Define the Application FullPath here sApp = ""C:\A\Batch.bat"" 'sApp = ""C:\windows\system32\calc.exe"" '// Lets DoIt ShellAndWait sApp '// Tell me if Successful MsgBox ""Finished running task!"" End Sub" Diyagram çizme "Sub polygon() 'zeichnet Polygon Application.ScreenUpdating = False anzeck = InputBox(""Wieviele Ecken ?"") If anzeck = Empty Or Not IsNumeric(anzeck) Or anzeck < 3 Then Exit Sub seite = InputBox(""Seitenlänge ?"") If seite = Empty Or Not IsNumeric(seite) Then Exit Sub a = 200 ActiveSheet.Drawings.Add(a, a, a + seite, a, False) _ .Select winkel = 180 - 360 / anzeck gegenwinkel = 180 - (winkel + 90) winkel1 = 3.14159265358979 * winkel / 180 gegenwinkel1 = 3.14159265358979 * gegenwinkel / 180 x = a + seite y = a k = 1 For i = 1 To anzeck - 1 x = x - k * seite * Sin(gegenwinkel1) y = y + k * seite * Cos(gegenwinkel1) Selection.AddVertex x, y k = k * (-1) gegenwinkel1 = gegenwinkel1 - winkel1 Next Application.ScreenUpdating = True End Sub" Dizi yöntemi sayfa seçme "Sub sec() Worksheets(Array(1, 3, 5)).Select End Sub" Dizindeki en son klasör ya da dosya ismini verir "Sub Dizindeki_Son_İsim() Dim ds, a Set ds = CreateObject(""Scripting.FileSystemObject"") a = ds.GetBaseName(""C:\SXSİ\Deneme\Ben.txt"") MsgBox a End Sub" Dizindeki sürücü harfini verir "Sub Sürücü_İsmi() Dim ds, a Set ds = CreateObject(""Scripting.FileSystemObject"") a = ds.GetDriveName(""C:\SXSİ\Deneme\Ben.txt"") MsgBox a End Sub" Doğum gününü bulma "Dim d_tarih Do d_tarih = InputBox(""Doğum Tarihiniz Ör:01/04/1979"", ""Doğum Tarihinizi Yazın Lütfen"") Loop While Not IsDate(d_tarih) MsgBox (WeekdayName(Weekday(d_tarih, 0), False, 0) + "" "" + ""Günü Doğmuşsunuz."")" Dolar okutma "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 Dollars"" 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" Dolaylı makro "aktif sayfaya açılır kutu ekleyin. Referansını A sütununa verin. A sütunundakileri dolaylı olarak b14 te gösterir Sub yaz() ActiveSheet.Shapes(""Drop Down 1"").Select [b14] = Evaluate(""=INDIRECT(""""A"" & Selection.Value & """""""" & "")"") [b13].Select End Sub" Dolu alanlaı yazdırma "Sub doluyazdir() ActiveSheet.UsedRange.Select Selection.PrintOut End Sub" Dolu hücreleri seçer ve büyük harfe çevirir "Sub doluhucre_sec() Dim range As range Sheets(""Sayfa1"").Activate ActiveSheet.UsedRange.Select For Each range In Selection If range.HasFormula = False Then range.Value = UCase(range.Value) End If Next End Sub" Dolu hücreleri seçer ve küçük harfe çevirir "Sub doluhucre_sec() Dim range As range Sheets(""Sayfa1"").Activate ActiveSheet.UsedRange.Select For Each range In Selection If range.HasFormula = False Then range.Value = LCase(range.Value) End If Next End Sub" Dolu kayıt sayısı "Sub DoluKayitSayisi() Sayi = WorksheetFunction.CountA(Range(""A1:A9000"")) 'Eğer mesajla almak isterseniz şu koduda ekleyin MsgBox Sayi End Sub" Dolu olanları diğer sayfaya aktarır "Private Sub CommandButton1_Click() Dim MyRng As Range Dim NoA1 As Long Set sh1 = Sheets(""Sayfa1"") Set sh2 = Sheets(""Sayfa2"") NoA1 = sh1.Cells(65536, 1).End(xlUp).Row For Each MyRng In sh1.Range(""A1:A"" & NoA1) NoA2 = sh2.Cells(65536, 1).End(xlUp).Row + 1 If MyRng <> ""m.cinsi"" And MyRng <> """" Then sh2.Range(""A"" & NoA2) = MyRng sh2.Range(""B"" & NoA2) = MyRng.Offset(0, 1) sh2.Range(""C"" & NoA2) = MyRng.Offset(0, 2) sh2.Range(""D"" & NoA2) = MyRng.Offset(0, 3) End If Next End Sub" Dolu olanları 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" Dolu satır ve sütunu kesiştirerek seçme (mükemmel) "Sub SelAllData() Application.ScreenUpdating = False Dim myLastRow As Long Dim myLastColumn As Long Range(""A1"").Select On Error Resume Next myLastRow = Cells.Find(""*"", [A1], , , xlByRows, xlPrevious).Row myLastColumn = Cells.Find(""*"", [A1], , , xlByColumns, xlPrevious).Column myLastCell = Cells(myLastRow, myLastColumn).Address myRange = ""a1:"" & myLastCell Application.ScreenUpdating = True Range(myRange).Select End Sub" Dolu textbox sayısını mesajla bildir "Private Sub CommandButton1_Click() Dim say Dim ekle On Error Resume Next For say = 1 To UserForm1.Controls.Count If Mid(Controls(say).Name, 1, 7) = ""TextBox"" Then GoTo ileri Else GoTo gec End If ileri: If Controls(say).Text <> """" Then ekle = ekle + 1 End If gec: Next say MsgBox ekle End Sub" Dolu, yazılı alanların seçilmesi ve enson dolu hücrenin bulunması "Function LastCell(ws As Worksheet) As Range Dim LastRow&, LastCol% On Error Resume Next With ws LastRow& = .Cells.Find(What:=""*"", _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row LastCol% = .Cells.Find(What:=""*"", _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByColumns).Column End With Set LastCell = ws.Cells(LastRow&, LastCol%) End Function Sub RealLastCell() RLC = LastCell(ActiveSheet).Address(False, False) MsgBox (""The """"real"""" last cell is "" & vbCrLf & vbLf & RLC) End Sub Sub Used_Range() ActiveSheet.UsedRange.Select End Sub" Dosya açık mı değil mi bakar değilse açar "Function WorkbookOpen(WorkBookName As String) As Boolean WorkbookOpen = False On Error GoTo WorkBookNotOpen If Len(Application.Workbooks(WorkBookName).Name) > 0 Then WorkbookOpen = True Exit Function End If WorkBookNotOpen: End Function Sub AA() If Not WorkbookOpen(""C.xls"") Then Workbooks.Open ""C.xls"" End If End Sub" Dosya açıldığında tanımlama bilgisi "Sub auto_open() Sheets(""GİRİŞ"").Select Range(""a1"").Select MsgBox ""GİRİŞ Sayfasındaki gerekli bilgileri doldurun "" End Sub 'ThisWorkbook'a açıklama ekler(kitap açıldığında otomatik devreye girer. Private Sub Workbook_Open() Call MsgBox(""Programlayan : Mahmut BAYRAM"" & vbNewLine & vbNewLine & _ ""Sonuçları kontrol etmeyi unutmayın!"" & vbNewLine & vbNewLine & _ ""sayfaları kopyalayabilirsiniz. "", vbInformation, ""UYARI"") End Sub" Dosya açıldığında tanimlama bilgisi "Sub auto_open() Sheets(""GİRİŞ"").Select Range(""a1"").Select MsgBox ""GİRİŞ Sayfasındaki gerekli bilgileri doldurun "" End Sub 'ThisWorkbook'a açıklama ekler(kitap açıldığında otomatik devreye girer. Private Sub Workbook_Open() Call MsgBox(""Programlayan : pir."" & vbNewLine & vbNewLine & _ ""Sonuçları kontrol etmeyi unutmayın!"" & vbNewLine & vbNewLine & _ ""sayfaları kopyalayabilirsiniz. "", vbInformation, ""UYARI"") End Sub" Dosya açıp içerisine veri girme "Sub DateiAuswahl() Dim WB As Workbook Dim TB As Worksheet Dim i% Dim dName Dim dFilter$ dFilter = ""Excel-Dateien(*.xls), *.xls"" ChDrive ""c"" ChDir ""c:\"" dName = Application.GetOpenFilename(dFilter) If dName = False Then Exit Sub Set WB = Workbooks.Open(dName) Set TB = WB.Worksheets(1) For i = 1 To 20 TB.Cells(i, 5) = ""Spalte E - Zeile "" & i Next i End Sub" Dosya adı, yolu ve çalışma sayfası adını fornsiyonlarla yazdır "UYARI: Aşağıdaki işlevlerin sonuç verebilmesi için çalışma kitabının kaydedilmiş olması gerekmektedir. Çalışma kitabının tam yolunu, adını ve çalışma sayfası adını birlikte yazdırmak için; =HÜCRE(""DosyaAdı"") Çalışma kitabının yolunu yazdırmak için; =SOLDAN(HÜCRE(""DosyaAdı"");BUL(""["";HÜCRE(""DosyaAdı"");1)-1) Çalışma kitabı adını dosya uzantısı ile birlikte yazdırmak için; =PARÇAAL(HÜCRE(""DosyaAdı"");MBUL(""["";HÜCRE(""DosyaAdı"");1)+1;MBUL(""]"";HÜCRE(""DosyaAdı"");1)-MBUL(""["";HÜCRE(""DosyaAdı""))-1) Çalışma kitabı adını dosya uzantısı olmaksızın yazdırmak için; =PARÇAAL(HÜCRE(""DosyaAdı"");MBUL(""["";HÜCRE(""DosyaAdı"");1)+1;MBUL(""]"";HÜCRE(""DosyaAdı"");1)-MBUL(""["";HÜCRE(""DosyaAdı""))-5) Çalışma sayfası adını yazdırmak için; =SAĞDAN(HÜCRE(""DosyaAdı"");UZUNLUK(HÜCRE(""DosyaAdı""))-MBUL(""]"";HÜCRE(""DosyaAdı"");1))" Dosya al "Tek başına bir işe yaramayan bir kod. Adı geçen dosya ismi hafızada tutuluyor ve işlemler bu dosya üzerinden yapılıyor. Örnekler ikinci bölümde 'verilecektir. Sub Dosya_Al() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") Set f = ds.GetFile(""D:\ExcelÖrnekleri\Soru.xls"") MsgBox f End Sub 'Bu kodda ise dosya değil,sadece ismi alınıyor. Sub Dosya_İsmi_Al() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") f = ds.GetFileName(""D:\ExcelÖrnekleri\Soru.xls"") 'Sadece Dosya ismi alındığı için SET tabiri kullanılmaz MsgBox f End Sub" Dosya arama "Sub ProcessBooks() Dim wkbk As Workbook Dim i As Long With Application.FileSearch .NewSearch .LookIn = ""C:\My Documents"" .SearchSubFolders = False .FileName = ""*.xls"" .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then " Dosya arama (var mı, yok mu) "Sub dosya_ara() Dim ds, a Set ds = CreateObject(""Scripting.FileSystemObject"") a = ds.FileExists(""C:\testfile.txt"") If a = True Then MsgBox ""Bu isimde bir dosya var"" Else MsgBox ""Bu isimde bir dosya yok"" End If End Sub" Dosya arama 2 "Diskteki istediğiniz dosyaları (alt klasörler dahil) nasıl bulacağınız ve bir comboda nasıl listeleyeceğiniz yazıyor. 'Bir forma btnara ismli bir düğme ve comsonuc isimli bir combobox yerleştirmeniz yeterli. Private Sub btnara_Click() comsonuc.Clear comsonuc.Refresh Dim arama As Object Dim aradosya As Object Set arama = CreateObject(""FileSearch.Search"") Call arama.SearchFiles(""d:\"", ""*.mp3"", True) Call arama.SearchFiles(""C:\"", ""*.xls"", True) DoEvents If arama.Files.Count > 0 Then For Each aradosya In arama.Files comsonuc.AddItem aradosya.FileName Set aradosya = Nothing Next End If Set arama = Nothing comsonuc.text=""ARAMA BİTTİ"" End Sub" Dosya arayıp bulsun varsa onaylasın "Sub Existe() If Dir$(""c:\ajeter\test.xls"") = """" Then MsgBox "" Pas trouvé ce fichier :O("" Else MsgBox "" OK ! Trouvé :O)"" End If End Sub" Dosya cd rom ismin kontrol ediyor tutmuyorsa kapatıyor "Sub auto_open() Dim fso, drv, cdr Set fso = CreateObject(""Scripting.FileSystemObject"") For Each drv In fso.Drives If drv.driveType = 4 Then Set cdr = drv Next If cdr.volumename <> ""CD nin adı"" Then MsgBox ""Lütfen program cd sini takmadan programı çalıştırmayınız"" ThisWorkbook.Close False End If End Sub" Dosya dizinde mi bakar, varsa açar yoksa mesaj verir "Function FileExists(FullFileName As String) As Boolean FileExists = Len(Dir(FullFileName)) > 0 End Function Sub ss() If Not FileExists(""C:\f.xls"") Then MsgBox ""Aradığınız dosya belirtilen dizinde yok"" Else Workbooks.Open ""C:\f.xls"" End If End Sub" Dosya düzen çubuğuna menü ekleme silme "Modüle Option Explicit Sub CreateMenu() ' creates a new menu. ' can also be used to create commandbarbuttons ' may be automatically executed from an Auto_Open macro or a Workbook_Open eventmacro Dim cbMenu As CommandBarControl, cbSubMenu As CommandBarControl RemoveMenu ' delete the menu if it already exists ' create a new menu on an existing commandbar (the next 6 lines) Set cbMenu = Application.CommandBars(1).Controls.Add(msoControlPopup, , , , True) With cbMenu .Caption = ""&My menu"" .Tag = ""MyTag"" .BeginGroup = False End With ' or add to an existing menu (use the next line instead of the previous 6 lines) 'Set cbMenu = Application.CommandBars.FindControl(, 30007) ' Tools-menu If cbMenu Is Nothing Then Exit Sub ' didn't find the menu ' add menuitem to menu With cbMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = ""&Menu Item1"" .OnAction = ThisWorkbook.Name & ""!Macroname"" End With ' add menuitem to menu With cbMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = ""&Menu Item2"" .OnAction = ThisWorkbook.Name & ""!Macroname"" End With ' add a submenu Set cbSubMenu = cbMenu.Controls.Add(msoControlPopup, 1, , , True) With cbSubMenu .Caption = ""&Submenu1"" .Tag = ""SubMenu1"" .BeginGroup = True End With ' add menuitem to submenu (or buttons to a commandbar) With cbSubMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = ""&Submenu Item1"" .OnAction = ThisWorkbook.Name & ""!Macroname"" .Style = msoButtonIconAndCaption .FaceId = 71 .State = msoButtonDown ' or msoButtonUp End With ' add menuitem to submenu (or buttons to a commandbar) With cbSubMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = ""&Submenu Item2"" .OnAction = ThisWorkbook.Name & ""!Macroname"" .Style = msoButtonIconAndCaption .FaceId = 72 .Enabled = False ' or True End With ' add a submenu to the submenu Set cbSubMenu = cbSubMenu.Controls.Add(msoControlPopup, 1, , , True) With cbSubMenu .Caption = ""&Submenu2"" .Tag = ""SubMenu2"" .BeginGroup = True End With ' add menuitem to submenu submenu With cbSubMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = ""&Submenu Item1"" .OnAction = ThisWorkbook.Name & ""!Macroname"" .Style = msoButtonIconAndCaption .FaceId = 71 .State = msoButtonDown ' or msoButtonUp End With ' add menuitem to submenu submenu With cbSubMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = ""&Submenu Item2"" .OnAction = ThisWorkbook.Name & ""!Macroname"" .Style = msoButtonIconAndCaption .FaceId = 72 .Enabled = False ' or True End With ' add menuitem to menu With cbMenu.Controls.Add(msoControlButton, 1, , , True) .Caption = ""&Remove this menu"" .OnAction = ThisWorkbook.Name & ""!RemoveMenu"" .Style = msoButtonIconAndCaption .FaceId = 463 .BeginGroup = True End With Set cbSubMenu = Nothing Set cbMenu = Nothing End Sub Sub RemoveMenu() ' may be automatically executed from an Auto_Close macro or a Workbook_BeforeClose eventmacro DeleteCustomCommandBarControl ""MyTag"" ' deletes the new menu End Sub Private Sub DeleteCustomCommandBarControl(CustomControlTag As String) ' deletes ALL occurences of commandbar controls with a tag = CustomControlTag 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 ShowHideMenu(MenuVisible As Boolean) ' may be automatically executed from an Workbook_Activate macro or a Workbook_Deactivate eventmacro ChangeControlVisibility ""MyTag"", MenuVisible ' toggles menu visibility End Sub Private Sub ChangeControlVisibility(CustomControlTag As String, MenuVisible As Boolean) ' toggles menu visibility On Error Resume Next Application.CommandBars.FindControl(, , CustomControlTag, False).Visible = MenuVisible On Error GoTo 0 End Sub Sub Macroname() ' used by the menuitems created by the CreateMenu macro MsgBox ""This could be your macro running!"", vbInformation, ThisWorkbook.Name End Sub 'Thisworkbook a Private Sub Workbook_Activate() ShowHideMenu True End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) RemoveMenu End Sub Private Sub Workbook_Deactivate() ShowHideMenu False End Sub Private Sub Workbook_Open() CreateMenu End Sub" Dosya düzen menülerinin iptali ve yeni menü "Sub MenuErstellen() Dim MB As CommandBar Dim Ctrl1 As CommandBarControl Dim Ctrl2 As CommandBarControl Dim Ctrl1a As CommandBarControl Dim Ctrl1b As CommandBarControl Set MB = CommandBars.Add(Name:=""Neues Menü"", MenuBar:=True) Set Ctrl1 = MB.Controls.Add(Type:=msoControlPopup) Ctrl1.Caption = ""Untermenü1"" Set Ctrl2 = MB.Controls.Add(Type:=msoControlPopup) Ctrl2.Caption = ""Untermenü2"" Set Ctrl1a = Ctrl1.Controls.Add(Type:=msoControlPopup) Ctrl1a.Caption = ""Daten"" Set Ctrl1b = Ctrl1.Controls.Add(Type:=msoControlPopup) Ctrl1b.Caption = ""Übertragen"" CommandBars(""Neues Menü"").Visible = True End Sub" Dosya düzen menüsüne menü ekleme "Private Sub Workbook_Activate() MenuBars(xlWorksheet).Menus.Add ""&Test Menü"" Set ml = MenuBars(xlWorksheet).Menus(""Test Menü"") With ml .MenuItems.Add Caption:=""&Daten erfassen"", _ OnAction:=""DatenSpeichern"" .MenuItems.AddMenu Caption:=""&Auswertungen"" With .MenuItems(""Auswertungen"") .MenuItems.Add Caption:=""&Auswertung1"", _ OnAction:="""" .MenuItems.Add Caption:=""A&uswertung2"", _ OnAction:="""" End With End With End Sub Private Sub Workbook_Deactivate() MenuBars(xlWorksheet).Reset End Sub Private Sub Workbook_Open() MenuBars(xlWorksheet).Menus.Add ""&Test Menü"" Set ml = MenuBars(xlWorksheet).Menus(""Test Menü"") With ml .MenuItems.Add Caption:=""&Daten erfassen"", _ OnAction:=""DatenSpeichern"" .MenuItems.AddMenu Caption:=""&Auswertungen"" With .MenuItems(""Auswertungen"") .MenuItems.Add Caption:=""&Auswertung1"", _ OnAction:="""" .MenuItems.Add Caption:=""A&uswertung2"", _ OnAction:="""" End With End With End Sub" Dosya düzen menüsünü gizleme ve gösterme "Sub Menueleiste_ausblenden() Application.CommandBars(""Worksheet Menu Bar"").Enabled = False End Sub Sub Menueleiste_einblenden() Application.CommandBars(""Worksheet Menu Bar"").Enabled = True End Sub" Dosya düzen menüsünü silme "Sub supBA() For Each LaBarMenu In ActiveMenuBar.Menus LaBarMenu.Delete Next MsgBox ""Barre de menus supprimée !"" ActiveMenuBar.Reset MsgBox ""Barre de menus rétablie !"" End Sub Sub ac() Application.CommandBars(1).Enabled = True End Sub" Dosya isimleri "Sub Dosya_İsimleri() Dim ds, dc, f, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set f = ds.GetFolder(""C:\SXS"") Set dc = f.Files For Each dosya In dc s = s & vbCrLf & dosya.Name Next MsgBox s End Sub" Dosya isimlerin excele atamak "Sub Dosyalar() Dim Klasor As String Dim Dosya As String Dim i As Integer Klasor = ""C:\osman"" Dosya = Dir(Klasor & Application.PathSeparator & ""*.*"", vbDirectory) Do While Dosya <> """" Cells(i + 1, 1) = Dosya i = i + 1 Dosya = Dir Loop End Sub" Dosya kaç kere açılmış "ThisWorkbook'a Private Sub Workbook_Open() Worksheets(""Sayfa1"").Range(""A1"").Value = Worksheets(""Sayfa1"").Range(""A1"").Value + 1 MsgBox ""Bu dosya "" & Worksheets(""Sayfa1"").Range(""A1"").Value & "" kez açıldı"" & vbCrLf & ""En son açan : "" & Worksheets(""Sayfa1"").Range(""B1"") Worksheets(""Sayfa1"").Range(""B1"") = Application.UserName ThisWorkbook.Save End Sub" Dosya klasör ekle "Sub Auto_Open() 'belirtilen dizinde ""pir"" isimli bir klasör olup olmadığına bakar yoksa oluşturur On Error Resume Next If Dir(""C:\pir"") = """" Then MkDir ""C:\pir"" Sheets(""Sheet1"").Select End Sub Sub dosyaekle() 'belirtilen dizine dosya ekler. aynı isimli dosya varsa öncekini siler yeniden ekler Dim Dosyam As String, Message As String Workbooks.Add 'çalışma kitabı ekler Dosyam = ""C:\pir.xls"" 'yeni eklenecek dosyamızın ismi On Error Resume Next Kill Dosyam 'önceki dosyayı kaldırır On Error GoTo 0 ActiveWorkbook.SaveAs Filename:=Dosyam 'dosyaya isim verir ActiveWorkbook.Close End Sub" Dosya klasör ekle "Sub Auto_Open() 'belirtilen dizinde ""mahmut"" isimli bir klasör olup olmadığına bakar yoksa oluşturur On Error Resume Next If Dir(""C:\mahmut"") = """" Then MkDir ""C:\pir"" Sheets(""Sheet1"").Select End Sub Sub dosyaekle() 'belirtilen dizine dosya ekler. aynı isimli dosya varsa öncekini siler yeniden ekler Dim Dosyam As String, Message As String Workbooks.Add 'çalışma kitabı ekler Dosyam = ""C:\mahmut.xls"" 'yeni eklenecek dosyamızın ismi On Error Resume Next Kill Dosyam 'önceki dosyayı kaldırır On Error GoTo 0 ActiveWorkbook.SaveAs Filename:=Dosyam 'dosyaya isim verir ActiveWorkbook.Close End Sub" Dosya listeleme "Sub dosya_listeleme() Dim datename As String, i As Integer datename = Dir$(""C:\Documents and Settings\pir\Belgelerim\*.xls"") Do While datename <> """" ActiveCell.Offset(i, 0) = datename i = i + 1 datename = Dir$() Loop End Sub" Dosya menüsü hariç diğer araç çubuklarının gizlenmesi "Sub Verstecken() For Each tb in Toolbars tb.Visible = False Next tb End Sub" Dosya sayısı "Sub Dosya_Sayısı() Dim ds, dc, f, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set f = ds.GetFolder(""C:\SXS"") Set dc = f.Files s = dc.Count MsgBox s End Sub" Dosya silmek "Sub sil() Kill ""C:\Documents And Settings\pir\Belgelerim\pir.xls"" End Sub" Dosya sistemini gösterme "Sub Dosya_Sistemi_Göster() Dim ds, d, s Set ds = CreateObject(""Scripting.FileSystemObject"") Set d = ds.GetDrive(""C:\"") s = d.FileSystem MsgBox s End Sub" Dosya sistemini öğrenme "Private Declare Function GetVolumeInformation Lib ""Kernel32"" Alias ""GetVolumeInformationA"" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long Sub Dosya_Sistemi() Dim DosyaSistemi As String DosyaSistemi = String$(255, Chr$(0)) GetVolumeInformation ""C:\"", 0, 255, 0, 0, 0, DosyaSistemi, 255 DosyaSistemi = Left$(DosyaSistemi, InStr(1, DosyaSistemi, Chr$(0)) - 1) MsgBox DosyaSistemi End Sub" Dosya taşıma "Sub Dosya_Taşı() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") f = ds.MoveFile(""D:\ExcelÖrnekleri\Move.xls"", ""C:\"") End Sub" Dosya uzantısını verir "Sub Uzantı_İsmi() Dim ds, f Set ds = CreateObject(""Scripting.FileSystemObject"") f = ds.GetExtensionName(""D:\ExcelÖrnekleri\Soru.xls"") MsgBox f End Sub" Dosya yedekleme "Sub Yedek() '/_ Dismi= ActiveWorkbook.Name ActiveWorkbook.SaveCopyAs ""D:\Alihan_Bordro\ "" & Dismi ActiveWorkbook.Save End Sub" Dosya yedekleme mesaj kutusu ile ismini yaz "Sub Enregistre_Sous() Réponse = MsgBox(""Voulez-vous enregistrer ce classeur ?"", vbYesNo) If Réponse = vbYes Then Nom = InputBox(""Donnez un nom de fichier !"" & Chr(13) & ""Exemple: Rapport"") If Nom = """" Then Exit Sub Else GoTo continu End If continu: ChDrive ""c"" ChDir ""c:\"" 'Indiquez le répertoire ActiveWorkbook.SaveAs Filename:=(Nom) End If End Sub" Dosya yolu ve uzantısını belirle ayrıntılı listelesin "Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Declare Function SHGetPathFromIDList Lib ""shell32.dll"" _ Alias ""SHGetPathFromIDListA"" _ (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib ""shell32.dll"" _ Alias ""SHBrowseForFolderA"" (lpBrowseInfo As BROWSEINFO) As Long Private z! Function GetDirectory(Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer With bInfo .pidlRoot = 0& .lpszTitle = Msg .ulFlags = &H1 End With x = SHBrowseForFolder(bInfo) path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Else GetDirectory = """" End If End Function Sub Dateisuche(Laufwerk, Dateien) Dim tmp, Wdhlg, Dateiname As String On Error Resume Next If Right(Laufwerk, 1) <> ""\"" Then Laufwerk = Laufwerk + ""\"" tmp = Dir(Laufwerk & Dateien) Do While Len(tmp) Dateiname = Laufwerk & tmp Application.StatusBar = Dateiname Cells(z, 1).Select Cells(z, 1) = Laufwerk & tmp 'Pfad Cells(z, 2) = FileLen(Laufwerk & tmp) 'Größe Cells(z, 3) = FileDateTime(Laufwerk & tmp) 'Datum/Zeit Cells(z, 4) = tmp 'nur Dateiname z = z + 1 tmp = Dir() Loop tmp = Dir(Laufwerk, vbDirectory) Do While Len(tmp) If (tmp <> ""."") And (tmp <> "".."") Then If (GetAttr(Laufwerk & tmp) And vbDirectory) = vbDirectory Then Dateisuche Laufwerk & tmp, Dateien z = z - 1 Wdhlg = Dir(Laufwerk, vbDirectory) z = z + 1 Do While Wdhlg <> tmp Wdhlg = Dir() Loop End If End If tmp = Dir() Loop On Error GoTo 0 Application.StatusBar = False End Sub Sub Suchen() Dim Laufwerk$, Dateien$ 'Ersze Zeile, in der eine Eintragung erfolgt z = 2 'Alte Eintragungen löschen [a1:e5000] = """" 'Ersatz: = ""C:\Eigene Dateien"" Laufwerk = GetDirectory(""Bitte einen Ordner wählen"") If Laufwerk = """" Then Exit Sub 'Ersatz: Dateien = ""*.*"" Dateien = InputBox(""Nach welchen Dateien soll in"" & _ Chr(10) & "" "" & Laufwerk & Chr(10) & _ ""gesucht werden (z. B. *.xls)?"", _ ""Dateityp"", ""*.*"") If Dateien = """" Then Exit Sub Dateisuche Laufwerk, Dateien End Sub" Dosya yoluna gÖre excelden excele yÜkleme "Sub a() Set xl = CreateObject(""Excel.Sheet"") xl.Application.Workbooks.Open Range(""K1"") End Sub " Dosya yolunda excel dosyalarını bulur ve açar "Sub ExcelDateienÖffnen() With Application.FileSearch .NewSearch .LookIn = ""C:\"" ‘\Belgelerim şeklinde de olabilir. .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks .Execute For i = 1 To .FoundFiles.Count Workbooks.Open .FoundFiles(i) Next i End With End Sub" Dosya yolunu göster ayrıntılı olarak listelesin dosyaların kapladıkları alanları, dosya yolunu vs… "Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Declare Function SHGetPathFromIDList Lib ""shell32.dll"" Alias ""SHGetPathFromIDListA"" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib ""shell32.dll"" Alias ""SHBrowseForFolderA"" (lpBrowseInfo As BROWSEINFO) As Long Sub Verzeichnisse_auflisten() Dim Pfad1, Name1, Anzahl, X, X0, X1, X2, Verz, Anzverz, Größe Dim TB1, TB2 As Worksheet Dim msg As String Set TB1 = ThisWorkbook.Worksheets(1) Set TB2 = ThisWorkbook.Worksheets(2) start = Now TB1.[a:D] = """" TB2.[a:D] = """" If ThisWorkbook.Worksheets.Count > 2 Then Application.DisplayAlerts = False For X = 3 To ThisWorkbook.Worksheets.Count ThisWorkbook.Worksheets(3).Delete Next X Application.DisplayAlerts = True End If msg = ""Wählen Sie bitte einen Ordner aus:"" Pfad1 = getdirectory(msg) If Pfad1 = """" Then Exit Sub Name1 = Dir(Pfad1, vbDirectory) TB1.[a2] = Pfad1 Anzahl = 2 TB1.[a1] = ""Pfad"" TB1.[b1] = ""UnterVerz."" TB1.[c1] = ""Anz. Dateien"" TB1.[d1] = ""Datgröße in Verz."" X0 = 2 X1 = 2 Do While TB1.Cells(Rows.Count, 1).End(xlUp).Row <> TB1.Cells(Rows.Count, 2).End(xlUp).Row For X2 = X0 To X1 Pfad1 = TB1.Cells(X2, 1) If Right(Pfad1, 1) <> ""\"" Then Pfad1 = Pfad1 & ""\"" Name1 = Dir(Pfad1, vbDirectory) Verz = 0 Do While Name1 <> """" If Name1 <> ""."" And Name1 <> "".."" Then If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then Anzahl = Anzahl + 1 TB1.Cells(Anzahl, 1) = Pfad1 & Name1 & ""\"" Verz = Verz + 1 End If End If Name1 = Dir Loop TB1.Cells(X2, 2) = Verz Next X2 X0 = X1 + 1 X1 = X2 Loop Anzverz = TB1.Cells(Rows.Count, 1).End(xlUp).Row i = 1 ii = 0 For Verz = 2 To Anzverz Anzahl = 0 Größe = 0 Set fs = CreateObject(""Scripting.FileSystemObject"") Set f = fs.GetFolder(TB1.Cells(Verz, 1)) Set fc = f.Files For Each f1 In fc If i = 65536 Then ii = ii + 1 ThisWorkbook.Worksheets.Add.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) ThisWorkbook.Worksheets(ii + 2).Name = ""Dateien "" & ii + 1 Set TB2 = ThisWorkbook.Worksheets(ii + 2) i = 1 End If i = i + 1 Anzahl = Anzahl + 1 TB2.Cells(i, 1) = f1.Name TB2.Cells(i, 2) = f & ""\"" & f1.Name 'Hyperlink auf die Datei einfügen TB2.Hyperlinks.Add Anchor:=TB2.Cells(i, 2), Address:= _ f & ""\"" & f1.Name TB2.Cells(i, 3) = FileLen(f1) TB2.Cells(i, 4) = FileDateTime(f1) Größe = Größe + FileLen(f1) Next TB1.Cells(Verz, 3) = Anzahl TB1.Cells(Verz, 4) = Größe / 1024 / 1024 Next Verz 'MsgBox (ii * 65536) + i ende = Now MsgBox ""Anzahl der Verzeichnisse: "" & Verz & Chr(13) & _ ""Anzahl der Dateien: "" & (ii * 65536) + i & Chr(13) & _ Chr(13) & ""Dauer: "" & Format(ende - start, ""nn:ss"") End Sub Function getdirectory(Optional msg) As String Dim bInfo As BROWSEINFO Dim Path As String Dim r As Long, X As Long, pos As Integer ' Ausgangsordner = Desktop bInfo.pidlRoot = 0& If IsMissing(msg) Then bInfo.lpszTitle = ""Wählen Sie bitte einen Ordner aus."" Else bInfo.lpszTitle = msg End If bInfo.ulFlags = &H1 X = SHBrowseForFolder(bInfo) Path = Space$(512) r = SHGetPathFromIDList(ByVal X, ByVal Path) If r Then pos = InStr(Path, Chr$(0)) getdirectory = Left(Path, pos - 1) Else getdirectory = """" End If End Function" Dosya, düzen menüsüne menü ekleme "Private Sub Workbook_Open() Dim cmb As CommandBar Dim cmbp As CommandBarPopup Set cmb = Application.CommandBars. _ Add(Name:=""MeineLeiste"", _ Position:=msoBarTop, _ Temporary:=True) Set cmbp = cmb.Controls.Add(Type:=msoControlPopup) cmb.Visible = True cmbp.Caption = ""Mein Submenü"" With cmbp.Controls.Add(Type:=msoControlButton, _ Temporary:=True) .Caption = ""Meine 1. Prozedur"" .BeginGroup = True .FaceId = 59 .OnAction = ""MeineProzedur1"" End With With cmbp.Controls.Add(Type:=msoControlButton, _ Temporary:=True) .Caption = ""Meine 2. Prozedur"" .FaceId = 49 .OnAction = ""MeineProzedur2"" End With Set cmb = Nothing Set cmbp = Nothing End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim cmb As CommandBar Set cmb = Application.CommandBars(""MeineLeiste"") cmb.Delete Set cmb = Nothing End Sub Sub MeineProzedur1() MsgBox Application.UserName End Sub Sub MeineProzedur2() MsgBox Now() End Sub" Dosya, görünüm, düzen menüsünü gizle göster "Sub MenueleisteAusblenden() Application.CommandBars(""Worksheet Menu Bar"").Enabled = False End Sub Sub MenueleisteAusblenden() Application.CommandBars(""Worksheet Menu Bar"").Enabled = True End Sub" Dosya, menü çubuğunu gizle Application.CommandBars.ActiveMenuBar.Enabled = False Dosyada kİŞİ resmİ olmadiĞinda formdakİ İmage'nİn boŞ olmasi "On Error GoTo hata If foto <> False Then Image1.Picture = LoadPicture(""E:\Office\WINDOWS\Resim\"" & foto & "".bmp"") 'BU SATIRIN ÇALIŞMASI İÇİN ""C"" BÖLÜMÜNE ""Resim"" adında bir klasör açıp içine resimleri kişilerin kendi isimleriyle kaydedin. Image1.PictureSizeMode = fmPictureSizeModeStretch End If End If Next bak Exit Sub hata: Image1.Picture =loadpicture("""")" Dosyamızı silme "Sub dosyasil() On Error Resume Next RmDir ""C:\pir\xp\beyza"" End Sub" Dosyanın açık olup olmadığına bakar açık değilse açar "Function WorkbookOpen(WorkBookName As String) As Boolean WorkbookOpen = False On Error GoTo WorkBookNotOpen If Len(Application.Workbooks(WorkBookName).Name) > 0 Then WorkbookOpen = True Exit Function End If WorkBookNotOpen: End Function Sub AA() If Not WorkbookOpen(""C.xls"") Then Workbooks.Open ""C.xls"" End If End Sub" Dosyanın açılma tarih ve saatini txt'ye işler (alt alta) "Private Sub Workbook_Open() Open ThisWorkbook.Path & ""\pirr.log"" For Append As #1 Print #1, Application.UserName, Now Close #1 End Sub" Dosyanın tarihini yazın kaç gün geçtiğin hesaplasın "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" Dosyanın yolunu ve ismini hücreye yazdırır "Function CreateFileList(FileFilter As String, _ IncludeSubFolder As Boolean) As Variant Dim FileList() As String, FileCount As Long CreateFileList = """" Erase FileList If FileFilter = """" Then FileFilter = ""*.*"" ' all files With Application.FileSearch .NewSearch .LookIn = CurDir .Filename = FileFilter .SearchSubFolders = IncludeSubFolder .FileType = msoFileTypeAllFiles If .Execute(SortBy:=msoSortByFileName, _ SortOrder:=msoSortOrderAscending) = 0 Then Exit Function ReDim FileList(.FoundFiles.Count) For FileCount = 1 To .FoundFiles.Count FileList(FileCount) = .FoundFiles(FileCount) Next FileCount .FileType = msoFileTypeExcelWorkbooks ' reset filetypes End With CreateFileList = FileList Erase FileList End Function Sub TestCreateFileList() Dim FileNamesList As Variant, i As Integer 'ChDir ""C:\My Documents"" FileNamesList = CreateFileList(""*.*"", False) Range(""A:A"").ClearContents For i = 1 To UBound(FileNamesList) Cells(i + 1, 1).Formula = FileNamesList(i) Next i End Sub" Dosyanızı İstediğiniz klasöre yedekleyin "Sub Yedek() '/_ Dismi= ActiveWorkbook.Name ActiveWorkbook.SaveCopyAs ""D:\Alihan_Bordro\ "" & Dismi ActiveWorkbook.Save End Sub " Dosyanin bayt cİnsİnden bÜyÜklÜĞÜ nedİr? "A ya dosya ismini Bye Bayt cinsini Cye de tarihini yazar Kod: Sub Dateiname_Hyperlink() Dim StDateiname As String Dim Dateiform As String Dim InI As Long, TotFiles As Long Dim Suchpfad As String Dim OldStatus As Variant Suchpfad = InputBox(""Yolunu değiştirebilirsiniz"", ""Adres yolu"", Application.DefaultFilePath) If Suchpfad = """" Then Exit Sub Dateiform = InputBox(""Dosya uzantısını siz değiştiriniz"", ""Uzantı"", ""*.xls"") If Dateiform = """" Then Exit Sub Application.ScreenUpdating = True OldStatus = Application.StatusBar Sheets.Add After:=Worksheets(Worksheets.Count) With Application.FileSearch .LookIn = Suchpfad .SearchSubFolders = True .Filename = Dateiform If .Execute() > 0 Then TotFiles = .FoundFiles.Count Application.StatusBar = ""Total "" & TotFiles & "" gefunden"" For InI = 1 To .FoundFiles.Count Application.StatusBar = ""Datei: "" & InI & "" von "" & TotFiles StDateiname = Mid(.FoundFiles(InI), InStrRev(.FoundFiles(InI), ""\"") + 1) ActiveSheet.Hyperlinks.Add Anchor:=Cells(InI, 1), _ Address:=.FoundFiles(InI), TextToDisplay:=StDateiname Cells(InI, 2) = FileLen(.FoundFiles(InI)) Cells(InI, 3) = FileDateTime(.FoundFiles(InI)) Next InI End If End With Application.StatusBar = OldStatus Application.ScreenUpdating = True End Sub" Dosyayı farklı şekillerde kaydetme " Sub auto_close() sor = MsgBox(""Güle güle "" & Format(Now, ""dd.mmmm.yy hh:mm"") & Chr(10) & Chr(10) & ""dosyanın kaydedilmesini istiyormusunuz?"", 4, """") If sor = vbYes Then ActiveWorkbook.Save ActiveWorkbook.Close Else Application.DisplayAlerts = False ActiveWorkbook.Close End If End Sub" Dosyayı kapama "Sub kapa() MsgBox ""Bu programı pir düzenlemiştir."", , ""KAPATILIYOR"" ActiveWorkbook.Close True End Sub" Dosyayı kim açtı "ThisWorkBook yazılacak. 'Ayrıca C:\acılısarsiv.txt olarak ayrıca txt dosyası oluşturuyor.. Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String LastOpen = GetSetting(""xxrt"", ""Dosya"", ""Opened"", """") [a1] = ""En son açılış tarihi: "" & LastOpen [a2] = ""Dosyayı en son açan kullanıcı: "" & Application.UserName LastOpen = Date & "" "" & Time SaveSetting ""xxrt"", ""Dosya"", ""Opened"", LastOpen Dim LastRowA As Integer Dim veri1 As String Dim veri2 As String Dim i As Integer Open ""C:\acılısarsiv.txt"" For Output As #1 LastRowA = Cells(65536, 1).End(xlUp).Row For i = 1 To LastRowA veri1 = Cells(i, 1).Text veri2 = Cells(i, 2).Text Print #1, veri1; "" ""; veri2; Next i Close #1 'C Klasöründe txt hazırladı 'enson açan kişinin yazılı bulunduğuSayfa1 a1 ve a2 deki verileri siler.. 'eğer Sayfa1'de silmesini istemezseniz aşağıdakileri silin. Sheets(""Sayfa1"").Select Range(""A1:A2"").Select Selection.ClearContents Range(""A1"").Select End Sub 'Mesaj olarakta [a1] = ""En son açılış tarihi: "" & LastOpen [a2] = ""Dosyayı en son açan kullanıcı: "" & Application.UserName 'Kodlarının altına bunları yazın. MsgBox ""En son açılış tarihi: "" & LastOpen MsgBox ""Dosyayı en son açan kullanıcı: "" & Application.UserName " Dosyayı kim ne zaman hangi tarihte açtı txt "ThisWorkbook'a Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String LastOpen = GetSetting(""xxrt"", ""Dosya"", ""Opened"", """") [a1] = ""En son açılış tarihi: "" & LastOpen [a2] = ""Dosyayı en son açan kullanıcı: "" & Application.UserName MsgBox ""En son açılış tarihi: "" & LastOpen MsgBox ""Dosyayı en son açan kullanıcı: "" & Application.UserName LastOpen = Date & "" "" & Time SaveSetting ""xxrt"", ""Dosya"", ""Opened"", LastOpen Dim LastRowA As Integer Dim veri1 As String Dim veri2 As String Dim i As Integer Open ""C:\acılısarsiv.txt"" For Output As #1 LastRowA = Cells(65536, 1).End(xlUp).Row For i = 1 To LastRowA veri1 = Cells(i, 1).Text veri2 = Cells(i, 2).Text Print #1, veri1; "" ""; veri2; Next i Close #1 'C Klasöründe txt hazırladı 'enson açan kişinin yazılı bulunduğuSayfa1 a1 ve a2 deki verileri siler.. 'eğer Sayfa1'de silmesini istemezseniz aşağıdakileri silin. Sheets(""Sayfa1"").Select Range(""A1:A2"").Select Selection.ClearContents Range(""A1"").Select End Sub" Dosyayı sizden başkası kaydetmesin "Private Sub Workbook_BeforeSave _ (ByVal SaveAsUI As Boolean, Cancel As Boolean) sifre = InputBox(""İşçi Maaş İcmali olduğundan Kayıt için Şifre Girmelisiniz."", _ ""Yetkili Kişi"", ""Kaydetmek İçin Şifre girin"") If sifre = ""123456"" Then'Örnek Şifre olarak 123456 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" Dosyayı tarihli olarak kayıt etme "Option Explicit Sub DateAsFilename() Dim sFileName As String sFileName = Format(Now, ""dd.mm.yyyy"") + "".xls"" ' tarih formatını değiştirebilirsiniz (ddmmyy) gibi ActiveWorkbook.SaveAs sFileName End Sub" Dosyayi kİm aÇti "Sanırım Dosyanız Çok gizli olsa gerek..Dosyanızda silinme riskini düşünerek bu kodlara ihtiyaç duyduğunuzu umarım.Yoksa Bilgilerinizi makrolarınızı sizde paylaşmak istersiniz..Neyse aşağıdaki kod tam çözüm olmamakla birlikte bu kodlar ThisWorkBook yazılacak. .Ayrıca C:\acılısarsiv.txt olarak ayrıca txt dosyası oluşturuyor.. Kod: Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String LastOpen = GetSetting(""xxrt"", ""Dosya"", ""Opened"", """") [a1] = ""En son açılış tarihi: "" & LastOpen [a2] = ""Dosyayı en son açan kullanıcı: "" & Application.UserName LastOpen = Date & "" "" & Time SaveSetting ""xxrt"", ""Dosya"", ""Opened"", LastOpen Dim LastRowA As Integer Dim veri1 As String Dim veri2 As String Dim i As Integer Open ""C:\acılısarsiv.txt"" For Output As #1 LastRowA = Cells(65536, 1).End(xlUp).Row For i = 1 To LastRowA veri1 = Cells(i, 1).Text veri2 = Cells(i, 2).Text Print #1, veri1; "" ""; veri2; Next i Close #1 'C Klasöründe txt hazırladı 'enson açan kişinin yazılı bulunduğuSayfa1 a1 ve a2 deki verileri siler.. 'eğer Sayfa1'de silmesini istemezseniz aşağıdakileri silin. Sheets(""Sayfa1"").Select Range(""A1:A2"").Select Selection.ClearContents Range(""A1"").Select End Sub Mesaj olarakta Kod: [a1] = ""En son açılış tarihi: "" & LastOpen [a2] = ""Dosyayı en son açan kullanıcı: "" & Application.UserName Kodlarının altına bunları yazın.Kod: MsgBox ""En son açılış tarihi: "" & LastOpen MsgBox ""Dosyayı en son açan kullanıcı: "" & Application.UserName " Döngü "C1, C2, C3 veC4'e X değerlerini 'D1, D2,D3 ve D4'e Y değerlerini 'E1, E2, E3 ve E4'e Z değerlerini girin. Sub xyz() Dim i As Integer Dim j As Integer Dim k As Integer Dim satir As Integer satir = 1 For k = 1 To 4 For j = 1 To 4 For i = 1 To 4 Cells(satir, 1) = Cells(k, 3) & Cells(j, 4) & Cells(i, 5) satir = satir + 1 Next i Next j Next k End Sub " Döngü ile yanyana yazdırma "Sub TableauAnTrimestre() For An = 1 To 5 Cells(1, An + 1).Value = 2000 + An Next An For Trimestre = 1 To 4 Cells(Trimestre + 1, 1).Value = ""Trim"" & Trimestre Next Trimestre End Sub" Döngülü formül girme "Sub JourSemaine() Dim semaine(1 To 7) As String semaine(1) = ""Lundi"" semaine(2) = ""Mardi"" semaine(3) = ""Mercredi"" semaine(4) = ""Jeudi"" semaine(5) = ""Vendredi"" semaine(6) = ""Samedi"" semaine(7) = ""Dimanche"" For i = 1 To 7 Selection.Offset(i - 1, 0).Formula = semaine(i) Next i End Sub" Dtpicker le güncel tarih "a = Mid(Date, 3, 1) DTPicker1.Value = Format(Date, ""dd"" + a + ""mm"" + a + ""yyyy"")" Dtpicker tarih değerini hücreye alma "Private Sub DTPicker1_Change() [B3] = DTPicker1.Value End Sub" Dtpickerin değerinin database den gelen bir değer olmasını istiyorsak "Date = gunkontrol.Fields(""tarih"") a = Mid(Date, 3, 1) DTPicker1.Value = Format(Date, ""dd"" + a + ""mm"" + a + ""yyyy"") ancak bu kod yazıldığında bilgisayarın sistem tarihi de database den galen tarih olarak değişiyor. bunu önlemek içi şöyle bir kontrol uygulayabiliriz: sondate = Date Date = gunkontrol.Fields(""tarih"") a = Mid(Date, 3, 1) DTPicker1.Value = Format(Date, ""dd"" + a + ""mm"" + a + ""yyyy"") Date = sondate" Durum çubuğunda bulunduğun adres "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _ ByVal Target As Excel.Range) Application.StatusBar = Sh.Name & "":"" & Target.Address End Sub" Durum çubuğunda bulunduğun adres2 "Thisworkbook'a Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Application.StatusBar = Application.UserName & ""-"" & _ ThisWorkbook.Path & ""-"" & Sh.Name & "":"" & Target.Address Application.Caption = ThisWorkbook.Path & ""-"" & Sh.Name ActiveWindow.Caption = Target.Address End Sub" Durum çubuğunda sayı mesaj "Declare Function GetAsyncKeyState Lib ""User32"" _ (ByVal vKey As Integer) As Integer 'GetAsyncKeyState est asynchrone - La touche est mémorisée Sub testToucheA() For y = 1 To 10000 Application.StatusBar = y Next If (GetAsyncKeyState(65) <> 0) Then MsgBox ""Touche A frappée."" End If End Sub" Durum çubuğunda toplam alma (fare ile seçileni toplar) "Sub tridoublon() Worksheets(""Feuil1"").Range(""A1"").Sort _ key1:=Worksheets(""Feuil1"").Range(""A2""), _ Order1:=xlAscending, Header:=xlGuess Set MaCell = Worksheets(""Feuil1"").Range(""A1"") Do While Not IsEmpty(MaCell) Set MaCellSuite = MaCell.Offset(1, 0) If MaCellSuite.Value = MaCell.Value Then MaCell.EntireRow.Delete End If Set MaCell = MaCellSuite Loop End Sub" Düzen seçenekleri penceresi "Sub Dialog_47() Application.Dialogs(xlDialogOptionsEdit).Show End Sub" E1:e15 'i toplayıp a1'e yazar "Sub GetSum() [A1].Value = Application.Sum([E1:E15]) End Sub" E10 hücresine yazı yaz sağdan sola kayarak yazsın "Declare Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long) Sub Rotieren() Dim C As Range Dim i% Set C = Range(""E10"") For i = 1 To 2000 C = Right(C, Len(C.Value) - 1) + Left(C, 1) Sleep 200 Next i End Sub" E2 hücresinde formülü aşağı doğru çekerek çoğaltır "Sub Düğme1_Tıklat() x = Cells(65536, 3).End(xlUp).Row Range(""E2"").AutoFill Destination:=Range(""E2:E"" & x) Application.Calculate End Sub" Eğer "p" sütununda "evet" yazanlar listede yer alsın "Private Sub CommandButton1_Click() For Each yes In Range(""P:P"") If yes = ""evet"" Then ListBox1.AddItem yes.Offset(0, -12) End If Next End Sub" Eğer a1 1 ise sayfa ekle "Private Sub Worksheet_Change(ByVal Target As Range) If Target.Value = 1 Then Dim sayfa As Worksheet Dim önek As String Dim sonek As Integer Set Sayfam = Worksheets.Add önek = ""Sayfam"" SonEkim = 1 On Error Resume Next Sayfam.Name = önek & sonek If Err.Number <> 0 Then önek = sonek + 1 Sayfam.Name = önek & sonek End If End If End Sub" Eğer a1 hücresi 1 ise mesaj kutusu çalışsın ve excelpazarı yazsın "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = ""$A$1"" Then If Target.Value = ""1"" Then MsgBox ""ExcelPazarı"" End If End Sub" Eğer a1 hücresi sıfırdan büyükse macro çalışsın "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Range(""A1"") >= 1 Then MsgBox ""Aşkından Selamlar"" End Sub " Eğer a1 hücresinde işlem yapılırsa a2 hücresine değiştirilme tarihi ve saatini yazar "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target = Cells(1, 1) Then Cells(2, 1) = Now End Sub 'alternatif ŞİMDİ() or Bugün or Time" Eğer a1 hücresinin değeri a3 hücresindeki değerden düşükse macro çalışsın "Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = ""$A$1"" Or Target.Address = ""$A$3"" Then If Range(""A1"").Value < Range(""A3"").Value Then Macro1 End If End If End Sub Sub Macro1() MsgBox ""Selam"" End Sub" Eğer aktif hücre değeri 1 den büyük ise aktif hücrenin altına boş satır ekler "Sub InserLSiRupture() Set x = ActiveCell Do Until IsEmpty(x) If x.Row > 1 Then If x.Offset(-1, 0).Value <> x.Value Then Rows(x.Row).Insert Shift:=xlDown End If End If Set x = x.Offset(1, 0) Loop End Sub" Eğer aktif hücre numerik ise ve 500 den büyükse kalın yapar "Sub Action() If IsNumeric(ActiveCell) Then ActiveCell.Font.Bold = ActiveCell.Value >= 500 End If End Sub" Eğer aktif hücrede değer varsa onu a17'ye yazar "Sub SelCurRegCopy() Selection.CurrentRegion.Select Selection.Copy Range(""A17"").Select ' Substitute your range here ActiveSheet.Paste Application.CutCopyMode = False End Sub" Eğer formülü 7 tane ve daha fazlası "12 adet eğer formülünü araya + işlecini koyarak 2 ye bölmektir. Formül B1 hücresine yazılmış ve A1 hücresindeki veriyi kontrol tmektediA1=""OCAK"";OCAK!A1;EĞER(A1=""ŞUBAT"";ŞUBAT!A1;EĞER(A1=""MART"";MART!A1;EĞER(A1=""NİSAN"";NİSAN!A1;EĞER(A1=""MAYIS"";MAYIS!A1;EĞER(A1=""HAZİRAN"";HAZİRAN!A1))))))+EĞER(A1=""TEMMUZ"";TEMMUZ!A1;EĞER(A1=""AĞUSTOS"";AĞUSTOS!A1;EĞER(A1=""EYLÜL"";EYLÜL!A1;EĞER(A1=""EKİM"";EKİM!A1;EĞER(A1=""KASIM"";KASIM!A1;EĞER(A1=""ARALIK"";ARALIK!A1))))))" Eğer sayfa boş ise alt bilgiye tarihi ekler değilse ekleyer ve yazdırır "Sub Datum_in_Fusszeile() Dim SeitenNummer%, X% Dim Zaehler As Boolean Zaehler = True X = ExecuteExcel4Macro(""get.document(50)"") For SeitenNummer = 1 To X If Zaehler = True Then With ActiveSheet.PageSetup .RightFooter = ""&D"" .LeftFooter = """" End With End If If Zaehler = False Then With ActiveSheet.PageSetup .RightFooter = """" .LeftFooter = ""&D"" End With End If ActiveWindow.SelectedSheets.PrintOut _ From:=SeitenNummer, To:=SeitenNummer, Copies:=1 Zaehler = Not Zaehler Next SeitenNummer End Sub" Eğer sütunda veriler varsa yukarıdan aşağıya doğru seçer "Sub SelectFirstToLastInColumn() Set TopCell = Cells(1, ActiveCell.Column) Set BottomCell = Cells(16384, ActiveCell.Column) If IsEmpty(TopCell) Then Set TopCell = TopCell.End(xlDown) If IsEmpty(BottomCell) Then Set BottomCell = BottomCell.End(xlUp) If TopCell.Row = 16384 And BottomCell.Row = 1 Then ActiveCell.Select Else Range(TopCell, BottomCell).Select End Sub" Eğer yanyana 2 hücrede değer varsa sağdan sola doğru seçer "Sub SelectFirstToLastInRow() Set LeftCell = Cells(ActiveCell.Row, 1) Set RightCell = Cells(ActiveCell.Row, 256) If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight) If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft) If LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select End Sub" Eğerle hücreye formül girme ve koda çevirme "Sub ExcelEger() [B1] = ""=IF(A1>=50,""""Sınıf Geçer"""",""""Sınıfta Kalır"""")"" End Sub Sub VBAEger() If [A1] >= 50 Then [B1] = ""Sınıf Geçer"" Else [B1] = ""Sınıfta Kalır"" End If End Sub" Ehatalıysa formülünün izahı "Bu tür hata mesajlarının hepsinde aynı yöntemi uygulamak mümkündür. Unutulmamalıdır ki, hata mesajı olan hücrede bir formül bulunmaktadır. 'Farzedelim ki hatalı hücrede aşağıdaki gibi bir formül olsun. =DÜŞEYARA(B1;C1:D11;2;0) 'Düşeyara ile aranılan veri bulunamadığında hücrede #YOK hata değeri olacaktır. Dolayısı ile bu da o hücrenin içerisinde bulunduğu bir toplama 'dizisini hatalı olarak gösterecektir. O halde bu hücreye ya boşluk değeri ya da sıfır değeri atayabiliriz. Ama unutmayınız sıfır değeri çarpma 'işleminde sorun çıkartabilir. O halde boşluk değeri atayalım. Yukarıdaki formülü aşağıdaki gibi değiştiriniz. =EĞER(EHATALIYSA(DÜŞEYARA(B1;C1:D11;2;0));"""";DÜŞEYARA(B1;C1:D11;2;0)) 'Yaptığımız tek şey normal olarak bildiğimiz EĞER formülü ile birlikte EHATALIYSA formülünü kullanmaktır. Formülün anlaşılması için aşağıdaki 'açıklamayı inceleyiniz. =EĞER(HATALIYSA(formül);"""";formül)) '""Eğer formül hatalı sonuç veriyorsa hücreyi boş bırak, değil ise formül sonucunu yazdır.""" Eklantilerin tamamının kontrolü "Sub Eklenti() Dim i As Integer Dim Eklenti Cells(1, 1).Value = ""Eklenti Adı"" Cells(1, 2).Value = ""Eklenti Yolu"" Cells(1, 3).Value = ""Eklenti Boyutu"" Cells(1, 4).Value = ""Eklentiyi Oluşturma Tarihi"" Cells(1, 5).Value = ""Dosya Tipi"" Set Eklenti = CreateObject(""Scripting.FileSystemObject"") For i = 1 To Application.AddIns.Count Cells(i + 1, 1).Value = Application.AddIns(i).Name 'adı Cells(i + 1, 2).Value = Application.AddIns(i).Path 'Dosya Yolu Cells(i + 1, 3).Value = Int(Eklenti.GetFile(Application.AddIns(i).FullName).Size / 1024) & "" Kb"" Cells(i + 1, 4).Value = Eklenti.GetFile(Application.AddIns(i).FullName).DateCreated Cells(i + 1, 5).Value = Eklenti.GetFile(Application.AddIns(i).FullName).Type If Application.AddIns(i).Installed = False Then Cells(i + 1, 6).Value = ""Aktif Değil"" Else Cells(i + 1, 6).Value = ""Aktif"" End If Next i Columns(""A:F"").EntireColumn.AutoFit End Sub" Ekle (hücre) penceresi "Sub Dialog_38() Application.Dialogs(xlDialogInsert).Show End Sub" Eklentiler penceresi "Sub Dialog_03() Application.Dialogs(xlDialogAddinManager).Show End Sub" Eklentileri mesajla öğrenin "Sub afficheComplement() For Each a In AddIns MsgBox a.FullName Next a End Sub" Eklentinin varlığını kontrol etme "Sub testUtilitAnalyse() If AddIns(""Query manager"").Installed = True Then MsgBox ""Utilitaire d'analyse installé"" Else MsgBox ""Utilitaire d'analyse non installé"" End If End Sub" Ekran çözünürlüğü ayarlama "Private Declare Function EnumDisplaySettings Lib ""user32"" Alias ""EnumDisplaySettingsA"" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean Private Declare Function ChangeDisplaySettings Lib ""user32"" Alias ""ChangeDisplaySettingsA"" (lpDevMode As Any, ByVal dwflags As Long) As Long Const CCDEVICENAME = 32 Const CCFORMNAME = 32 Const DM_PELSWIDTH = &H80000 Const DM_PELSHEIGHT = &H100000 Type DEVMODE dmDeviceName As String * CCDEVICENAME dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName As String * CCFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Integer dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type Dim DevM As DEVMODE Private Sub ChangeScreenResolution(iWidth As Single, iHeight As Single) Dim a As Boolean Dim i& Dim b& i = 0 Do a = EnumDisplaySettings(0&, i&, DevM) i = i + 1 Loop Until (a = False) DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT DevM.dmPelsWidth = iWidth DevM.dmPelsHeight = iHeight b = ChangeDisplaySettings(DevM, 0) End Sub Sub ChangeTo1024_768() Call ChangeScreenResolution(1024, 768) 'buradaki değerleri değiştirerek ayarlayabilirsiniz. End Sub" Ekran çözünürlüğünü ayarlatma "Private Declare Function EnumDisplaySettings Lib ""user32"" Alias ""EnumDisplaySettingsA"" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean Private Declare Function ChangeDisplaySettings Lib ""user32"" Alias ""ChangeDisplaySettingsA"" (lpDevMode As Any, ByVal dwflags As Long) As Long Const CCDEVICENAME = 32 Const CCFORMNAME = 32 Const DM_PELSWIDTH = &H80000 Const DM_PELSHEIGHT = &H100000 Type DEVMODE dmDeviceName As String * CCDEVICENAME dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName As String * CCFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Integer dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type Dim DevM As DEVMODE Private Sub ChangeScreenResolution(iWidth As Single, iHeight As Single) Dim a As Boolean Dim i& Dim b& i = 0 Do a = EnumDisplaySettings(0&, i&, DevM) i = i + 1 Loop Until (a = False) DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT DevM.dmPelsWidth = iWidth DevM.dmPelsHeight = iHeight b = ChangeDisplaySettings(DevM, 0) End Sub Sub ChangeTo1024_768() Call ChangeScreenResolution(1024, 768) End Sub" Ekran çözünürlüğünü ayarlattırmak "Declare Function GetClipCursor Lib ""user32"" (lprc As RECT) As Long Type RECT gauche As Long haut As Long droit As Long bas As Long End Type Dim oGCC As RECT Sub auto_open() GetClipCursor oGCC With oGCC [a1] = .droit & "" x "" & .bas If [a1] <> ""1024 x 768"" Then MsgBox ""Üzgünüm ekran çözünürlüğünüz 1024 x 768 olması gerekiyor aksi taktirde bu programı kullanmazsınız"" Application.DisplayAlerts = False ActiveWorkbook.Close End If End With End Sub" Ekran çözünürlüğünü öğrenme "Declare Function GetDeviceCaps Lib ""gdi32"" (ByVal hdc As Long, ByVal nIndex As Long) As Long Declare Function GetDC Lib ""user32"" (ByVal hwnd As Long) As Long Declare Function ReleaseDC Lib ""user32"" (ByVal hwnd As Long, ByVal hdc As Long) As Long Const HORZRES = 8 Const VERTRES = 10 Declare Function GetSystemMetrics Lib ""user32"" (ByVal nIndex As Long) As Long Const SM_CYSCREEN As Long = 1 Const SM_CXSCREEN As Long = 0 Sub GetScreenDimensions() Dim lWidth As Long Dim lHeight As Long lWidth = GetSystemMetrics(SM_CXSCREEN) lHeight = GetSystemMetrics(SM_CYSCREEN) MsgBox ""Screen Width = "" & lWidth & vbCrLf & ""Screen Height = "" & lHeight End Sub Function ScreenResolution() Dim lRval As Long Dim lDc As Long Dim lHSize As Long Dim lVSize As Long lDc = GetDC(0&) lHSize = GetDeviceCaps(lDc, HORZRES) lVSize = GetDeviceCaps(lDc, VERTRES) lRval = ReleaseDC(0, lDc) ScreenResolution = lHSize & ""x"" & lVSize End Function Sub GetScreenSize() Debug.Print ScreenResolution() End Sub" Ekran çözünürlüğünün 800x600 ayarlı olarak sayfanın gösterilmesi "Private Sub Worksheet_Activate() Call GetScreenSize End Sub Declare Function GetDeviceCaps Lib ""gdi32"" (ByVal hdc As Long, _ ByVal nIndex As Long) As Long Declare Function GetDC Lib ""user32"" (ByVal hwnd As Long) As Long Declare Function ReleaseDC Lib ""user32"" (ByVal hwnd As Long, _ ByVal hdc As Long) As Long Const HORZRES = 8 Const VERTRES = 10 Function ScreenResolution() Dim lRval As Long Dim lDc As Long Dim lHSize As Long Dim lVSize As Long lDc = GetDC(0&) lHSize = GetDeviceCaps(lDc, HORZRES) lVSize = GetDeviceCaps(lDc, VERTRES) lRval = ReleaseDC(0, lDc) ScreenResolution = lHSize & ""x"" & lVSize End Function Sub GetScreenSize() Dim aufl As String aufl = ScreenResolution() If aufl = ""800x600"" Then ActiveWindow.Zoom = 75 End If If aufl = ""1024x768"" Then ActiveWindow.Zoom = 125 End If End Sub" Ekran çözünürlüğünüzü öğrenin "Declare Function GetDeviceCaps Lib ""gdi32"" (ByVal hdc As Long, _ ByVal nIndex As Long) As Long Declare Function GetDC Lib ""user32"" (ByVal hWnd As Long) As Long Declare Function ReleaseDC Lib ""user32"" (ByVal hWnd As Long, _ ByVal hdc As Long) As Long Sub RésolutionEcran() Dim Pix As Long Pix = GetDC(0) MsgBox ""La résolution est : "" & GetDeviceCaps(Pix, 8) _ & "" * "" & GetDeviceCaps(Pix, 10) & "" pixels"" ReleaseDC 0, Pix End Sub" Ekrandaki araç çubuklarını kaldırır ve getirir "Sub Menueleiste_ein() With Application .ScreenUpdating = False .CommandBars(""toolbar list"").Enabled = True .CommandBars(""Worksheet Menu Bar"").Enabled = True .CommandBars(""Cell"").Enabled = True .DisplayFormulaBar = False .DisplayStatusBar = False .DisplayFullScreen = False End With With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True .DisplayWorkbookTabs = True .DisplayHeadings = True .WindowState = xlMaximized End With End Sub Sub Menueleiste_aus() With Application .ScreenUpdating = False .CommandBars(""toolbar list"").Enabled = False .CommandBars(""Worksheet Menu Bar"").Enabled = False .CommandBars(""Cell"").Enabled = False .DisplayFormulaBar = True .DisplayStatusBar = True .DisplayFullScreen = True End With With ActiveWindow .DisplayHorizontalScrollBar = False .DisplayVerticalScrollBar = False .DisplayWorkbookTabs = False .DisplayHeadings = False .WindowState = xlMaximized End With End Sub" Email ayıklama "Sub ayikla() For x = 1 To [a65536].End(3).Row d = Split(Cells(x, 1)) For Each elem In d If InStr(elem, ""@"") Then a = a + 1 Sheets(""sayfa2"").Cells(a, 1) = Trim(Replace(Replace(Replace(elem, "","", """"), ""e-mail:"", """"), Chr(160), """")) End If Next elem Next x Sheets(""sayfa2"").Select End Sub" Email linki ekleme "Sub Email() ActiveWorkbook.SendMail Recipients:=""pir@yahoo.com"" End Sub" Email linki verme ve açma "Sub HyperlinkMitEmailEinfuegen() Range(""A1"").Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= ""mailto:machero@aol.com"" End Sub Sub HyperlinkAktivieren() Range(""A1"").Select Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True End Sub" En alttakİ boŞ hÜcre "Tüm sayfadaki en son hücreyi isterseniz aşağıdaki kodu deneyin. Sub ensonagit() Sheets(""sayfa2"").Select Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Select End Sub" En son aktf hücrenin bulunduğu sütunu söyler "Sub test_A() Colonne = Left$(ActiveCell.Address(0, 0), (ActiveCell.Column < 27) + 2) If Colonne = ""A"" Then MsgBox ""Je lance la macro ici"" Else MsgBox Colonne End If End Sub" En son aktif hücreye gider "Sub LetzteZelle() Rows.SpecialCells(xlCellTypeLastCell).Rows.Activate End Sub" En son boşluklu kelimeyi bulur =pir(a3) "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" En son dolu hücrenin bulunduğu kolon numarasını verir "Sub AnzahlVerwendeteZeilen() i = ActiveSheet.UsedRange.Rows.Count MsgBox i End Sub" En son girilen verinin satır numarasını söyler (a sütununda) "Sub LastRow() MsgBox Cells.Find(""*"", searchdirection:=xlPrevious).Row End Sub" En son hÜc.Yukaridakİlerİnİ sİler "Çalışma Sayfasındaki 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 " En son kaydedİlen hÜcre "Soruyu sorduktan sonra tesadüfen Sayın Raider'in daha önce yazmış olduğu aşağıdaki kodu buldum ve işimi gördü. Kod: Private Sub Worksheet_Activate() Cells(65536, 2).End(xlUp).Select End Sub " En son kayıt tarihini açılışta öğren "Private Sub Workbook_Open() MsgBox ActiveWorkbook.BuiltinDocumentProperties(12).Name & ActiveWorkbook.BuiltinDocumentProperties(12) End Sub" En son kayıtlı hücreye gider a sütununda "Sub der() Range(""A1"").Select If Cells(ActiveCell.Row + 1, ActiveCell.Column).Value <> """" Then ActiveCell.End(xlDown).Select End If End Sub" Enter tuşunun geri gelsin "Sub ResetEnterReturn() Application.OnKey ""{ENTER}"" Application.OnKey ""~"" End Sub " Enter tuşunun geri gelsin 2 "Sub Auto_Close() Application.MoveAfterReturn = True End Sub " Enter tuşunun iptali "Private Sub Worksheet_Activate() Application.OnKey ""{ENTER}"", ""Macro1"" Application.OnKey ""~"", ""Macro1"" End Sub" Entere basilinca İstedİĞİmİz bİr hÜcrenİn aktİf olmasi "Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row > 4 Then Cells(1, Target.Column + 1).Activate End Sub " Esc tuŞuyla userformunuzu "ESC tuşuyla Userformunuzu kapatabilirsiniz Kod: Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 27 Then Unload Me End Sub " Eski formülleri geri getirme (förmül yenileme) "Sub formulyenile() Application.ScreenUpdating = False Range(""e2"").Select Range(""e2"").Formula = ""=ROUND(AVERAGE(RC[-4]:RC[-1]),0)"" Range(""e2"").Select Selection.AutoFill Destination:=Range(""e2:e50""), Type:=xlFillDefault Range(""e2:e50"").Select Selection.AutoFill Destination:=Range(""e2:e50""), Type:=xlFillDefault Range(""e2"").Select Application.ScreenUpdating = True End Sub" EŞ zamanli olmayan verİlerİ otomatİk sİlen kod "Sub a() For i = 1 To 100 If Cells(i, 1) <> Cells(i, 3) Then Cells(i, 3).EntireRow.Delete End If Next End Sub" Etiket aralıkları ekleme penceresi "Sub Dialog_40() Application.Dialogs(xlDialogInsertNameLabel).Show End Sub" Etkin işlem sayfasının genişliğini belirle ActiveSheet.StandartWidth=25 - ->Etkin işlem sayfasının genişliğini 25 yapar. Etkinleştir penceresi "Sub Dialog_01() Application.Dialogs(xlDialogActivate).Show End Sub" Etopla formÜlÜne karŞilik gelen makro "UserForm'a CommandButton1 nesnesini ilave ederseniz; Kod: Private Sub ComboBox1_Change() [AA1] = ComboBox1.Text End Sub Private Sub CommandButton1_Click() MsgBox Format(Evaluate(""SUMIF(C8:C1000,AA1,E8:E1000)""), ""###,###"") End Sub TextBox2' e girdiğin tarih de dikkate alınsın istiyorsan; Kod: Private Sub ComboBox1_Change() On Error Resume Next [AA1] = ComboBox1.Text [AA2] = CDate(TextBox2.Text) + 0 End Sub ' Private Sub TextBox2_Change() On Error Resume Next [AA1] = ComboBox1.Text [AA2] = CDate(TextBox2.Text) + 0 End Sub ' Private Sub CommandButton1_Click() MsgBox Format(Evaluate(""SUMPRODUCT((B8:B998=AA2)*(C8:C998=AA1)*(E8:E998))""), ""###,###"") End Sub " Evet ve hayır doğrultusunda makro çalıştırma "Sub mesaj() YesNo = MsgBox(""Bu makroyu çalıştırmak istiyor musunuz?"", vbYesNo + vbCritical, ""Soru Başlığı"") Select Case YesNo Case vbYes MsgBox ""Makro çalıştırıldı."", vbMsgBoxRtlReading Case vbNo MsgBox ""Makroyu iptal ettiniz."", vbMsgBoxSetForeground End Select End Sub" Excel ' de kopyalama makrosu nasil yazilir? "Size iki çözüm ; 1.cisi activ sayfada active hucre en son veri girdiğiniz hucre ise Kod: Sub Cozum1() Dim i As Integer Set Sliste = Worksheets(""liste"") For i = 2 To 30000 If Sliste.Range(""A"" & i).Value = Empty Then Sliste.Range(""A"" & i).Value = ActiveCell.Value Sliste.Range(""B"" & i).Value = ActiveCell.Offset(0, 1).Value Exit Sub End If Next i End Sub 2.cisi ise Activ sayfada activ hucra neresi olursa olsun.en son veri girişi yaptığınız hucredeki veriyi liste sayfasına aktarır. Kod: Sub Cozum2() Dim iliste, satir As Integer Dim hucre As Range Set Sliste = Worksheets(""liste"") For iliste = 2 To WorksheetFunction.CountA(Range(""A1:A65000"")) For Each hucre In Range(""A1:A65000"").Cells If hucre.Value = Empty Then satir = hucre.Row - 1 GoTo cik End If Next hucre cik: If Sliste.Range(""A"" & iliste).Value = Empty Then Sliste.Range(""A"" & iliste).Value = ActiveSheet.Cells(satir, 1).Value Sliste.Range(""B"" & iliste).Value = ActiveSheet.Cells(satir, 2).Value Exit Sub End If Next iliste End Sub Burada listeniz a ve b surunlarında olduğunu ve devamlı şekilde liste sayfasına aktaracağınızı hesap ederek yapılmıştır" Excel (xls) dosyasını silme "Sub Killfile() Dim MyFile As String 'This line of code is optional On Error Resume Next 'On hitting errors, code resumes next code MyFile = ""c:\Yeni.xls"" Kill MyFile End Sub" Excel belgelerİ salt okunur aÇiliyor "Sub b() Open ""c:/uludağ/no"" For Random As #4 Dim s As Integer Dim h As String Get 4, 1, s u = 2 For i = 2 To s Get 4, i, h Dim kitap As Excel.Application Set kitap = CreateObject(""Excel.Application"") kitap.Workbooks.Open (""c:\uludağ\"" & h & "".xls"") kitap.Visible = False Sheets(1).Cells(u, 2).Value = kitap.Sheets(9).Cells(2, 2).Value Sheets(1).Cells(u, 3).Value = kitap.Sheets(9).Cells(2, 3).Value For w = 1 To 9 If kitap.Sheets(9).Cells(w + 1, 4) = """" Then u = u + w: GoTo 10 Sheets(1).Cells(u + w - 1, 1).Value = kitap.Sheets(9).Cells(2, 1).Value Sheets(1).Cells(u + w - 1, 4).Value = kitap.Sheets(9).Cells(w + 1, 4) Sheets(1).Cells(u + w - 1, 5).Value = kitap.Sheets(9).Cells(w + 1, 5) Sheets(1).Cells(u + w - 1, 6).Value = kitap.Sheets(9).Cells(w + 1, 6) Sheets(1).Cells(u + w - 1, 7).Value = kitap.Sheets(9).Cells(w + 1, 7) Sheets(1).Cells(u + w - 1, 8).Value = kitap.Sheets(9).Cells(w + 1, 8) Sheets(1).Cells(u + w - 1, 9).Value = kitap.Sheets(9).Cells(w + 1, 9) Sheets(1).Cells(u + w - 1, 10).Value = kitap.Sheets(9).Cells(w + 1, 10) Next w 10 Next i Close 4 kitap.Quit Set kitap = Nothing End Sub" Excel crack "Sub Passwortknacken() xlCrack End Sub Private Function xlCrack() Dim wkb As Workbook Dim wks As Worksheet Dim txt As String Application.ScreenUpdating = False Set wkb = ActiveWorkbook Set wks = ActiveWorkbook.ActiveSheet txt = Application.Version If Left(txt, 1) <> 8 And Left(txt, 1) <> 9 Then Beep MsgBox ""Das AddIn ist nur unter XL8 und XL9 lauffähig!"" Exit Function End If Call wkbEncode(wkb) For Each wks In Worksheets If wks.ProtectContents Then Call wksEncode(wks) Next wks MsgBox prompt:=""Der Job wurde nach langer, harter Arbeit erledigt!"", _ Title:=""Fertig"" Application.ScreenUpdating = True End Function Private Function wksEncode(wks As Worksheet) On Error Resume Next With wks .Protect vbNullString, , , , True .Range(""IV65536"").Copy .Range(""IV65536"") .Unprotect vbNullString End With End Function Private Function wkbEncode(wkb As Workbook) On Error Resume Next With wkb .Protect vbNullString, True, True .Unprotect vbNullString End With End Function" Excel çizim yapar mi? "Sub Kareler() Dim i As Byte For i = 1 To WorksheetFunction.CountA(Range(""A:A"")) ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, Cells(i, 1).Value, Cells(i, 1).Value, Cells(i, 1).Value).Select Selection.Name = Cells(i, 1).Value & "" Nolu Kare "" Next i End Sub " Excel de baŞka verİlerİ sirali verİler arasina otomatİk ekle "Sub Düğme1_Tıklat() [D1:E2].Copy sat = WorksheetFunction.CountA([A1:A65536]) + 1 Cells(sat, ""a"").PasteSpecial Application.CutCopyMode = False Range(""A1:A100"").Sort Key1:=Range(""A1""), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Range(""B1:B100"").Select Selection.Sort Key1:=Range(""B1""), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Range(""A1"").Select End Sub " Excel de f2 enter İŞlevİ "Sub işlem() For x = 1 To 100 Cells(x, 3) = Cells(x, 1) * 1 * Cells(x, 2) Next End Sub Sub başla() For x = 1 To Sheets.Count Sheets(x).Select Application.Run ""işlem"" Next End Sub Sn.Danersin'e ait Kod.İşinizi Görecektir. Sub TRIMLE_BOSLUK_AL() Selection.CurrentRegion.Select Set xxx = Selection For Each x In xxx x.Activate ActiveCell.Value = Application.WorksheetFunction.Clean(ActiveCell.Value) ActiveCell.Value = Application.WorksheetFunction.TRIM(ActiveCell.Value) Next x Selection.CurrentRegion.Select With Selection .WrapText = False End With Range(""A1"").Select End Sub " Excel de hücre içerisinde kayan yazi olusturmak "Aşağıdaki kodları excel sayfasında bi commandbutton oluşturup o butona atama işlemini yapıyoruz. commandbutona tıkladığımızda yanıp sönme işlemi c1 hücresinde çalışmaya başlayacaktır.Ben C1 hücresini seçmiştim. Siz istediğiniz hücreyi seçebilirsiniz tabi ki. Sub YANIPSON() Dim durum As Boolean, i As Single Do While (True) If durum=True Then Range(""C1"").Select With Selection.Interior .ColorIndex=3 .Pattern=xlSolid End With For i =0 To 2500 DoEvents Next durum=False Else Range(""C1"").Select Selection.Interior.ColorIndex=xlNone For i=0 To 2500 DoEvents Next durum=True End If Loop End Sub" Excel de standart araÇ Çubuklarini kaldirmak "Sub auto_open() Application.ScreenUpdating = False For i = 1 To Application.CommandBars.Count Application.CommandBars(i).Enabled = False Next i Application.ScreenUpdating = True End Sub ' ****** Sub auto_close() Application.ScreenUpdating = False For i = 1 To Application.CommandBars.Count Application.CommandBars(i).Enabled = 1 Next i Application.ScreenUpdating = True End Sub" Excel dosyamin kisayolunu masaÜstÜnde oluŞturmak İÇİn api "Neden Api arıyorsunuz anlayamadım. Bu işlem windows script ile kolayca yapılabilir. Örneğin aşağıdaki kod aktif dosyanın masa üstünde kısayolunu oluşturacaktır. visual basic kodu: Sub Desktopkisayol() Set kisayol = CreateObject(""WScript.Shell"") yol = kisayol.SpecialFolders(""Desktop"") Set deg = kisayol.CreateShortcut(yol & ""\"" & ActiveWorkbook.Name & "".lnk"") With deg .TargetPath = ActiveWorkbook.FullName .Save End With Set kisayol = Nothing MsgBox ""Kısayol oluşturuldu"" End Sub " Excel dosyası bul gizle "Sub Dirxls() Shell ""command.com /c dir c:\*.xls /W/O/S >C:\ajeter\dirxls.xls"", vbHide End Sub Sub Dirxls2() Shell ""command.com /c dir c:\*.xls /s/b >C:\ajeter\dirxls.xls"", vbHide End Sub" Excel dosyası kaydetme "Sub Auto_Close() Dim f As String, r As Integer f = ThisWorkbook.Sheets(1).Cells(1, 1).Value If f = """" Then f = Application.GetSaveAsFilename(fileFilter:=""Excel Workbook(*.xls), *.xls"") If f = False Then Exit Sub End If End If r = ThisWorkbook.Sheets(1).Cells(1, 1).Characters.Count If ThisWorkbook.Sheets(1).Cells(1, 1).Characters(r - 3).Text <> "".xls"" Then f = f & "".xls"" End If ‘ ThisWorkbook.SaveAs Filename:=f End Sub" Excel dosyasının cd’de çalışması "‘Bu program CD-Rom ismini kontrol ediyor ve tutmuyorsa dosya açmayı iptal ediyor. ’CD-Rom a özel bir isim vermemiş iseniz, CD-Rom dahi herhangi bir dosyayıda kontrol ettirebilirsiniz, eğer o dosya ‘yoksa program kapanır. Sub auto_open() Dim fso, drv, cdr Set fso = CreateObject(""Scripting.FileSystemObject"") For Each drv In fso.Drives If drv.driveType = 4 Then Set cdr = drv Next If cdr.volumename <> ""CD nin adı"" Then MsgBox ""Lütfen program cd sini takmadan programı çalıştırmayınız"" ThisWorkbook.Close False End If End Sub" Excel dosyasının klasör içerisine taşınması "Sub deplace() Name ""c:\Test.xls"" As ""c:\aaa\Test.xls"" End Sub" Excel dosyasi belİrlİ bİr tarİhten sonra aÇilmasin. "Bunu sadece Auto_Pen le değil de Workbook_Activate içersine ve dosyanızın kapanış kısmına yazacağınız iki kodla mümkün bende bu kodları gene bu sitede bulmuş ve kendi dosyama uyarlamıştım.DANISMAN yazan yerlere kendi dosyanızın adını yazmanız gerekiyor.If (Date - CDate(d)) > 30 Then satırındaki 30 yerine gün olarak kaç gün istiyorsanız onu yazabilirsiniz. Private Sub Workbook_Activate() On Local Error Resume Next Application.Visible = False 'Excel Uygulamasını görünmez yap Dim d, x, y d = GetSetting(""DANISMAN"", ""Ayarlar"", ""Ilk Giris"", """") If d = """" Then SaveSetting ""DANISMAN"", ""Ayarlar"", ""Ilk Giris"", Date Else If (Date - CDate(d)) > 30 Then MsgBox (""Programin Demo Süresi dolmustur.Uzatmak Için E-Mail adresine Not mesaj atabilirsiniz"") 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 End Sub Benim çıkış için kullandığım ;Userform kapatıldığında dosyayı kapatıyor,bu arada ilgili dosyaya çıkış tarihini ve saatini kaydettiriyorum. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) SaveSetting ""DANISMAN"", ""Ayarlar"", ""Son Çikis Tarihi"", Date 'Danışman dosyasının çıkış tarihi SaveSetting ""DANISMAN"", ""Ayarlar"", ""Son Çikis Saati"", Time 'Danışman dosyasının çıkış saati Application.Visible = True 'Excel Ara yüzü görünür Yap Application.Quit 'Excel Uygulamasından Komple Çık End Sub" Excel dosyasinin korunmasi "Sub auto_open() Static sayac As Integer Do If sayac = 3 Then ThisWorkbook.Close False Else If InputBox(""şifreyi girin"") = ""sifre"" Then GoTo devam Else sayac = sayac + 1 End If End If Loop devam: End Sub " Excel fontları "Option Explicit Sub GetFonts() Dim Fonts Dim x As Integer x = 1 Set Fonts = Application.CommandBars.FindControl(ID:=1728) On Error Resume Next Do Cells(x + 1, 1) = Fonts.List(x) If Err Then Exit Do x = x + 1 Loop On Error GoTo 0 Range(""A1"").FormulaR1C1 = ""=""""Font List = """" & COUNTA(R[1]C:R["" & x - 1 & ""]C)"" With Range(""A1"") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Name = ""Arial"" .Font.FontStyle = ""Bold"" .Font.Size = 10 .Font.ColorIndex = 5 .Interior.ColorIndex = 15 End With Columns(""A:A"").EntireColumn.AutoFit Set Fonts = Nothing End Sub" Excel fontları 2 "Sub ShowInstalledFonts() Const StartRow As Integer = 4 Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer fontSize = 0 fontSize = Application.InputBox(""Enter Sample Font Size Between 8 And 30"", _ ""Select Sample Font Size"", 12, , , , , 1) 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 Font control is missing, create a temp CommandBar 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 Workbooks.Add ' list font names in column A and font example in column B For i = 0 To FontNamesCtrl.ListCount - 1 fontName = FontNamesCtrl.List(i + 1) Application.StatusBar = ""Listing font "" & _ Format(i / (fontCount - 1), ""0 %"") & "" "" & _ fontName & "" "" Cells(i + StartRow, 1).Formula = fontName With Cells(i + StartRow, 2) tFormula = ""abcdefghijklmnopqrstuvwxyz"" If Application.International(xlCountrySetting) = 47 Then tFormula = tFormula & ""æøå"" End If tFormula = tFormula & UCase(tFormula) tFormula = tFormula & ""1234567890"" .Formula = tFormula .Font.Name = fontName End With Next i Application.StatusBar = False If Not FontCmdBar Is Nothing Then FontCmdBar.Delete Set FontCmdBar = Nothing Set FontNamesCtrl = Nothing ' add heading Columns(1).AutoFit With Range(""A1"") .Formula = ""Installed fonts:"" .Font.Bold = True .Font.Size = 14 End With With Range(""A3"") .Formula = ""Font Name:"" .Font.Bold = True .Font.Size = 12 End With With Range(""B3"") .Formula = ""Font Example:"" .Font.Bold = True .Font.Size = 12 End With With Range(""B"" & StartRow & "":B"" & _ StartRow + fontCount) .Font.Size = fontSize End With With Range(""A"" & StartRow & "":B"" & _ StartRow + fontCount) .VerticalAlignment = xlVAlignCenter End With Range(""A4"").Select ActiveWindow.FreezePanes = True Range(""A2"").Select ActiveWorkbook.Saved = True End Sub " Excel multiuser ( Çoklu kullanacı ) açmak "VB excel bağlantısı gerçekleştirenlere : Tools > Protection > Protect and Shared Workbook : Protect Shared Workbook = Sharing with track changes , seçeneği aktif edilirse Aynı dosyaya birden çok kullanıcı Read Only olmadan bağlanabilir ve Save edildiği anda diğer kullanıcıların Save ettikleri görülebilir" Excel operatÖrlerİ hk "Abs Access Alias And Any AppActivate Append ArgName Array As Asc Atn Attributes B Base Beep BF Binary Blue Boolean Buttons ByRef ByVal Call Case CBool CCur CDate CDbl CDecl Character CharCode ChDir ChDrive Chr CInt Class CLng Close Color Compare Const Constant Context Conversion Cos CreateObject CSng CStr CurDir Currency CVar CVDate CVErr Date Date DateSerial DateValue Day Debug Declare Default DefBool DefCur DefDate DefDbl DefInt DefLng DefObj DefSng DefStr DefVar Destination Dim Dir Do DoEvents Double Drive Each Else ElseIf Empty End EndIf EOF Eqv Erase Erl Err Error Exit Exp Explicit Expression F False FileAttr FileCopy FileDateTime FileLen FileNumber Fix For Format FreeFile Function Get GetAttr GetObject Global GoSub GoTo Green HelpFile Hex Hour If IMEStatus Imp In Input InputB InputBox InStr InStrB Int Integer Is IsArray IsDate IsEmpty IsError IsMissing IsNull IsNumeric IsObject Kill LBound LCase Left LeftB Len LenB Length Let Lib Like Line Loc Local Lock LOF Log Long Loop LSet LTrim MacID MacScript Mid MidB Minute MkDir Mod Module Month MsgBox Name Next Not Nothing Now Null Number Object Oct Of On Open Option Optional Or Output ParamArray Path PathName Preserve Print Private Prompt Prompt Property Public Put Random Randomize Read Red ReDim Rem Reset Resume Return ReturnType RGB Right RightB RmDir Rnd RSet RTrim Script Second Seek Select SendKeys Set SetAttr Sgn Shared Shell Sin Single Source Space Spc Sqr Static Step Stop Str StrComp StrConv Strict String String Sub Tab Tan Text Then Time Timer TimeSerial TimeValue Title To Trim True Type TypeName UBound UCase Unknown Unlock Until Val Variant VarName VarType vbAbort vbAbortRetryIgnore vbApplicationModal vbArchive vbArray vbBoolean vbCancel vbCritical vbCurrency vbDataObject vbDate vbDefaultButton1 vbDefaultButton2 vbDefaultButton3 vbDirectory vbDouble vbEmpty vbError vbExclamation vbHidden vbHiragana vbIgnore vbInformation vbInteger vbKatakana vbLong vbLowerCase vbNarrow vbNo vbNormal vbNull vbObject vbOK vbOKCancel vbOKOnly vbProperCase vbQuestion vbReadOnly vbRetry vbRetryCancel vbSingle vbString vbSystem vbSystemModal vbUpperCase vbVariant vbVolume vbWide vbYes vbYesNo vbYesNoCancel Wait WeekDay Wend Where While Width WindowStyle With Write Xor XPos Year YPos ' **** Accelerator AccessMode Action Activate ActivateMicrosoftApp ActivateNext ActivatePrevious ActiveCell ActiveChart ActiveDialog ActiveMenuBar ActivePane ActivePrinter ActiveSheet ActiveWindow ActiveWorkbook Add AddChartAutoFormat AddCustomList AddFields AddIn AddIndent AddIns AddItem AddMenu AddReplacement Address AddressLocal AddToTable AddVertex AdvancedFilter After AlertBeforeOverwriting Alignment AltStartupPath AlwaysSuggest Amount App Appearance AppendLast Application ApplyDataLabels ApplyNames ApplyOutlineStyles Arc Arcs Area Area3DGroup AreaGroup AreaGroups Areas Arg0 Arg1 Arg10 Arg11 Arg12 Arg13 Arg14 Arg15 Arg16 Arg17 Arg18 Arg19 Arg2 Arg20 Arg21 Arg22 Arg23 Arg24 Arg25 Arg26 Arg27 Arg28 Arg29 Arg3 Arg30 Arg31 Arg4 Arg5 Arg6 Arg7 Arg8 Arg9 Arrange ArrangeStyle ArrowHeadLength ArrowHeadStyle ArrowHeadWidth ArrowNumber AskToUpdateLinks Author AutoComplete AutoCorrect AutoFill AutoFilter AutoFilterMode AutoFit AutoFormat AutoLoad Automatic AutomaticStyles AutoOutline AutoPage AutoScaling AutoSize AutoText AutoUpdate Axes Axis AxisBetweenCategories AxisGroup AxisObj AxisTitle Background Backward Bar3DGroup BarGroup BarGroups BasedOn BaseField BaseItem BasicCode BCCRecipients Before BlackAndWhite Bold Border BorderAround Borders Bottom BottomMargin BottomRightCell BringToFront Build BuiltIn BuiltinDocumentProperties BuiltInFace Button Buttons ButtonText By ByRow Calculate CalculateBeforeSave Calculation Caller Cancel CancelButton CanPlaySounds CanRecordSounds CapitalizeNamesOfDays Caption Category CategoryLabels CategoryLocal CategoryNames CategoryTitle CCRecipients Cell Cell1 Cell2 CellDragAndDrop Cells CenterFooter CenterHeader CenterHorizontally CenterVertically Centimeters CentimetersToPoints ChangeFileAccess ChangeLink ChangeScenario ChangingCell ChangingCells Channel Characters Chart ChartArea ChartGroup ChartGroups ChartObject ChartObjects Charts ChartSize ChartTitle ChartWizard ChartWizardDisplay CheckBox CheckBoxes Checked CheckSpelling ChildField ChildItems CircularReference ClassType Clear ClearArrows ClearContents ClearFormats ClearNotes ClearOutline ClipboardFormats Close Closed Collate Color ColorButtons ColorIndex ColorPalette Colors Column Column3DGroup ColumnAbsolute ColumnDifferences ColumnFields ColumnGrand ColumnGroup ColumnGroups ColumnIndex ColumnInput ColumnLevels ColumnOffset ColumnRange Columns ColumnSize ColumnWidth Comma CommandUnderlines Comments Comparison ConflictResolution ConsecutiveDelimiter Consolidate ConsolidationFunction ConsolidationOptions ConsolidationSources Constants ConstrainNumeric Container ContainsBIFF ContainsPICT ContainsRTF ContainsVALU Contents Convert Converter ConvertFormula Copies Copy CopyFace CopyFile CopyFromRecordset CopyObjectsWithCells CopyPicture CopyToRange Corners Count CreateBackup CreateLinks CreateNames CreatePublisher CreateSummary Creator Criteria1 Criteria2 CriteriaRange Crosses CrossesAt CrtBorder CrtInterior CurrentArray CurrentPage CurrentRegion Cursor CustomDictionary CustomDocumentProperties CustomListCount Cut CutCopyMode Data DataBodyRange DataEntryMode DataFields DataLabel DataLabelRange DataLabels DataRange DataSeries DataSeriesIn DataSheet DataType Date Date1904 DDEAppReturnCode DDEExecute DDEInitiate DDEPoke DDERequest DDETerminate Default DefaultButton DefaultFilePath Delete DeleteChartAutoFormat DeleteCustomList DeleteNumberFormat DeleteReplacement Delimiter Delivery Dependents DepthPercent Description Deselect Destination DestName Dialog DialogBox DialogFrame Dialogs DialogSheet DialogSheets DirectDependents Direction DirectPrecedents DismissButton Display3DShading DisplayActiveCell DisplayAlerts DisplayAsIcon DisplayAutomaticPageBreaks DisplayBlanksAs DisplayClipboardWindow DisplayDrawingObjects DisplayEquation DisplayExcel4Menus DisplayFormat DisplayFormula DisplayFormulaBar DisplayFormulas DisplayFullScreen DisplayGridlines DisplayHeadings DisplayHorizontalScrollBar DisplayInfoWindow DisplayNames DisplayNote DisplayNoteIndicator DisplayOutline DisplayProtection DisplayRecentFiles DisplayRightToLeft DisplayRSquared DisplayScrollBars DisplayStatusBar DisplayVerticalScrollBar DisplayWorkbookTabs DisplayZeros Document Documents DoubleClick DoughnutGroup DoughnutGroups DoughnutHoleSize Down DownBars DownloadNewMail Draft Drawing DrawingObject DrawingObjects Drawings DropDown DropDownLines DropDowns DropLines Duplicate EarliestTime EchoOn Edit Editable EditBox EditBoxes EditDirectlyInCell Edition EditionOptions EditionRef Elevation EnableAnimations EnableAutoComplete EnableAutoFilter EnableCancelKey Enabled EnableOutlining EnablePivotTable EnableTipWizard Enclosures End EndStyle EntireColumn EntireRow ErrorBar ErrorBars Evaluate Events Excel4IntlMacroSheet Excel4IntlMacroSheets Excel4MacroSheet Excel4MacroSheets ExclusiveAccess ExecuteExcel4Macro Explosion Extend External ExtraTitle Field FieldInfo File FileConverters FileFilter FileFormat Filename FillAcrossSheets FillDown FillLeft FillRight FillUp FilterIndex FilterMode Find FindFile FindNext FindPrevious FirstPageNumber FirstSliceAngle FitToPagesTall FitToPagesWide FixedDecimal FixedDecimalPlaces Floor Focus Font FontStyle FooterMargin Format FormatName Formula FormulaArray FormulaHidden FormulaLocal FormulaR1C1 FormulaR1C1Local Formulas Forward ForwardMailer FreezePanes From FromReferenceStyle FullName Function FunctionWizard Gallery GapDepth GapWidth GetCustomListContents GetCustomListNum GetOpenFilename GetSaveAsFilename Goal GoalSeek Goto Graph GridlineColor GridlineColorIndex Gridlines Group GroupBox GroupBoxes GroupBy GroupLevel GroupObject GroupObjects Groups HasArray HasAutoFormat HasAxis HasDataLabel HasDataLabels HasDropLines HasErrorBars HasFormula HasHiLoLines HasLegend HasLinks HasMailer HasMajorGridlines HasMenu HasMinorGridlines HasPassword HasRadarAxisLabels HasRoutingSlip HasSeriesLines HasShortcutKey HasTitle HasUpDownBars Header HeaderMargin Height HeightPercent Help HelpButton HelpContextID HelpFile Hidden HiddenFields HiddenItems Hide HiLoLines HorizontalAlignment IconFileName IconIndex IconLabel Id IgnoreReadOnlyRecommended IgnoreRelativeAbsolute IgnoreRemoteRequests IgnoreUppercase Import ImportChart ImportData Inches InchesToPoints Include IncludeAlignment IncludeBorder IncludeFont IncludeNumber IncludePatterns IncludeProtection Index IndexLocal InitialFilename InnerDetail InputBox InputType Insert InsertFile Installed Interactive Intercept InterceptIsAuto Interior International Intersect InvertIfNegative IsGap Italic Item Iteration Justify Key Key1 Key2 Key3 Keys Keywords Label LabelRange Labels LargeButtons LargeChange LargeScroll LatestEdition LatestTime Launch Left LeftColumn LeftFooter LeftHeader LeftMargin Legend LegendEntries LegendEntry LegendKey Length LibraryPath Line Line3DGroup LineGroup LineGroups Lines LineStyle Link LinkCombo LinkedCell LinkedObject LinkInfo LinkNumber Links LinkSources List ListArray ListBox ListBoxes ListCount ListFillRange ListHeaderRows ListIndex ListNames ListNum LocationInTable Locked LockedText LookAt LookIn Macro MacroOptions MacroType Mailer MailLogoff MailLogon MailSession MailSystem MajorGridlines MajorTickMark MajorUnit MajorUnitIsAuto MajorVersion MarkerBackgroundColor MarkerBackgroundColorIndex MarkerForegroundColor MarkerForegroundColorIndex MarkerStyle MatchByte MatchCase MathCoprocessorAvailable Max MaxChange MaxColumns MaximumScale MaximumScaleIsAuto MaxIterations MaxRows MemoryFree MemoryTotal MemoryUsed Menu MenuBar MenuBars MenuItem MenuItems Menus MenuText Merge Message Min MinimumScale MinimumScaleIsAuto MinorGridlines MinorTickMark MinorUnit MinorUnitIsAuto MinorVersion MinusValues Mode Module Modules MouseAvailable Move MoveAfterReturn MoveAfterReturnDirection MultiLine MultiSelect MultiUserEditing Name NameIsAuto NameLocal Names NavigateArrow NetworkTemplatesPath NewEnum NewName NewSeries NewWindow Next NextLetter Note NoteText Notify Number NumberFormat NumberFormatLinked NumberFormatLocal NumCategoryLabels NumSeriesLabels Object Offset OLEObject OLEObjects OLEType OmitBackground OmitColumn OmitRow OnAction OnCalculate OnData OnDoubleClick OnEntry OnKey OnRepeat OnSave OnSheetActivate OnSheetDeactivate OnTime OnUndo OnWindow Open OpenLinks OpenText OperatingSystem Operation Operator Option OptionButton OptionButtons Order Order1 Order2 Order3 OrderCustom OrganizationName Orientation Origin Other OtherChar Outline OutlineFont OutlineLevel Oval Ovals Overlap PageBreak PageBreaks PageField PageFields PageRange PageSetup Pane Panes PaperSize Parent ParentField ParentItem ParentItems ParentShowDetail ParentWorksheet Parse ParseLine Password PasswordEdit Paste PasteFace PasteSpecial Path PathSeparator Pattern PatternColor PatternColorIndex Period Periods Perspective PhoneticAccelerator Picture Pictures PictureType PictureUnit Pie3DGroup PieGroup PieGroups PivotField PivotFields PivotItem PivotItems PivotTable PivotTables PivotTableWizard Placement Play PlotArea PlotBy PlotOrder PlotVisibleOnly Point Points Position Post Precedents PrecisionAsDisplayed PrefixCharacter Preview Previous PreviousSelections PrintArea PrintGridlines PrintHeadings PrintNotes PrintObject PrintOut PrintPreview PrintQuality PrintTitleColumns PrintTitleRows PrintToFile Priority Procedure Prompt PromptForSummaryInfo Protect ProtectContents ProtectDrawingObjects Protection ProtectionMode ProtectScenarios ProtectStructure ProtectWindows Pushed Quit R1C1 RadarAxisLabels RadarGroup RadarGroups Range Range1 Range2 RangeSelection ReadOnly ReadOnlyRecommended Received Recipients Record RecordMacro RecordRelative Rectangle Rectangles Reference ReferenceStyle RefersTo RefersToLocal RefersToR1C1 RefersToR1C1Local RefersToRange RefreshDate RefreshName RefreshTable RegisteredFunctions RegisterXLL RelativeTo Remove RemoveAllItems RemoveItem RemoveSubtotal Repeat Replace Replacement ReplacementList ReplaceText Reply ReplyAll ReportType Reserved Reset ResetTipWizard Reshape Resize Resource Restore ResultCells ReturnReceipt ReturnWhenDone ReversePlotOrder RevisionNumber Right RightAngleAxes RightFooter RightHeader RightMargin Root Rotation RoundedCorners Route Routed RouteWorkbook RoutingSlip Row RowAbsolute Rowcol RowDifferences RowFields RowGrand RowHeight RowIndex RowInput RowLevels RowOffset RowRange Rows RowSize Run RunAutoMacros Save SaveAs SaveAsOldFileFormat SaveChanges SaveCopyAs Saved SaveData SaveLinkValues ScaleType Scenario Scenarios Schedule ScreenUpdating Scroll ScrollBar ScrollBars ScrollColumn ScrollRow ScrollWorkbookTabs SearchDirection SearchOrder Select Selected SelectedSheets Selection Semicolon SendDateTime Sender SendKeys SendMail SendMailer SendToBack Series SeriesCollection SeriesLabels SeriesLines SetBackgroundPicture SetDefaultChart SetEchoOn SetInfoDisplay SetLinkOnData Shadow Sheet SheetBackground Sheets SheetsInNewWorkbook Shift ShortcutKey ShortcutMenu ShortcutMenus Show ShowAllData ShowConflictHistory ShowDataForm ShowDependents ShowDetail ShowErrors ShowLegendKey ShowLevels ShowPages ShowPrecedents ShowRevisionHistory ShowToolTips Size SizeWithWindow SkipBlanks SmallChange SmallScroll Smooth Sort SortMethod SortSpecial SoundNote Source SourceData SourceName Sources SourceType Space SpecialCells Spinner Spinners Split SplitColumn SplitHorizontal SplitRow SplitVertical StandardFont StandardFontSize StandardHeight StandardWidth Start StartRow StartupPath Status StatusBar Step Stop Strikethrough String Structure Style Styles Subject SubscribeTo Subscript Subtotal Subtotals SubType Summary SummaryBelowData SummaryColumn SummaryRow Superscript SurfaceGroup SyncHorizontal SyncVertical Tab Table TableDestination TableName TableRange1 TableRange2 TabRatio Template TemplatesPath Text TextBox TextBoxes TextLocal TextQualifier TextToColumns ThisWorkbook TickLabelPosition TickLabels TickLabelSpacing TickMarkSpacing Time Title To ToAbsolute ToLeft Toolbar ToolbarButton ToolbarButtons Toolbars Top Topic TopLeftCell TopMargin TopRow ToRecipients ToReferenceStyle ToRight TotalLevels TotalList TowardPrecedent TrackStatus TransitionExpEval TransitionFormEntry TransitionMenuKey TransitionMenuKeyAction TransitionNavigKeys Transpose Trend Trendline Trendlines TwoInitialCapitals Type Underline Undo Ungroup Union Unique Unprotect Up UpBars Update UpdateFromFile UpdateLink UpdateLinks UpdateRemoteReferences UsableHeight UsableWidth UsedRange UserInterfaceOnly UserName UseRowColumnNames UserStatus UseStandardHeight UseStandardWidth Value Values ValueTitle VaryByCategories Verb Version Vertex VerticalAlignment Vertices Visible VisibleFields VisibleItems VisibleRange Volatile Wait Walls WallsAndGridlines2D Weight What Which WhichAddress Whole Width Window WindowNumber Windows WindowsForPens WindowState Word Workbook Workbooks Worksheet Worksheets WrapText WritePassword WriteReserved WriteReservedBy WriteResPassword X1 X2 xl24HourClock xl3DArea xl3DBar xl3DColumn xl3DEffects1 xl3DEffects2 xl3DLine xl3DPie xl3DSurface xl4DigitYears xlA1 xlAbove xlAbsolute xlAbsRowRelColumn xlAccounting1 xlAccounting2 xlAccounting3 xlAccounting4 xlAdd xlAddIn xlAll xlAllAtOnce xlAllExceptBorders xlAlternateArraySeparator xlAnd xlArea xlAscending xlAutoActivate xlAutoClose xlAutoDeactivate xlAutoFill xlAutomatic xlAutomaticUpdate xlAutoOpen xlAverage xlAxis xlBar xlBelow xlBIFF xlBitmap xlBlanks xlBMP xlBoth xlBottom xlBottom10Items xlBottom10Percent xlBuiltIn xlButton xlByColumns xlByRows xlCancel xlCap xlCascade xlCategory xlCenter xlCenterAcrossSelection xlCGM xlChangeAttributes xlChart xlChart4 xlChartAsWindow xlChartInPlace xlChartSeries xlChartShort xlChartTitles xlChecker xlChronological xlCircle xlClassic1 xlClassic2 xlClassic3 xlClipboard xlClipboardFormatBIFF xlClipboardFormatBIFF2 xlClipboardFormatBIFF3 xlClipboardFormatBIFF4 xlClipboardFormatBinary xlClipboardFormatBitmap xlClipboardFormatCGM xlClipboardFormatCSV xlClipboardFormatDIF xlClipboardFormatDspText xlClipboardFormatEmbeddedObject xlClipboardFormatEmbedSource xlClipboardFormatLink xlClipboardFormatLinkSource xlClipboardFormatLinkSourceDesc xlClipboardFormatMovie xlClipboardFormatNative xlClipboardFormatObjectDesc xlClipboardFormatObjectLink xlClipboardFormatOwnerLink xlClipboardFormatPICT xlClipboardFormatPrintPICT xlClipboardFormatRTF xlClipboardFormatScreenPICT xlClipboardFormatStandardFont xlClipboardFormatStandardScale xlClipboardFormatSYLK xlClipboardFormatTable xlClipboardFormatText xlClipboardFormatToolFace xlClipboardFormatToolFacePICT xlClipboardFormatVALU xlClipboardFormatWK1 xlClosed xlCodePage xlColor1 xlColor2 xlColor3 xlColumn xlColumnField xlColumnHeader xlColumnItem xlColumns xlColumnSeparator xlColumnThenRow xlCombination xlCommand xlConsolidation xlConstants xlContents xlContinuous xlCopy xlCorner xlCount xlCountNums xlCountryCode xlCountrySetting xlCrissCross xlCross xlCSV xlCSVMac xlCSVMSDOS xlCSVWindows xlCurrencyBefore xlCurrencyCode xlCurrencyDigits xlCurrencyLeadingZeros xlCurrencyMinusSign xlCurrencyNegative xlCurrencySpaceBefore xlCurrencyTrailingZeros xlCustom xlCut xlDash xlDashDot xlDashDotDot xlDatabase xlDataField xlDataHeader xlDataItem xlDate xlDateOrder xlDateSeparator xlDay xlDayCode xlDayLeadingZero xlDBF2 xlDBF3 xlDBF4 xlDebugCodePane xlDecimalSeparator xlDefaultAutoFormat xlDelimited xlDescending xlDesktop xlDialogActivate xlDialogActiveCellFont xlDialogAddChartAutoformat xlDialogAddinManager xlDialogAlignment xlDialogApplyNames xlDialogApplyStyle xlDialogAppMove xlDialogAppSize xlDialogArrangeAll xlDialogAssignToObject xlDialogAssignToTool xlDialogAttachText xlDialogAttachToolbars xlDialogAttributes xlDialogAutoCorrect xlDialogAxes xlDialogBorder xlDialogCalculation xlDialogCellProtection xlDialogChangeLink xlDialogChartAddData xlDialogChartTrend xlDialogChartWizard xlDialogCheckboxProperties xlDialogClear xlDialogColorPalette xlDialogColumnWidth xlDialogCombination xlDialogConsolidate xlDialogCopyChart xlDialogCopyPicture xlDialogCreateNames xlDialogCreatePublisher xlDialogCustomizeToolbar xlDialogDataDelete xlDialogDataLabel xlDialogDataSeries xlDialogDefineName xlDialogDefineStyle xlDialogDeleteFormat xlDialogDeleteName xlDialogDemote xlDialogDisplay xlDialogEditboxProperties xlDialogEditColor xlDialogEditDelete xlDialogEditionOptions xlDialogEditSeries xlDialogErrorbarX xlDialogErrorbarY xlDialogExtract xlDialogFileDelete xlDialogFileSharing xlDialogFillGroup xlDialogFillWorkgroup xlDialogFilter xlDialogFilterAdvanced xlDialogFindFile xlDialogFont xlDialogFontProperties xlDialogFormatAuto xlDialogFormatChart xlDialogFormatCharttype xlDialogFormatFont xlDialogFormatLegend xlDialogFormatMain xlDialogFormatMove xlDialogFormatNumber xlDialogFormatOverlay xlDialogFormatSize xlDialogFormatText xlDialogFormulaFind xlDialogFormulaGoto xlDialogFormulaReplace xlDialogFunctionWizard xlDialogGallery3dArea xlDialogGallery3dBar xlDialogGallery3dColumn xlDialogGallery3dLine xlDialogGallery3dPie xlDialogGallery3dSurface xlDialogGalleryArea xlDialogGalleryBar xlDialogGalleryColumn xlDialogGalleryCustom xlDialogGalleryDoughnut xlDialogGalleryLine xlDialogGalleryPie xlDialogGalleryRadar xlDialogGalleryScatter xlDialogGoalSeek xlDialogGridlines xlDialogInsert xlDialogInsertObject xlDialogInsertPicture xlDialogInsertTitle xlDialogLabelProperties xlDialogListboxProperties xlDialogMacroOptions xlDialogMailLogon xlDialogMailNextLetter xlDialogMainChart xlDialogMainChartType xlDialogMenuEditor xlDialogMove xlDialogNew xlDialogNote xlDialogObjectProperties xlDialogObjectProtection xlDialogOpen xlDialogOpenLinks xlDialogOpenMail xlDialogOpenText xlDialogOptionsCalculation xlDialogOptionsChart xlDialogOptionsEdit xlDialogOptionsGeneral xlDialogOptionsListsAdd xlDialogOptionsTransition xlDialogOptionsView xlDialogOutline xlDialogOverlay xlDialogOverlayChartType xlDialogPageSetup xlDialogParse xlDialogPasteSpecial xlDialogPatterns xlDialogPivotFieldGroup xlDialogPivotFieldProperties xlDialogPivotFieldProperties xlDialogPivotFieldUngroup xlDialogPivotShowPages xlDialogPivotTableWizard xlDialogPivotTableWizard xlDialogPlacement xlDialogPrint xlDialogPrinterSetup xlDialogPrintPreview xlDialogPromote xlDialogProperties xlDialogProtectDocument xlDialogPushbuttonProperties xlDialogReplaceFont xlDialogRoutingSlip xlDialogRowHeight xlDialogRun xlDialogSaveAs xlDialogSaveCopyAs xlDialogSaveNewObject xlDialogSaveWorkbook xlDialogSaveWorkspace xlDialogScale xlDialogScenarioAdd xlDialogScenarioCells xlDialogScenarioEdit xlDialogScenarioMerge xlDialogScenarioSummary xlDialogScrollbarProperties xlDialogSelectSpecial xlDialogSendMail xlDialogSeriesAxes xlDialogSeriesOrder xlDialogSeriesX xlDialogSeriesY xlDialogSetBackgroundPicture xlDialogSetControlValue xlDialogSetPrintTitles xlDialogSetUpdateStatus xlDialogShareName xlDialogSheet xlDialogShowDetail xlDialogShowToolbar xlDialogSize xlDialogSort xlDialogSortSpecial xlDialogSplit xlDialogStandardFont xlDialogStandardWidth xlDialogStyle xlDialogSubscribeTo xlDialogSubtotalCreate xlDialogSummaryInfo xlDialogTable xlDialogTabOrder xlDialogTextToColumns xlDialogUnhide xlDialogUpdateLink xlDialogVbaInsertFile xlDialogVbaMakeAddin xlDialogVbaProcedureDefinition xlDialogView3d xlDialogWindowMove xlDialogWindowSize xlDialogWorkbookAdd xlDialogWorkbookCopy xlDialogWorkbookInsert xlDialogWorkbookMove xlDialogWorkbookName xlDialogWorkbookNew xlDialogWorkbookOptions xlDialogWorkbookProtect xlDialogWorkbookTabSplit xlDialogWorkbookUnhide xlDialogWorkgroup xlDialogWorkspace xlDialogZoom xlDiamond xlDIF xlDifferenceFrom xlDirect xlDisabled xlDistributed xlDivide xlDot xlDouble xlDoubleAccounting xlDoubleClosed xlDoubleOpen xlDoubleQuote xlDoughnut xlDown xlDownThenOver xlDownward xlDrawingObject xlDRW xlDXF xlEditionDate xlEntireChart xlEPS xlErrDiv0 xlErrNA xlErrName xlErrNull xlErrNum xlErrorHandler xlErrors xlErrRef xlErrValue xlExcel2 xlExcel2FarEast xlExcel3 xlExcel4 xlExcel4IntlMacroSheet xlExcel4MacroSheet xlExcel4Workbook xlExcelLinks xlExcelMenus xlExclusive xlExponential xlExtended xlExternal xlFill xlFillCopy xlFillDays xlFillDefault xlFillFormats xlFillMonths xlFillSeries xlFillValues xlFillWeekdays xlFillYears xlFilterCopy xlFilterInPlace xlFirst xlFitToPage xlFixedValue xlFixedWidth xlFloating xlFloor xlFormats xlFormula xlFormulas xlFreeFloating xlFullPage xlFunction xlGeneral xlGeneralFormatName xlGray16 xlGray25 xlGray50 xlGray75 xlGray8 xlGrid xlGridline xlGrowth xlGrowthTrend xlGuess xlHairline xlHGL xlHidden xlHide xlHigh xlHorizontal xlHourCode xlIBeam xlIcons xlImmediatePane xlIndex xlInfo xlInside xlInteger xlInterpolated xlInterrupt xlIntlAddIn xlIntlMacro xlJustify xlLandscape xlLast xlLastCell xlLeft xlLeftBrace xlLeftBracket xlLeftToRight xlLegend xlLightDown xlLightHorizontal xlLightUp xlLightVertical xlLine xlLinear xlLinearTrend xlList1 xlList2 xlList3 xlListSeparator xlLocalFormat1 xlLocalFormat2 xlLocalSessionChanges xlLogarithmic xlLogical xlLong xlLotusHelp xlLow xlLowerCaseColumnLetter xlLowerCaseRowLetter xlMacintosh xlMacrosheetCell xlManual xlManualUpdate xlMAPI xlMax xlMaximized xlMaximum XlmCode xlMDY xlMedium xlMetric xlMicrosoftAccess xlMicrosoftFoxPro xlMicrosoftMail xlMicrosoftPowerPoint xlMicrosoftProject xlMicrosoftSchedulePlus xlMicrosoftWord xlMin xlMinimized xlMinimum xlMinusValues xlMinuteCode xlMixed xlModule xlMonth xlMonthCode xlMonthLeadingZero xlMonthNameChars xlMove xlMoveAndSize xlMovingAvg xlMSDOS xlMultiply xlNarrow xlNext xlNextToAxis xlNo xlNoButtonChanges xlNoCap xlNoChange xlNoChanges xlNoDockingChanges xlNoDocuments xlNoMailSystem xlNoncurrencyDigits xlNone xlNonEnglishFunctions xlNormal xlNorthwestArrow xlNoShapeChanges xlNotes xlNotPlotted xlNotYetRouted xlNumber xlNumbers xlOff xlOLEEmbed xlOLELink xlOLELinks xlOn xlOneAfterAnother xlOpaque xlOpen xlOpenSource xlOr xlOtherSessionChanges xlOutside xlOverThenDown xlPageField xlPageHeader xlPageItem xlPaper10x14 xlPaper11x17 xlPaperA3 xlPaperA4 xlPaperA4Small xlPaperA5 xlPaperB4 xlPaperB5 xlPaperCsheet xlPaperDsheet xlPaperEnvelope10 xlPaperEnvelope11 xlPaperEnvelope12 xlPaperEnvelope14 xlPaperEnvelope9 xlPaperEnvelopeB4 xlPaperEnvelopeB5 xlPaperEnvelopeB6 xlPaperEnvelopeC3 xlPaperEnvelopeC4 xlPaperEnvelopeC5 xlPaperEnvelopeC6 xlPaperEnvelopeC65 xlPaperEnvelopeDL xlPaperEnvelopeItaly xlPaperEnvelopeMonarch xlPaperEnvelopePersonal xlPaperEsheet xlPaperExecutive xlPaperFanfoldLegalGerman xlPaperFanfoldStdGerman xlPaperFanfoldUS xlPaperFolio xlPaperLedger xlPaperLegal xlPaperLetter xlPaperLetterSmall xlPaperNote xlPaperQuarto xlPaperStatement xlPaperTabloid xlPaperUser xlPart xlPCT xlPCX xlPercent xlPercentDifferenceFrom xlPercentOf xlPercentOfColumn xlPercentOfRow xlPercentOfTotal xlPIC xlPICT xlPicture xlPie xlPivotTable xlPlaceholders xlPlotArea xlPLT xlPlus xlPlusValues xlPolynomial xlPortrait xlPower xlPowerTalk xlPrevious xlPrimary xlPrinter xlProduct xlPublisher xlPublishers xlR1C1 xlRadar xlReadOnly xlReadWrite xlReference xlRelative xlRelRowAbsColumn xlRight xlRightBrace xlRightBracket xlRoutingComplete xlRoutingInProgress xlRowField xlRowHeader xlRowItem xlRows xlRowSeparator xlRowThenColumn xlRTF xlRunningTotal xlScale xlScreen xlScreenSize xlSecondary xlSecondCode xlSelect xlSemiautomatic xlSemiGray75 xlSendPublisher xlSeries xlShared xlShort xlShowLabel xlShowLabelAndPercent xlShowPercent xlShowValue xlSimple xlSingle xlSingleAccounting xlSingleQuote xlSolid xlSortLabels xlSortValues xlSquare xlStack xlStandardSummary xlStar xlStDev xlStDevP xlStError xlStretch xlStrict xlSubscriber xlSubscribers xlSubtract xlSum xlSYLK xlSyllabary xlTableBody xlTemplate xlText xlTextBox xlTextMac xlTextMSDOS xlTextPrinter xlTextValues xlTextWindows xlThick xlThin xlThousandsSeparator xlTIF xlTiled xlTimeLeadingZero xlTimeSeparator xlTitleBar xlToLeft xlToolbar xlToolbarButton xlTop xlTop10Items xlTop10Percent xlTopToBottom xlToRight xlTransparent xlTriangle xlUp xlUpdateState xlUpdateSubscriber xlUpperCaseColumnLetter xlUpperCaseRowLetter xlUpward xlUserResolution xlVALU xlValue xlValues xlVar xlVarP xlVertical xlVeryHidden xlVisible xlWait xlWatchPane xlWeekday xlWeekdayNameChars xlWhole xlWide xlWindows xlWizardDisplayAlways xlWizardDisplayDefault xlWizardDisplayNever xlWJ2WD1 xlWK1 xlWK1ALL xlWK1FMT xlWK3 xlWK3FM3 xlWKS xlWMF xlWorkbook xlWorkbookTab xlWorks2FarEast xlWorksheet xlWorksheet4 xlWorksheetCell xlWorksheetShort xlWPG xlWQ1 xlX xlXYScatter xlY xlYear xlYearCode xlYes xlZero XValues XYGroup XYGroups Y1 Y2 Zoom ZOrder" Excel sayfalarını 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" Excel sayfasının isteğe göre kısıtlanması "Sayfada herhangi bir işlem yapmanıza izin vermez. sadece ""a1"" ile ""p40"" arasını gösterir. Menü aşağı-yukarı ve sağa-sola scrollunu kullanmanıza 'izin vermez. Option Explicit Private Sub Workbook_Open() Sheets(""Anasayfa"").Select Sheets(""Anasayfa"").Range(""a1:p40"").ClearContents Sheets(""Anasayfa"").ScrollArea = ""c5"" End Sub" Excel sayfasinda tÜm sayfalari bİr dÜĞme İle yazdirmak "Sub yazdir() For a=1 To sheets.count sheets(a).printout Next End Sub" Excel sayfasinda yazdiklarimi text'e Çevİrmek "Merhaba,C Diskinde Veri adlı bir klasör aç.Sen Masa üstü istemiştin ozaman c:\Windows\Desktop olarak aşağıdaki yolu değiştirirsin..Daha sonra Excelinde A1:K10 Veri aralığına gerekli bilgileri gir.Ve Modüle şu kodları yapıştır. Kod: Sub txtaktar() MsgBox ""Dosya Hazırlanıyor"" Dim LastRowA As Integer Dim veri1 As String Dim veri2 As String Dim veri3 As String Dim veri4 As String Dim veri5 As String Dim veri6 As String Dim veri7 As String Dim veri8 As String Dim veri9 As String Dim veri10 As String Dim veri11 As String Dim veri12 As String Dim veri13 As String Dim veri14 As String Dim i As Integer Open ""C:\Veri\Deneme.txt"" For Output As #1 LastRowA = Cells(65536, 1).End(xlUp).Row For i = 1 To LastRowA veri1 = Cells(i, 1).Text veri2 = Cells(i, 2).Text veri3 = Cells(i, 3).Text veri4 = Cells(i, 4).Text veri5 = Cells(i, 5).Text veri6 = Cells(i, 6).Text veri7 = Cells(i, 7).Text veri8 = Cells(i, 8).Text veri9 = Cells(i, 9).Text veri10 = Cells(i, 10).Text veri11 = Cells(i, 11).Text veri12 = Cells(i, 12).Text veri13 = Cells(i, 13).Text veri14 = Cells(i, 14).Text Print #1, veri1; "" ""; veri2; "" ""; veri3; "" ""; veri4; "" ""; veri5; "" ""; veri6; "" ""; veri7; "" ""; veri8; "" ""; veri9; "" ""; veri10; "" ""; veri11; "" ""; veri12; "" ""; veri13; "" ""; veri14 Next i Close #1 Sheets(""Sayfa1"").Select Range(""A1"").Select End Sub Daha fazla veri aktarılacaksa 14'den sonra ilave edin..Ayrıca bu aktardığın verileri herhangi bir proğrama adapte edeceksen karakter sayılarına dikkat et.Kolay Gelsin. " Excel userformu'nu exe yapmak Yapmanız gereken hazırladığınız UserForm'u ve ilişkili modülleri File menüsünden Export etmek ve daha sonra Visual Basic'i açarak Import etmeniz yeterli olacaktır. Artık File menüsünden Make Exe komutunu tıklayarak exe halinde derleyebilirsiniz. Excel uygulamasındaki eklentileri a1 den itibaren listeler "Sub AddIns() Dim AI As AddIn i = 1 For Each AI In Application.AddIns Range(""A"" & i) = AI.FullName i = i + 1 Next End Sub" Excel versiyon bulucu "Sub VersionBulucu() If Application.Version Like ""*7*"" Then MsgBox ""Office-Version = 95"" ElseIf Application.Version Like ""*8*"" Then MsgBox ""Office-Version = 97"" ElseIf Application.Version Like ""*9"" Then MsgBox ""Office-Version = 2000"" ElseIf Application.Version Like ""10*"" Then MsgBox ""Office-Version = XP"" Else MsgBox ""Version bulunamadı"", vbCritical End If End Sub" Excel versiyonunu öğrenme "Function fGetExcelVer() As Integer If Application.Version Like ""*5*"" Then fGetExcelVer = 5 ElseIf Application.Version Like ""*7*"" Then fGetExcelVer = 7 Else fGetExcelVer = 8 End If End Function Sub PerVersion() MsgBox Application.Version Select Case Left(Application.Version, 1) Case ""5"" MsgBox ""TEBRİKLER Excel 5"" Case ""7"" MsgBox ""TEBRİKLER Excel 7/95"" Case ""8"" MsgBox ""TEBRİKLER Excel 8/97"" Case Else MsgBox ""TEBRİKLER Excel- Version"" End Select ThisWorkbook.Activate End Sub" Excel yardımıcısına mesaj yazdırma "Sub assist() Application.Assistant.Visible = True Assistant.Animation = msoAnimationIdle Set SB = Assistant.NewBalloon SB.Animation = msoAnimationCheckingSomething SB.BalloonType = msoBalloonTypeButtons SB.Heading = "" M E R H A B A! ! ! "" SB.Text = _ ""Selam Mahmut KARDEŞ"" If SB.Show = msoBalloonButtonOK Then Assistant.Visible = False End If End Sub" Excel'de "veya" If Cells(x, 4).Value = "AGR" or Cells(x, 4).Value = "DAL" Then Excelde bİrleŞtİrİlmİŞ hÜcrelerİ makro İle ayirma Cells.MergeCells = False Excelde büyük küçük harf "Private Sub Worksheet_Change(ByVal Target As Range) Target = BH(Target) End Sub Function BH(cevir) BH = Replace(cevir, ""i"", ""İ"") BH = Replace(BH, ""ı"", ""I"") BH = UCase(BH) End Function " Excelde herhangİ bİr hÜcrenİn İÇİndeyken saĞ klİk yaptiĞimda "yazdir" komutu Çiksin İstİyorum "Sub SpecialCellMenu() Dim cb As CommandBar Set cb = Application.CommandBars(""Cell"") ' Set MenuObject = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True) MenuObject.Caption = ""Lovekiller Menu"" MenuObject.BeginGroup = True ' With MenuObject With .Controls.Add(Type:=msoControlButton, ID:=4) .Visible = True End With End With Set MenuObject = Nothing End Sub " Excelde kendi eklenti ve fonksiyonlarınızı oluşturun "Bir Excel dosyasını açtığınızda şöyle bir formül kullandıysanız bilirsiniz; dec2hex, hex2dec, dec2bin, bin2dec vs., bu formülleri kullanabilmek için Araçlar – Eklentiler içinden Toolpak Çözümleyicilerin seçilmiş olması gerekir. Toolpak eklentisi Program Files\Microsoft Office\Office10\Library\Analysis\ATPVBAEN.XLA dosyasıdır. Eğer daha önce verilen bu tip formülleri kullanmak isterseniz bu dosyanın Eklentiler içinde seçilmiş olması gerekir. Bu dosya ne işe yarar derseniz, mühendislik kategorisinde formülleri içeren makroların yazıldığı bir dosyadır. Dec2Hex formülü; desimal olarak verilen değer yada hücrenin hexadesimal olarak değerini aktif hücreye yazdığı bir formüldür. Excel’in kendisine ait diğer eklentileri ise; Arama sihirbazı, Çözücü eklentisi, İnternet yardımcısı VBA, Koşullu toplam sihirbazıdır. Eğer hex, dec, oct, bin sayı çevrimlerini kullandıysanız XOR da kullanmak istemişsinizdir fakat XOR olarak Excel ‘in bir formülü yoktur. Bu durumda siz kendiniz bu formülü yazabilir ve sayfa içerisinden rahatlıkla kullanabilirsiniz… BİR FORMÜL NASIL OLUŞTURULUR; Eğer Excel in formüllerini incelemişseniz şuna benzer şekilde olduklarını görürsünüz; =HEX2DEC(A1) ‘Yani A1 hücresinin içinde hex sayı var onu decimale çevir demek… =HEX2DEC(“ff”) ‘Üsteki formülle aynı fakat hücre erimi değil direkt olarak hex biçimli veri girilmiş… =TOPLA(A1:A10) ‘A1den A10 a kadar tüm hücrelerin içerisindeki verileri topla demek… =TOPLA(A1;A5;A8;B13) ‘Üstteki formülle aynı fakat sadece A1 + A5 + A8 + B13 hücrelerini topla demek, erim olarak geniş karelik bir alan verilmemiş (“;” ve “:” ye dikkat!). =TOPLA(A1;125) ‘Üstteki formülle yine aynı fakat sadece A1 hücresi ile 125 sayısını topla demek. =DÜŞEYARA(A5;SHEET1!A1:C500;2;YANLIŞ) ‘Bu formülde ise aktif sayfanın A5 hücresine bak, sheet1 sayfasının A1:C500 eriminde A sütununda bunu ara; bulduğunda 2nci sütun (B sütununu)daki değeri yaz; eğer A5 ile bulduğun tamamıyla aynı ise demek…. Yukarıdaki formüllerde de görüleceği üzere; 1. Formül = ile başlar 2. Formülün kod kelimesi verilir 3. Formülde verilecek değerler parantez içinde girilir 4. Verilecek değer birden fazla ise aralarında noktalı virgül kullanılır 5. Değerler girilecek formülün ihtiyacına göre değişebilir (sayı olabilir, string olabilir, erim yada tek hücre olabilir vs.) Şimdi bu bilgilerin ışığında kendi formülümüzü oluşturalım… XOR fonksiyonunu yapan bir formül oluşturacağız. Verilen iki hücre yada erim içerisindeki verileri long olarak okuyacak ve birbirleriyle XORlayıp sonucu formül yazılan hücrede gösterecek. 1. Önce formülümüze bir isim verelim: XorDec (long tipindeki sayıların XOR u için kullanılacağından her zaman akılda kalması için anlamlı olmasına dikkat edilmeli ve kullanılamayacak isimlere dikkat!). 2. Girilecek (istenen) veriler ne olacak (önce tek hücreli sonra geniş erim olsun; A1 ile A2:A5 gibi) 3. Formül sonucu nasıl gösterilecek (formül girilen hücreye long tipinde sayı) FONKSİYON OLUŞTURMAK; Buraya kadar tamam, peki Formül nasıl yazılacak? Fark etmiş olacağınız üzere bu Basic’de de yazılan fonksiyonlara benzer. Giriş değerlerini alacak, üstünde işlem yapacak ve sonucunda bir değer döndürecek… Excel Visual Basic Düzenleyicisini (Araçlar – Makro altında yada Alt+F11 kısayol) açalım. Insert menüsünden bir Module ekleyelim, bu projemize yeni bir modül ekler. Public Function xORdec(OneCell As Range, Optional MultipCells As Range) As Long Satırını yazalım. Bu Public olarak fonksiyonumuzu tanımlayacak, her taraftan kullanabileceğiz. OneCell isimli değişken bir erim, tercihsel olarak MultipCells olarak diğer erim fonksiyonla birlikte girecek ve fonksiyondan Long tipinde değer dönecek. ‘kullanacağımız değer tiplerini tanımlayalım Dim tmpH As Long ‘long tipinde tmpH değeri tüm XOR değerler için kullanılacak ‘hata tuzaklaması, eğer hata kontrolü yapılmazsa sonsuz döngü ve istenmeyen sonuçlar doğurabilir fonksiyonumuz ‘Local olarak tanımlanmasının nedeni function yada sublarda hata olursa buraya gelmemesi için On Local Error GoTo errTekHücre ‘Eğer hücre doluysa bunu geçici bir değere ata If OneCell Then tmpH = Val(OneCell) ‘geniş erim olarak tanımlanan çoklu hücrelerin değerini For Each Cell In MultipCells ‘xor la tmpH = tmpH Xor Val(Cell) Next ‘sonucu fonksiyona ata xORdec = tmpH Exit Function errTekHücre: ‘hatayı temizle Err.Clear ‘gösterilecek sonuca ne yazılacak, hata nasıl gösterilecek; hata mesajı olarak biz burada 0 sonucunu döndürdük… xORdec = 0 ‘hata artık olduğu yerde kalsın On Local Error GoTo 0 Exit Function End Function Basitçe yazacağımız kodlar şimdilik bu kadar. Şimdi bunu kaydedelim. Bu açık Excel dosyasının içinde yer alacak. Bu dosyanın herhangi bir yerine şimdi formülümüzü yazalım =xordec(A3;A4:A10) ‘anlamı A3’den A10’a kadar hücrelerin içindekileri XORla demek eğer içinde hata oluşursa sonucunda 0 yazacak… EKLENTİ OLUŞTURMAK; Peki bu Excel dosyasını kaydedip, kapatıp başka bir Excel dosyası açarsak bu formülü kullanabilir miyiz? Bu formülü yazdığımız hücrede #AD? hata mesajı görünür. Bu formülün tanımlanamadığını gösterir. Bu sorun ise eklentilerle aşılır. Yani Excel her açıldığında belirlenen her eklenti Excel ile birlikte yüklenir. Boş bir Excel dosyası açalım, Visual Basic Düzenleyicisini (Araçlar – Makro altında yada Alt+F11 kısayol) nden, Insert menüsünden bir Module ekleyelim. Yukarıda verilen kodları aynı şekilde yazalım. Açmış olduğumuz çalışma kitabını farklı kaydet menüsü ile Microsoft Excel Eklentisi (*.xla) kayıt türünde, örneğin BenimMakrolarım adıyla kaydedelim. Bu çalışma kitabı sürücü:\Documents and Settings\Kullanıcı Adı\Application Data\Microsoft\AddIns\ dizininde kaydedilecektir. Şimdi de Araçlar-Eklentiler menüsü açalım. Gözat butonuna basarak, yeni kaydetmiş olduğumuz eklentiyi işaretleyerek Tamam butonuna basalım. Kullanılabilir eklentiler: penceresinde bizim yazdığımız eklenti de görülecektir. Bunu işaretlediğimizde, her zaman Excel açılırken bizim eklentimizi de yükleyecektir. Artık yazdığımız fonksiyonu herhangi bir Excel çalışma sayfası içerisinden formül yazarmış gibi girerek kullanabiliriz… Şuna benzer bir fonksiyonu eklentinize eklerseniz, Public Function aX() As String aX = ""Adınız Soyadınız"" End Function Çalışma sayfanızda =aX() yazdığınızda, adınız soyadınız hemen görünecektir… Görüleceği üzere, Excel in kolaylıklarını (özelliklerini) daha verimli kullanırsanız, Excel de sizi hamallıktan (rutin işlerden) kurtaracaktır" Excelde sağ klik menüsünü gizle-göster Application.CommandBars("Menü Adı").Visible = True 'False de gizler Excelde satir sİlme "ok o zaman şöyle yapalım Kod: Sub sil() For i = Cells(65536, 1).End(xlUp).Row to 2 step -2 Rows(i).Delete Next i End Sub not: denemedim. edit: son satırın tek olma ihtimaline karşın Kod: Sub sil() z= Cells(65536, 1).End(xlUp).Row if z mod 2 = 1 then z = z -1 For i = z to 2 step -2 Rows(i).Delete Next i End Sub " Excelde sürekli flash ö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" Excelden word belgesi açmak "Sub WordAc() adres = Application.InputBox(""Belgenizin Adı Nedir ?"", ""Adres"", ""\Word.doc"") On Error GoTo hata1 With CreateObject(""Word.Application"") .Visible = 1 .Documents.Open (ThisWorkbook.Path & adres) End With hata1: End Sub " Excele şifreli giriş 3 hakkınız var. "Sub auto_open() Static sayac As Integer Do If sayac = 3 Then ThisWorkbook.Close False Else If InputBox(""Şifreyi girin"") = ""Buraya koymak istediğiniz şifreyi yazacaksınız!"" Then GoTo devam Else sayac = sayac + 1 End If End If Loop devam: End Sub" Excelİ aÇiŞta İstenen sayfa gelİr "Exceli İlk Açtığınızda istediğiniz sayfanın gelmesi için Sub SayfaHucreSec() Sheets(""Sayfa1"").Select Selection.Range(""A1"").Select End Sub " Exceli gizleme "Sub HideExcel() Application.Visible = False End Sub" Exceli gizleyerek mesaj verir "Sub Nur_MsgBox() Application.Visible = False MsgBox (""Du siehst nur die MsgBox"") Application.Visible = True End Sub" Exceli kapatma işlemi "Private Sub kapat() Dim Cevap As VbMsgBoxResult Cevap = MsgBox(""PROGRAMIN KAPATILMASINI İSTİYOR MUSUNUZ.?"", _ vbOKOnly + vbYesNo, ""MESAJ"") If Cevap = vbYes Then ActiveWorkbook.Save Excel.Application.Quit End If End Sub " Excelİ tamamen kapatma "makronuzun uygun yerine aşağidaki kodu yazmalısınız. Application.Quit " Excelİ tamamen kapatmak application.quit Excelin tüm menü buton resimler "Public Sub ListAllFaces() Btn = MsgBox(""This macro will list all of the button faces (over 5000)"" & vbCrLf & _ ""in this worksheet."" & vbCrLf & vbCrLf & _ ""Are you READY TO PROCEED?"", vbOKCancel, ""Button Image Listing"") If Btn = vbCancel Then Exit Sub Dim i As Integer Dim j As Integer Dim k As Integer Dim cbCtl As CommandBarControl Dim cbBar As CommandBar On Error Resume Next Application.ScreenUpdating = False Set cbBar = CommandBars.Add(Position:=msoBarFloating, MenuBar:=False, temporary:=True) Set cbCtl = cbBar.Controls.Add(Type:=msoControlButton, temporary:=True) k = 1 Do While Err.Number = 0 For j = 1 To 10 i = i + 1 Application.StatusBar = ""Face ID = "" & i cbCtl.FaceId = i cbCtl.CopyFace If Err.Number <> 0 Then Exit For ActiveSheet.Paste Cells(k, j + 1) Cells(k, j).Value = i Next k = k + 1 Loop Application.StatusBar = False cbBar.Delete End Sub" Excelinizin versiyonunu öğrenin "Sub testVersion() Dim myvers As String myvers = Application.Version MsgBox (""Microsoft Excel"" & "" "" & myvers) End Sub" Excel-outlook "A1 Hücresine xxrt@yahoo.com yazıldığında zaten köprü kendi kendine gelir ve bunu tıkladığınızda Outlook açılır.Ama yinede makro ile derseniz. 1.)A1 Hücresine manuel mail adresi yazılması şartı ile; Sub Makro6() Range(""A1"").Select Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True End Sub" Explorer açma "Sub Windows_Explorer_aufrufen() Shell (Environ(""systemroot"") & ""\explorer.exe""), 1 ' ** 'Shell (Environ(""systemroot"") & ""\explorer.exe C:\Temp""), 1 ' ** End Sub" Explorer'i açma tam ekran "Sub ExplorerDossier() Shell ""C:\WINDOWS\EXPLORER.EXE /n,/e,D:\FichXls"", vbMaximizedFocus End Sub" F9 tuŞuna bastiĞimda ÇaliŞmasini yanİ kaydetmesİnİ İstİyorum "Private Sub CommandButton1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) chkFKey (KeyCode) End Sub Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) chkFKey (KeyCode) End Sub Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) chkFKey (KeyCode) End Sub Private Sub TextBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) chkFKey (KeyCode) End Sub Private Sub chkFKey(KeyCode) If vbKeyF1 <= KeyCode And KeyCode < vbKeyF12 Then Select Case KeyCode Case vbKeyF1: MsgBox ""f1 e bastınız"" Case vbKeyF9: x = MsgBox(""f9 a bastınız. kayıt yapılsın mı?"", vbYesNo) 'kayıt işlemin burada yapın. Case Else: MsgBox ""F"" & (KeyCode - vbKeyF1 + 1) & "" e bastınız."" End Select End If End Sub" F9 tuşuna makro atama "Sub Auto_Open() Application.OnKey ""{F9}"", ""macro"" End Sub Sub macro() MsgBox ""aaa F9 tuşuna bastın"" End Sub" F9 tuşuna makrro atama "Sub Auto_Open() Application.OnKey ""{F9}"", ""mesaj"" End Sub Sub mesaj() MsgBox ""aaa F9 tuşuna bastın"" End Sub" Faİz hesabi "Sub hesapla() k = 4 Do While Cells(k, 7) <> """" tutar = Cells(k, 7) bastar = Cells(k, 8) sontar = Cells(k, 9) tmpbastar = bastar j = 4 faiz = 0 devam = True Do Until devam = False faiztar = Cells(j, 3) If Cells(j, 3) = """" Or faiztar > sontar Then faiztar = sontar: devam = False If bastar > faiztar Then GoTo 20 faizor = Cells(j - 1, 4) faiz = faiz + ((faiztar - tmpbastar) * tutar * faizor) / 36500 tmpbastar = faiztar 20 j = j + 1 Loop Cells(k, 10) = faiz k = k + 1: faiz = 0 Loop End Sub " Fare ile textbox içinin renklenmesi "Dim txtler() As New Class1 Dim combolar() As New Class1 Dim nense As Control Private Sub UserForm_Initialize() For Each nesne In UserForm1.Controls If TypeName(nesne) = ""TextBox"" Then ReDim Preserve txtler(i) Set txtler(i).txt = nesne i = i + 1 ElseIf TypeName(nesne) = ""ComboBox"" Then ReDim Preserve combolar(i) Set combolar(i).combo = nesne i = i + 1 End If Next nesne End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) For Each nesne In UserForm1.Controls If TypeName(nesne) = ""TextBox"" Or TypeName(nesne) = ""ComboBox"" Then nesne.BackColor = vbWhite End If Next nesne End Sub ‘classmodüle Public WithEvents txt As MSForms.TextBox Public WithEvents combo As MSForms.ComboBox Private Sub txt_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) txt.BackColor = vbRed End Sub Private Sub combo_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) combo.BackColor = vbRed End Sub" Fare imleci kum saati "Sub fare_imleci() If Application.Cursor = xlWait Then Application.Cursor = xlNormal Worksheets(1).Buttons(1).Caption = ""Fare İmleci Kum Saati"" Else Application.Cursor = xlWait Worksheets(1).Buttons(1).Caption = ""Fare İmleci Normal"" End If End Sub" Fare kursörünü gizlemek 1 "Private Declare Function BlockInput Lib ""user32"" (ByVal fBlock As Long) As Long Private Declare Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long) Sub Düğme1_Tıklat() DoEvents BlockInput True Sleep 5000 '5 saniye BlockInput False End Sub " Fare kursörünü gizlemek 2 "Declare Function ShowCursor Lib ""user32"" (ByVal bShow As Long) As Long Sub FareGizle() Application.OnTime Now + TimeValue(""00:00:05""), ""FareGöster"" ShowCursor False End Sub Sub FareGöster() ShowCursor True End Sub" Fare kursörünü hareket ettirme "Private Declare Function SetCursorPos Lib ""user32"" (ByVal X As Long, ByVal Y As Long) As Long Sub Cursor1() SetCursorPos 540, 350 End Sub Sub Cursor2() SetCursorPos 220, 200 End Sub" Farklı kaydederken dosya ismini otomatik yazsın "Sub Enregistre_Sous2() Réponse = MsgBox(""Voulez-vous enregistrer ce classeur ?"", vbYesNo) If Réponse = vbYes Then Dim nom As String Do While nom = """" 'Répète l'instruction tant qu'aucun nom est donné nom = InputBox(""Donnez un nom de fichier !"" & Chr(13) & ""Exemple: Rapport"") Loop ChDrive ""c"" ChDir ""c:\"" 'Indiquez le répertoire ActiveWorkbook.SaveAs Filename:=(nom) Application.Dialogs(xlDialogSaveAs).Show 'pour afficher la boîte Enregistrer sous End If End Sub" Farklı kaydederken dosya ismini otomatik yazsın 2 " Sub Enregistre_Sous2() Réponse = MsgBox(""Voulez-vous enregistrer ce classeur ?"", vbYesNo) If Réponse = vbYes Then ChDrive ""c"" ChDir ""c:\"" 'Indiquez le répertoire ActiveWorkbook.SaveAs Filename:=456 Application.Dialogs(xlDialogSaveAs).Show 'pour afficher la boîte Enregistrer sous End If End Sub" Farklı kaydet butonu ekleme ve renk verme "Sub Icon_Speichern_unter() Dim Pos As Byte ActiveSheet.Shapes(""Picture 1"").Copy Pos = Application.CommandBars(""Standard"").FindControl(, 3).Index + 1 With Application.CommandBars(""Standard"").Controls.Add(msoControlButton, ID:=748, before:=Pos) .Style = msoButtonIcon .PasteFace End With End Sub" Farklı kaydet ekranı gelmeden ve kaydetmeden çıkmak "Sub auto_close() Application.DisplayAlerts = False ActiveWorkbook.Close End Sub" Farklı kaydet ve sağ klik tuşunu disable yapma "Sub ac() EnableControl 748, 1 End Sub Sub kapa() EnableControl 748, 0 End Sub Sub EnableControl(Id As Integer, Enabled As Boolean) Dim CB As CommandBar Dim C As CommandBarControl For Each CB In Application.CommandBars Set C = CB.FindControl(Id:=Id, recursive:=True) If Not C Is Nothing Then C.Enabled = Enabled Next End Sub" Farklı kaydet ve sağ klik tuşunu disable yapma "Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If SaveAsUI Then Cancel = True End Sub Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) Cancel = True End Sub Private Sub Workbook_BeforeSave(ByVal pir As Boolean, Cancel As Boolean) If pir Then Cancel = True End Sub" Farklı kaydeti engelle "Thisworkbook'a Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If SaveAsUI Then Cancel = True'False farklı kaydede izin verir. End If End Sub" Farklı kaydetin devamlı gelmesini istiyorsanız "ThisWorkbook'a yazınız. Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.GetSaveAsFilename End Sub" Farkli kaydedİ engelle "Aşağıdaki kod kullanıcının kullanmakta olduğu dosyasını (farklı kaydet) yapmasını engeller. 'KOD Thisworkbook'a yazılacak Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If SaveAsUI Then Cancel = True'False farklı kaydede izin verir. End If Formuller ve Gönderen: Hüseyin 23-06-2010 15:17 10 125 EĞİTİM HİZMETLERİ EXCEL.WEB.TR Güvencesi ile bulunduğunuz şehirde eğitimleri takip edin. Online Eğitim Bilgileri Gönderen: Hüseyin 25-04-2010 23:02 1 1 Video Dersane (***Altın Üyelere Özel***) Excel Konusunda çeşitli derslerin videolu anlatımları. BU BÖLÜM SADECE ALTIN ÜYELERE AÇIKTIR!! Alt Forumlar: Excel Temel (Video Anlatım), Excel İleri (Video Anlatım), Excel VBA / Makro (Video Anlatım), Örnek Çözümler (Video Anlatım) ORTALAMA Fonksiyonu (Video Gönderen: Hüseyin 07-12-2010 11:01 159 257 Diğer ATATÜRK Köşesi (1 Kişi Görüntülüyor) Atatürk hakkında paylaşmak istediğiniz sunum, anı ve linkleri bu başlıkta paylaşabilirsiniz. Bugün 10 kasım Gönderen: Ömer 10-11-2010 17:11 49 317 Bayram ve Özel Gün Mesajları (3 Kişi Görüntülüyor) Bu başlığa resmi ve dini bayramlar ile özel günlere ait kutlama mesajlarınızı yazabilirsiniz. Yeni Yılınız Kutlu Olsun Gönderen: aatoş Bugün 13:37 89 1,414 Reklam - - Serbest Kürsü (5 Kişi Görüntülüyor) Bu başlıkta önemli gördüğünüz konulardaki mesajlarınızı yada duyurularınızı diğer üyelerimizle paylaşabilirsiniz. Son yaprakta düştü. Gönderen: canavar_55 Bugün 00:30 513 4,298 Türk Dili ve Edebiyatı Bu başlık altında Türkçemizin doğru kullanımına yönelik bilgilerinizi ve Edebiyatımızdan beğendiğiniz şiir ve diğer edebi eserler ile beğendiğiniz linkleri paylaşabilirsiniz. Uluslararası Türkçe Gönderen: emirali 25-11-2010 09:44 43 136 ***Altın Üyelere Özel*** Sadece Altın Üyelere özel sohbet bölümü Özel 17 265 Site ile ilgili FORUM KURALLARI-Duyurular-Forum Kullanım Bilgileri Lütfen ilk önce forum kurallarını okuyunuz. Foruma kayıt olduğunuzda bu kuralları kabul etmiş sayılırsınız. Açılan Konu Başlığını Gönderen: Korhan Ayhan 21-02-2010 23:46 19 24 Öneriler Eleştiriler Görüşler (2 Kişi Görüntülüyor) Site içerisinde görmek istediklerinizi veya görmek istemediklerinizi buraya yazabilirsiniz. Site hakkındaki görüşlerinizi de buraya yazabilirsiniz. EXCEL VİDEO DERSHANE Bölümümüz Gönderen: caner2010 11-12-2010 14:05 653 5,125 Reklam - - Kayıt olmadan önce (1 Kişi Görüntülüyor) Bu alana herkes mesaj gönderebilir. Kayıt gerektirmez. Nasıl kayıt olacağım diyenler. Kayıt oldum, onay e-mailim gelmedi diyenler. Adımı ve şifremi doğru giriyorum, fakat foruma giremiyorum diyenler. Bu alan sizin için. Kayıt İşlemi Aşamaları Gönderen: ekselansC 07-12-2010 14:45 108 603 TEST Alanı Yeni üye oldunuz ve bir mesaj atmak istiyorsunuz, ancak aklınıza da bir soru veya bilgi gelmiyor. İşte burası onun için. "Test", "Deneme", "Mesaj gönderiyorum" gibi başlıklarla istediğiniz deneme mesajınızı buraya atabilirsiniz. Bundan sonra göndereceğiniz mesajlar için bir alıştırma olsun diye :) test Gönderen: Evren Gizlen 09-12-2010 21:20 500 1,044 Forum Kurallarına Uymayan Başlıklar (1 Kişi Görüntülüyor) excel.web.tr forum kurallarına uymayan başlıklar bu bölüme taşınır. Başlığın sahibi 3 gün içerisinde gerekli düzenlemeleri yapmadığı takdirde başlık Moderatörler tarafından silinir. Exel den anlayan acil bugün Gönderen: lezonra 28-12-2010 10:37 1,269 2,037 Konuları Okundu İşaretle Forum Yöneticilerini Görüntüle Forum'da Neler Oluyor Kullanıcı Durumu: 440 (87 kayıtlı üye ve 353 misafir) En çok kullanıcı : 1,100; 18-03-2008 tarihinde; saat 11:45 itibariyle aktif olmuştur. kenan633, 010203, 9556552015, abdullahcabuk, acebeci, afatsumm, akavruk, altanson, amastris, baka, barabba, BARIS1, believe80, burakbeye, burhanşahin, cdesös, celebihan, cemfaki, cemkar, dincerusanmaz, diyokletiyanus, doseran, drages, ekinci_99, emre1988, emre9904, ERCAN BÜTÜN, ersimsek, fatih34, forest22, gezgin1, hamitcan, HASANB, hibercan, hipnozcu, huseyincoban, Huseyinkis, huseyinvurkan, Husgvarna, ifuat, İhsan Tank, isfa67, larainzaer, mamibey, marun, mekanikçi, mete69, meyir, modalı, mr.cyclone, mt70, muammer321, muendiss, myavsan, natcyurt, nongeyikm, ofis34, omerceri, onur_unlu, ottoman71, ozkance, ozuberk, portabler, quesh, reCALLL, retal, rs2003, sahir012, sah_zade, selcan, selphi7, signomis, skcsml, slcflz, solarbora, suatbayhan, tekintek, ugurkenan, uzmanamele, yahayf, yinanc, YONCA KOÇAK, zetkatamet ALTIN ÜYELİK Hakkında Detaylı Bilgi Son 24 saatte ziyaret eden üyeler : 971 Excel Forum İstatistikleri Konular: 81,900, Mesaj: 482,568, Üyeler: 201,199 En yeni üyemiz; signomis, forumumuza hoş geldiniz. Konu Yeni Mesaj İçeriyor Konuda Yeni Mesaj Yok kenan633 çıkış yap Saat 14:45 Bize Ulaşın - ExcelWebTr - Archive - En Üst Bu forum Çorlu WEB - www.elitnet.com.tr tarafından sunulmaktadır. Dost Site : İlköğretim - Toplu SMS - Diyet - Kreş - Rotary - Lions - Trakya İş Dünyası - Trakya Su Arıtma - Çorlu - Bahis - Çorlu WEB - Çorlu İlaçlama Powered by vBulletin Version 3.7.2 Copyright ©2000 - 2010, Jelsoft Enterprises Ltd. SEO by TechForum Advertisement System V2.6 By Branden  Excel Forum > EXCEL-Soruları > Fonksiyonlar metin içersinden parça alarak ek yapmak 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 Fonksiyonlar 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. Toplam 3 sayfada 1 1 2 3 > İlk Okunmamış Mesaja Git Konu Araçları Bu Konuda Ara Konuyu Oyla Görünüm Modları Dün, 20:47 #1 onur_unlu Giriş: 13/02/2009 Bölüm: Kocaeli Mesaj: 12 Excel Vers. ve Dili: 2003-türkçe metin içersinden parça alarak ek yapmak Merhaba Arkadaşlar Yardımlarınıza ihtiyacım var. A Sütünunda örnek veriyorum alt alta GHYO-U120-15 PLC150-20 KLUL10010 diye yazılar var. Burdan kırmızı ile belirtiğim C - U ve UL kelimelerini sonuna bende farklı birseyler ekleyerek çekmek istiyorum. Yani PARÇAAL - BUL - UZUNLUK vb. formüller kullanılması gerekiyor. Ben yapamadım yardımlarınız bekliyorum. Teşekkür ederim. Dün, 20:49 #2 İhsan Tank Altın Üye Giriş: 02/11/2009 Bölüm: Bize Her Yer "TRABZON" Mesaj: 3,870 Excel Vers. ve Dili: Ev ve İş Office 2003 - 2007 Türkçe soru dikkat çekici ama 2 eksiklik var 1 - konu başlığınız form kurallarına uymuyor 2 - örnek dosya ile tam olarak ne istedğinizi söylerseniz ona göre yapalım _ _ Alıntı: İlim öğrenmek her Müslüman için farzdır. İlim öğrenen kişiye, denizdeki balıklara kadar her şey istiğfar eder. HZ. MUHAMMED MUSTAFA ( S.A.V. ) Alıntı: Sorularınızı Örnek Dosya İle Destekleyiniz Alıntı: Sorularınızın Çözümlerinde Geri Dönüşüm Yapınız Dün, 21:38 #3 onur_unlu Giriş: 13/02/2009 Bölüm: Kocaeli Mesaj: 12 Excel Vers. ve Dili: 2003-türkçe Alıntı: İhsan Tank tarafından gönderildi soru dikkat çekici ama 2 eksiklik var 1 - konu başlığınız form kurallarına uymuyor 2 - örnek dosya ile tam olarak ne istedğinizi söylerseniz ona göre yapalım Kusura bakmayın formu inceledim yazacak bir yer bulamadım buraya yazdım. Aradığım bir cümle içerisinde istediğimi arayıp bulmak onu çekmek ve yanına başka birseyler eklemek istiyorum. ÖRNEK 1 = ALOU0015 ÖRNEK 2 = PİEFC015 ÖRNEK 3 = KJLU10015 kelimelerinden Örnek 1 den "U015" çekmek sonuna "PS" eklemek istiyorum. Örnek 2 den "C015" çekmek ve sonuna "KP" eklemek istiyorum. Örnek 3 den "LU015" Çekmek ve sonuna "-ES" eklemek istiyorum. Yani formun içinde EĞER-PARÇAAL-BUL vs kelimeler geçecek ama bir türlü yapamadım. İlgilendiğiniz için çok teşekkür ederim.. Dün, 22:12 #4 İhsan Tank Altın Üye Giriş: 02/11/2009 Bölüm: Bize Her Yer "TRABZON" Mesaj: 3,870 Excel Vers. ve Dili: Ev ve İş Office 2003 - 2007 Türkçe Alıntı: onur_unlu tarafından gönderildi Kusura bakmayın formu inceledim yazacak bir yer bulamadım buraya yazdım. Aradığım bir cümle içerisinde istediğimi arayıp bulmak onu çekmek ve yanına başka birseyler eklemek istiyorum. ÖRNEK 1 = ALOU0015 ÖRNEK 2 = PİEFC015 ÖRNEK 3 = KJLU10015 kelimelerinden Örnek 1 den "U015" çekmek sonuna "PS" eklemek istiyorum. Örnek 2 den "C015" çekmek ve sonuna "KP" eklemek istiyorum. Örnek 3 den "LU015" Çekmek ve sonuna "-ES" eklemek istiyorum. Yani formun içinde EĞER-PARÇAAL-BUL vs kelimeler geçecek ama bir türlü yapamadım. İlgilendiğiniz için çok teşekkür ederim.. eki inceleyin lütfen Eklenmiş Dosyalar onur_unlu - ihsan tank.zip (4.1 KB, 8 Görüntülenme) __ Alıntı: İlim öğrenmek her Müslüman için farzdır. İlim öğrenen kişiye, denizdeki balıklara kadar her şey istiğfar eder. HZ. MUHAMMED MUSTAFA ( S.A.V. ) Alıntı: Sorularınızı Örnek Dosya İle Destekleyiniz Alıntı: Sorularınızın Çözümlerinde Geri Dönüşüm Yapınız Dün, 22:18 #5 uzmanamele Uzman Giriş: 26/09/2007 Bölüm: Süleyman Özyüksel / Ankara Mesaj: 6,879 Excel Vers. ve Dili: excel 2003 / excel 2007 merhaba ek dosyayı inceleyiniz. KJLU10015 şeklinde olacaksa sorun çıkar, verilerinizin nasıl olduğuna dair örnek dosya ekleyiniz. Eklenmiş Dosyalar metin içinden parça al, ek yap.rar (6.5 KB, 5 Görüntülenme) __ Türk genci, İnkılapların ve rejimin sahibi ve bekçisidir. Atatürk Dün, 23:10 #6 onur_unlu Giriş: 13/02/2009 Bölüm: Kocaeli Mesaj: 12 Excel Vers. ve Dili: 2003-türkçe Arkadaşlar verdiğiniz örnekler için gerçekten çok teşekkür ederim. Son olarak bir cümlenin içinde hangisini geçtiğini bilmeden yapıyorsan nasıl olacak yani ÖRNEK 1 = ALOU0015 ÖRNEK 2 = PİEFC015 ÖRNEK 3 = KJLU10015 bunlardan biri olabilir öyle bir formul yazmalıyım ki U 'yu gördüğünde U'YU C'yi gördüğünce C'yi LU'yu gördüğünde LU'yu çeksin. bir formül içerisinde hapsinin geçmesi gerekiyor. Teşekkür ederim..