IDISLEMMAKRO KODU
1sayfa silerken uyarı gelmemesiSub Sil() Application.DisplayAlerts = False ActiveSheet.Delete End Sub 'Çıkışta Eski Haline Getirir. Sub Auto_Close() Application.DisplayAlerts = True End Sub
2"a1:m8" hücrelerinin arkaplani yanip sönerSub FlashBack() 'Make cell range Background color, flash x times, x fast, in x color, 'when Ctrl-a 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, 'Gray-50% 16, Gray-25% 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 End Sub
30 olan hücreleri geri almaType SaveRange Val As Variant Addr As String End Type ' Stores info about current selection Public OldWorkbook As Workbook Public OldSheet As Worksheet Public OldSelection() As SaveRange Sub ZeroRange() ' Inserts zero into all selected cells ' Abort if a range isn't selected If TypeName(Selection) "Range" Then Exit Sub ' The next block of statements ' Save the current values for undoing ReDim OldSelection(Selection.Count) Set OldWorkbook = ActiveWorkbook Set OldSheet = ActiveSheet i = 0 For Each cell In Selection i = i + 1 OldSelection(i).Addr = cell.Address OldSelection(i).Val = cell.Formula Next cell ' Insert 0 into current selection Application.ScreenUpdating = False Selection.Value = 0 ' Specify the Undo Sub Application.OnUndo "Undo the ZeroRange macro", "UndoZero" End Sub Sub UndoZero() ' Undoes the effect of the ZeroRange sub ' Tell user if a problem occurs On Error GoTo Problem Application.ScreenUpdating = False ' Make sure the correct workbook and sheet are active OldWorkbook.Activate OldSheet.Activate ' Restore the saved information For i = 1 To UBound(OldSelection) Range(OldSelection(i).Addr).Formula = OldSelection(i).Val Next i Exit Sub ' Error handler Problem: MsgBox "Can't undo" End Sub Other examples of Undo -
40 sıfırın tüm çalışma kitabında gösterilmemesi içinOption Explicit Sub Auto_Open() Dim sht As Worksheet For Each sht In Worksheets sht.Activate ActiveWindow.DisplayZeros = False Next sht End Sub Sub Auto_Close() Dim sht As Worksheet For Each sht In Worksheets sht.Activate ActiveWindow.DisplayZeros = True Next sht End Sub Sub BaskaBirYöntem() Dim byt As Byte For byt = 1 To Worksheets.Count Worksheets(byt).Activate ActiveWindow.DisplayZeros = False Next byt End Sub
51 den 26 ya kadar olan kolon sayısı kadar gizlemeSub LeereSpalteAus() Dim i% For i = 1 To 26 If IsEmpty(Cells(Rows.Count, i).End(xlUp)) Then Columns(i).Hidden = True End If Next i End Sub
61. satirla 2. satir arasina 7 tane satir eklediSub SATIREKLE() For i = 2 To 8 If Cells(i, 1) Cells(i + 1, 1) Then Rows(i + 1).EntireRow.Insert End If Next i End Sub sizin yaptığınızdan esinlenerek şöyle bir şey yaptım. O da sadece 1. satırla 2. satır arasına 7 tane satır ekledi. Yani döngüde ilk if'in sağlandığı yere. -
71.pir adlı sayfayı kopyalayarak 10 adet çoğaltır ve .pir eklerSub Modul_Loeschen() Dim Ini As Integer For Ini = 2 To 10 Sheets("1.pir").Copy After:=Sheets(Worksheets.Count) ActiveSheet.Name = Ini & ".pir" Next Ini With Application.VBE.ActiveVBProject .vbComponents.Remove .vbComponents("Modul1") End With End Sub
81.satır 1.sütunu seçSub sec() Cells(1, 1).Select End Sub
91.sayfa hariç diğerlerini uyarısız silerSub birincisayfaharicsil() Application.DisplayAlerts = False While Worksheets.Count > 1 Sheets(2).Delete Wend Application.DisplayAlerts = True End Sub
101.sayfa hariç tüm sayfalari gizleSub xlVeryHidden_All_Sheets() On Error Resume Next Dim sh As Worksheet For Each sh In Worksheets sh.Visible = xlVeryHidden Next End Sub
111.sayfayı açmaSub FirstSheet() Sheets(1).Select End Sub
1210 sn süreli mesajThisWorkbook a Private Sub Workbook_Open() Dim WshShell Dim intText As Integer Set WshShell = CreateObject("WScript.Shell") intText = WshShell.Popup("Diese ''MsgBox'' wird nach 10 sec geschlossen", _ 10, "''MsgBox'' für 10 sec (©)2003 KMB", vbSystemModal) End Sub
1310.satırdan itibaren gizleme ve göstermeSub BenutzterBereich() Dim WsTabelle As Worksheet On Error Resume Next For Each WsTabelle In Worksheets With WsTabelle .Rows(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":65536").EntireRow.Hidden = _ Not .Rows(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 & ":65536").EntireRow.Hidden .Range(.Cells(1, .UsedRange.SpecialCells(xlCellTypeLastCell).Column + 1), .Cells(65536, 256)).EntireColumn.Hidden = _ Not .Range(.Cells(1, .UsedRange.SpecialCells(xlCellTypeLastCell).Column + 1), .Cells(65536, 256)).EntireColumn.Hidden End With Next WsTabelle End Sub
14100 buton bar ekle kaldırSub Auto_Open() Toolbars("100 Button Faces").Visible = True Toolbars("Custom Toolfaces").Visible = True End Sub Sub Auto_Close() Toolbars("100 Button Faces").Delete Toolbars("Custom Toolfaces").Delete End Sub
152 listboxlar arası verş taşımaPrivate Sub UserForm_Initialize() ListBox1.RowSource = "A1:A" & Cells(65536, 1).End(xlUp).Row ListBox1.ListStyle = fmListStyleOption ListBox1.MultiSelect = fmMultiSelectMulti End Sub ' Private Sub CommandButton1_Click() ListBox2.Clear For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) = True Then ListBox2.AddItem ListBox1.List(i) End If Next End Sub
162 listboxlar arası verş taşımaPrivate Sub UserForm_Initialize() ListBox1.ColumnCount = 6 ListBox2.ColumnCount = 6 ListBox1.ListStyle = fmListStyleOption ListBox1.MultiSelect = fmMultiSelectMulti ListBox1.RowSource = "A1:F" & Cells(65536, 1).End(xlUp).Row End Sub ' Private Sub CommandButton1_Click() Dim MyArray() ListBox2.Clear For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) = True Then For j = 0 To 5 ReDim Preserve MyArray(5, xx) MyArray(j, xx) = ListBox1.List(i, j) Next xx = xx + 1 End If Next ListBox2.List() = WorksheetFunction.Transpose(MyArray) End Sub
172 tane userform_initialize olayini birleştirme
182.sütunda çift tıkla eklenecek satırı belirlePrivate Sub Worksheet_BeforeDoubleClick(ByVal _ Target As Range, Cancel As Boolean) 'D.McRitchie, 2004-09-21, nsert more rows up ' until 15, no deletions of rows 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 -
193 boyutlu hücreye kenarlıkSub Makro1() With ActiveCell.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With ActiveCell.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With End Sub
203 kere şifre hakkıSub auto_open() Static sayac As Integer Do If sayac = 3 Then ThisWorkbook.Close False Else If InputBox("Şifreyi girin") = "1" Then GoTo devam Else sayac = sayac + 1 End If End If Loop devam: End Sub
213 sn içerisinde msg box alarmSub timerMsg() Dim alertTime MsgBox "The alarm will go off in 3 seconds!" alertTime = Now + TimeValue("00:00:03") Application.OnTime alertTime, "msg" End Sub Sub msg() MsgBox "Three Seconds is up!" End Sub
2230 excel dosyasi içinde bir kelime aratmaAlpenin çözümüde olur ama kod olarak da;Dosyaları Sayfanıza ekliyerek,Görerek Bulabilirsiniz.Burada excellerin yolu olarak D:\Belgelerim aldım.Siz yolu değiştirebilrsiniz.Kodları modüle yapıştırın.Daha sonra Butona FileList makrosunu atayın.Kod: Sub FileList() Dim FileNamesList As Variant, i As Integer FileNamesList = CreateFileList("*.xls", True) Range("A:B").ClearContents For i = 1 To UBound(FileNamesList) Cells(i + 1, 1) = FileNamesList(i) Cells(i + 1, 2) = FileSize(Dir(FileNamesList(i))) Next Columns("A:B").AutoFit End Sub Function CreateFileList(FileFilter As String, IncludeSubFolder As Boolean) As Variant Dim FileList() As String, FileCount As Long CreateFileList = "" Erase FileList With Application.FileSearch .NewSearch .LookIn = "D:\Belgelerim\" .Filename = FileFilter .SearchSubFolders = IncludeSubFolder 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 End With CreateFileList = FileList Erase FileList End Function Function FileSize(filespec) Dim fs, f, f1, fc Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder("D:\Belgelerim\") Set fc = f.Files For Each f1 In fc If f1.Name = filespec Then FileSize = f1.Size / 1024 & " Kb" Next End Function Dosyalar Geldikten Sonra şu makro ile Dosyaların adlarını ayırarak İstediğin dosyayı fonksiyonlarla Bulabilirsin..Tabi bu yöntem tam istediğiniz değil ama yinede örnek olarak bulunsun.Kod: Sub ayır() Columns("A:A").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _ :="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)) ActiveWindow.ScrollColumn = 2 End Sub
234 işlem programı(basit)Private Sub Command1_Click() Dim sayı1, sayı2, sonuç As Double sayı1 = Val(Text1.Text) sayı2 = Val(Text2.Text) If Option1 = True Then sonuç = sayı1 + sayı2 If Option2 = True Then sonuç = sayı1 - sayı2 If Option3 = True Then sonuç = sayı1 * sayı2 If Option4 = True Then sonuç = sayı1 / sayı2 Text3.Text = Str(sonuç) End Sub
244. satırda işlem yapılırsa macro otomatik çalışsınPrivate Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Row = 4 Then MsgBox "Aşkından Selamlar" End Sub
254. sütunda işlem yapılırsa macro otomatik çalışsınPrivate Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Column = 4 Then MsgBox "Aşkın'dan Selamlar" End Sub
265 dk da bir kitabı kaydetmeSub auto_open() Application.OnTime Now + TimeValue("00:05:00"), "Kayıt" End Sub Sub Kayıt() ActiveWorkbook.Save MsgBox "Kitap Kaydedildi" Call auto_open End Sub
275. sütünundaki hücreye girilen veriye karşılık farklı farklı makroların çalışmasıPrivate Sub Worksheet_Change(ByVal Target As Range) If Target.Column 6 Then Exit Sub Select Case Target.Value Case "a" A_Makrosu Case "b" B_Makrosu Case "c" C_Makrosu End Select End Sub -
2865536 dan çoksa diğer sheet ' e atsin istiyorum....Sub GetTxtData2() 'Raider ® Dim MyFile As String MyFile = "C:\Test.txt" j = 0 Set NewSh = Worksheets.Add j = j + 1 NewSh.Name = "TextSheet-" & j Open MyFile For Input As #1 Do While Not EOF(1) i = i + 1 Line Input #1, InputData Cells(i, 1) = InputData If i > 65535 Then Set NewSh = Worksheets.Add j = j + 1 NewSh.Name = "TextSheet-" & j i = 0 End If Loop Close #1 Set NewSh = Nothing End Sub
299 farkli değer için koşullu biçimlendirmeAşağıdaki kodu sayfanın kod sayfasına kopyalayın. A1 hücresine yazdığınız sayı renk indexi olarak kabul edilmiştir. visual basic kodu: Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address "$A$1" Or IsNumeric(Target) = False Then Exit Sub Target.Interior.ColorIndex = Target End Sub -
30a hücresindeki değere göre sayfaya kaydetmeSub aktar() Set verisayfasi = Sheets(1) Select Case Range("a1").Value Case "A" Set sayfam = Sheets(1) Case "B" Set sayfam = Sheets(2) Case "C" Set sayfam = Sheets(3) Case "D" Set sayfam = Sheets(4) End Select ensonhucre = sayfam.Range("A65000").End(xlUp).Row 'son hucreye A sutunundan baktım For i = 1 To 5 sayfam.Cells(ensonhucre, i) = verisayfasi.Cells(2, i) Next End Sub
31a ile b'yi karşılaştır, aynı olanları c'ye, farklı olanları d'ye yazSub bul() For a = 2 To Cells(65536, 1).End(xlUp).Row If WorksheetFunction.CountIf(Columns(1), Cells(a, 2).Value) = 0 Then e = WorksheetFunction.CountA([d2:d65536]) + 1 Cells(e + 1, 4) = Cells(a, 2).Value End If If WorksheetFunction.CountIf(Columns(2
32a sütunu auto_copySub AutoCopy() Dim LookupRange As Range, cell As Range, Found As Boolean Dim DestRange As Range Set LookupSheet = Sheet2 Set DestSheet = Sheet3 n = ActiveCell.Value Set LookupRange = Intersect(LookupSheet.Columns("A"), LookupSheet.UsedRange) Set DestRange = DestSheet.Range("A65536").End(xlUp).Offset(1, 0) Found = False If n "" Then For Each cell In LookupRange If cell.Value = n Then delrange = cell.Address cell.EntireRow.Cut DestRange Found = True Exit For End If Next cell End If If Not Found Then msg = "The code does not exist on " & LookupSheet.Name & "." MsgBox msg, vbOKOnly, "AutoCopy" Else LookupSheet.Range(delrange).EntireRow.Delete DestSheet.Select Range("A65536").End(xlUp).EntireRow.Select End If End Sub -
33a sütununa pir yazınca makro çalışsınPrivate Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Intersect(Target, [A:A]) Is Nothing Then Exit Sub If Target = "" Then Exit Sub If Target = "pir" Then Call Test End Sub Sub Test() MsgBox "Tebrikler..!", vbInformation End Sub
34a sütununda aralarda boş satırları siler ve yukarı çekerOption Explicit Sub Leerzeilenlöschen() Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete End Sub
35a sütununda aynı değerde olanları yazdırma alanı olarak ayırırSub AutoBreak() Set Urange = ActiveSheet.UsedRange Set ColA = Range("A:A") Set Arange = Intersect(ColA, Urange) Set Brange = Arange.Offset(1, 0).Resize(Arange.Rows.Count - 1) Cells.PageBreak = xlNone For Each cell In Brange If cell.Value cell.Offset(1, 0).Value Then cell.Offset(1, 0).EntireRow.PageBreak = xlPageBreakManual End If Next End Sub -
36a sütununda aynı olanlardan 1 tane bırakır ve sıraya dizerSub Doppelte_löschen() Range("A:A").Select Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _ xlTopToBottom Range("A1").Select nr = ActiveCell zellende = Range("A" & Rows.Count).End(xlUp).Row Do ActiveCell.Offset(1, 0).Range("A1").Select If ActiveCell = nr Then Selection.EntireRow.Delete ActiveCell.Offset(-1, 0).Range("A1").Select End If nr = ActiveCell Loop Until ActiveCell = Range("A" & zellende + 1) End Sub
37a sütununda aynı olanları sayfa alanı olarak ayırırSub AutoBreak() Set Urange = ActiveSheet.UsedRange Set ColA = Range("A:A") Set Arange = Intersect(ColA, Urange) Set Brange = Arange.Offset(1, 0).Resize(Arange.Rows.Count - 1) Cells.PageBreak = xlNone For Each cell In Brange If cell.Value cell.Offset(1, 0).Value Then cell.Offset(1, 0).EntireRow.PageBreak = xlPageBreakManual End If Next End Sub -
38a sütununda aynı olanları sayfa alanı olarak ayırır2Sub SetzeSeiten() Dim rngBereich As Range Dim rngZelle As Range Application.ScreenUpdating = False On Error GoTo Ende Set rngBereich = Range("A1:A" & Range("A2").End(xlDown).Row) Cells.PageBreak = xlNone For Each rngZelle In rngBereich If rngZelle rngZelle.Offset(1, 0) Then rngZelle.Offset(1, 0).PageBreak = xlPageBreakManual Next rngZelle Ende: Application.ScreenUpdating = True End Sub -
39a sütununda boş satırları silerSub 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 End Sub
40a sütununda boşlukları aldırma doluları listelemeSub Leerzeilenlöschen() Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete End Sub
41a sütununda bugünü bulsunSub bugunu_bul() Dim lr As Long Dim i As Integer lr = Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To lr If Cells(i, 1).Value = Date Then Cells(i, 1).Select End End If Next i End Sub
42a sütununda en son sırada olan veriyi b1 e kopyalarSub LetztenWertKopieren() Dim intCol As Integer intCol = 1 '1 steht für Spalte A Cells(Rows.Count, intCol).End(xlUp).Copy _ Range("B1") End Sub
43a sütununda herhangi bir hücreye tıkla satır numarasını versinSayfanın kod bölümüne Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) rowoffset = 0 Intersect(ActiveCell.EntireRow, Columns("A")).Value = ActiveCell.Row + rowoffset End Sub
44a sütununda verilere göre sayfa ekler ve d sütununa kadar olan verileri de yazarSub aktar() On Error Resume Next Application.DisplayAlerts = False ActiveSheet.Move before:=Sheets(1) Application.DisplayAlerts = True ActiveSheet.Copy after:=Sheets(Worksheets.Count) ActiveSheet.Shapes("Button 1").Select Selection.Cut ActiveSheet.Shapes("Button 2").Select Selection.Cut basla: If [A2] = "" Then Exit Sub Set sayfa = ActiveSheet Columns("A:D").EntireColumn.AutoFit sayfa.Name = [A2] Set sec = [A2].CurrentRegion.Columns(1).ColumnDifferences([A2]) Set sec = Intersect(sec.EntireRow, [A:D]) If sec.Address = "" Then Exit Sub Worksheets.Add after:=Sheets(Worksheets.Count) Set sonsayfa = Sheets(Worksheets.Count) sayfa.Select For Each alan In sec.Areas alan.Copy sat = sonsayfa.[a65536].End(3).Row + 1 sonsayfa.Cells(sat, 1).Insert shift:=xlDown alan.Delete shift:=xlUp Next Set sec = Nothing sonsayfa.Select GoTo basla End Sub
45a sütunundaki aynı değerleri öbür sayfada süzüp b deki toplamlarını ilave ederSub aktar() 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 -
46a sütunundaki boş satırları gizlerPrivate Sub CommandButton1_Click() Application.ScreenUpdating = False Dim i As Integer For i = 1 To 300 '1 satır ile 300. satır arası If IsEmpty(Cells(i, 1)) Then '1. Satır 1. Sütun yani A1 hücresi Rows(i).Hidden = True End If Next i Application.ScreenUpdating = True
47a sütunundaki dolu hücreleri bulur ve yazdirma alani içine alirAçıklama:A sütunundaki dolu hücreleri bulur ve yazdırma alanı içine alır Kod: Sub setPrintArea() Dim rng As Range Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell) stcell = "A1": lcell = rng.Address ActiveSheet.PageSetup.PrintArea = stcell & ":" & lcell End Sub
48a sütunundaki en büyük sayı içinPrivate Sub UserForm_Initialize() TextBox1.Value = WorksheetFunction.Max(Range("A:A")) End Sub
49a sütunundaki en son veriyi b1 e yazSub enbuyuk() Dim intCol As Integer intCol = 1 '1 steht für Spalte A Cells(Rows.Count, intCol).End(xlUp).Copy _ Range("B1") End Sub
50a sütunundaki sayılara 1 ekler c sütununa yazarSub ekle1yazC() Dim MaValeur, compteur For compteur = 1 To 15 Range("A" & compteur).Select MaValeur = ActiveCell.Value Range("C" & compteur).Select ActiveCell.Value = MaValeur + 1 Next End Sub
51a sütunundakiler combboxta, combobox seçilince b,c,d dekiler textboxtaPrivate Sub ComboBox1_Change() Dim I As Long For I = 1 To 3 Me.Controls("TextBox" & I) = Range("A" & ComboBox1.ListIndex + 1).Offset(, I) Next I End Sub
52a sütunundakileri 100 ile toplar b sütununa yazarSub topla100yazB() Dim MaValeur, nbcell For nbcell = 1 To 10 Range("A" & nbcell).Select MaValeur = ActiveCell.Value Range("B" & nbcell).Select ActiveCell.Value = MaValeur + 100 Next End Sub
53a sütunundakileri benzersiz olacak şekilde ayıklarSub benzersiz() Columns("A:A").Select Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns("C:C"), Unique:=True Range("C11").Select End Sub
54a sütunundakileri benzersiz olacak şekilde ayıklar2Sub süz() On Error Resume Next Sayfa1.Range("a1:a1500").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sayfa1.Range( _ "h1"), Unique:=True End Sub
55a sütunundakileri saydırınWorksheetFunction.CountA(Columns("A"))
56a sütunundan g sütununa (g hariç) kadar olan hesaplamalar açık , diğer sütunlar butona basınca hesaplasınSub Auto_Open() Application.Calculation = xlCalculationManual 'hesaplamayı el ile yapar Application.OnKey "{F9}", "sec_hesapla" 'F9 tuşuna basınca sec_hesapla makrosunu çalıştırır End Sub Sub Auto_Close() Application.Calculation = xlCalculationAutomatic 'çıkışta otomatik hesaplama yapar. End Sub Sub sec_hesapla() Dim sec 'sec sabiti sec = Range("A1:A9").Select 'sec sabitinin aralığı tanımlanır ve seçilir (A1:A9 arasında formüllerin olduğunu varsayıorum) Selection.Calculate 'seçili olan aralık F9 tuşuna basılınca hesaplanır End Sub
57a sütununu hücrelerini çerçeve içerisine alırSub ZeilenFärben() Dim Zeile As Range, ZeilenNr As Integer For Each Zeile In Selection.Columns ZeilenNr = ZeilenNr + 1 If ZeilenNr Mod 2 = 0 Then Zeile.Interior.ColorIndex = 6 Else Zeile.Interior.ColorIndex = xlAutomatic End If Zeile.Borders.Weight = xlThin Next End Sub
58a sütünündaki sayıları sıralar (aradan biri silinice bile sıralar)Dim say As Integer Dim i As Integer say = WorksheetFunction.CountA(Range("A2:A65000")) For i = 1 To say Cells(i + 1, 1) = i Next i
59a sütünündaki sayıları sıralar (aradan biri silinice bile sıralar) 2Sub sirala() For x = 2 To [b65536].End(3).Row Cells(x, 1).Value = x - 1 Next End Sub
60a ve c sütunundaki veriler aynıysa o satırı silsinFor C = [c65536].End(3).Row To 1 Step -1 If Cells(C, "c")=cells(C,"a") Then Rows(C).Delete Next
61a, b sütunlarını topla c'ye yazSub abtoplaCyaz() Dim i As Integer On Error GoTo 10 For i = 1 To 50 If Cells(i, 1).Value Empty And Cells(i, 2).Value Empty And _ IsNumeric(Cells(i, 1).Value) And IsNumeric(Cells(i, 2).Value) Then Cells(i, 3).FormulaR1C1 = WorksheetFunction.Sum(Val(Cells(i, 1).Value) + Val(Cells(i, 2).Value)) Else 10 MsgBox "Geçersiz değer bulundu, lütfen kontrol ediniz ", vbExclamation, "H A T A !!! " Exit Sub End If Next i End Sub -
62a,b,c sütununda arar bulurDim bul As String Private Sub CommandButton1_Click() On Error GoTo 10 bul = InputBox("LÜTFEN ARANACAK ŞUBE KODUNU YADA İSMİNİ GİRİNİZ!!!!!!") bassat = Range("A4:C65536").Find(bul).Row For a = bassat To 65536 sonsat = Range("A" & a, "C65536").Find(bul).Row Next a 10 If sonsat = 0 Then MsgBox ("ARADIĞINIZ VERİ BULUNAMADI") Exit Sub End If Range("A" & bassat, "C" & sonsat).Select End Sub
63a,b,c,d sütunundaki verilerden h1 e yaz ı1 de bulsunPrivate Sub Worksheet_Change(ByVal Target As Range) Dim Bul As Range, ilkadres, i Application.ScreenUpdating = False If Target.Address = "$H$1" Then Sayfa1.[I1:I65536].ClearContents Set Bul = Sayfa1.[A:A].Find(Target, LookAt:=xlWhole) If Not Bul Is Nothing Then ilkadres = Bul.Address i = 1 Do i = i + 1 Target(i - 1, 2) = Bul(1, 4) Set Bul = Sayfa1.[A:A].FindNext(Bul) Loop Until ilkadres = Bul.Address End If End If End Sub
64a:a sütunundaki dolu satirlarin altina boş satir eklerAÇIKLAMA: A:A sütunundaki dolu satırların altına boş satır ekler Kod: Sub ZeileEinfuegen() Dim Zeile As Integer Zeile = 2 Application.ScreenUpdating = False Do Until Range("a" & Zeile).Value = "" Rows(Zeile & ":" & Zeile).Select Selection.Insert Shift:=xlDown Zeile = Zeile + 2 Loop Range("A1").Select Application.ScreenUpdating = True End Sub
65a:a200 hücrelerindeki verilerden listbox a sadece dolu hücreleri alir. (boş hücreler gözükmez)Private Sub UserForm_Initialize() Dim myrange As Range Dim myrange As Range Set myrange = Range("A1:A200") For Each c In myrange If c.Value = ListBox1.Value Then TextBox1.Value = ListBox1.Value & c.Value.Offset(1, 0).Value End If Next End Sub
66a1 0 ise 10 ve 20.satırlar arasını gizle değilse gösterPrivate Sub Worksheet_SelectionChange(ByVal Target As Range) If [a1].Value = 0 Then Rows("10:20").EntireRow.Hidden = True Else Rows("10:20").EntireRow.Hidden = False End If End Sub
67a1 0 ise a10:a20 arasını gizle değilse gösterPrivate Sub Worksheet_SelectionChange(ByVal Target As Range) If [a1].Value = 0 Then Rows("10:20").EntireRow.Hidden = True Else Rows("10:20").EntireRow.Hidden = False End If End Sub
68a1 0 ise c10:c20 gizle 1 ise gösterPrivate Sub Worksheet_SelectionChange(ByVal Target As Range) If [a1].Value = 0 Then Rows("10:20").EntireRow.Hidden = True Else Rows("10:20").EntireRow.Hidden = False End If End Sub
69a1 1 ise b1 martsayfanın kod kısmına Private Sub Worksheet_Change(ByVal Target As Range) If Range("a1") = 1 Then Range("b1") = "Mart" End If End Sub
70a1 10 karakterden fazla ise mesaj verSub testNbCaractere() CellTest = Range("a1").Value If Len(CellTest) > 10 Then MsgBox "Pas plus de 10 caractères", vbOKOnly, "Erreur de caractères" Exit Sub End If End Sub
71a1 b1 den itibaren numaralar(kodlar) ve damgalarSub Zeichen_auslesen() Range("B1").Select ActiveCell.FormulaR1C1 = "=CHAR(ROW(RC))" Range("A1").Select ActiveCell.FormulaR1C1 = "=CODE(RC[1])" Range("A1:B1").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .ShrinkToFit = False .MergeCells = False End With With Selection.Font .Name = "Arial" .Size = 12 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With Selection.Font.Bold = True Selection.AutoFill Destination:=Range("A1:B255"), Type:=xlFillDefault Range("A1").Select End Sub
72a1 boş ise (silersen) 10 yaparPrivate Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = "$A$1" And IsEmpty(Target) = True Then Target = "10" End Sub
73a1 de adı yazan sayfayı acmakSayfa1'de A1 hücresinde "Sayfa2" yazsın. Aşağıdaki kodu kullanın. Worksheets(Range("A1").Value).Select Eğer Value'yu eklemezseniz kod çalışmayabilir. Value yerine Text' de yazabilirsiniz. Eğer bu kodu başka sayfadan çalıştıracaksanız yani Sayfa1'de değilken çalıştıracaksanız aşağıdaki kodu kullanmalısınız. Worksheets(Worksheets("Sayfa1").Range("A1").Text).Select Böyle durumlarda genelde kodun kısa ve anlaşılabilir olması için sayfalara set atamasını yapmanızı tavsiye ederim. Sub SayfaAc() Set s1 = Worksheets("Sayfa1") Worksheets(s1.Range("A1").Text).Select End Sub
74a1 de kritere göre filtreleme (süz işlemi)Range("A1").AutoFilter Field:=1, Criteria1:=">2", Operator:=xlAnd, Criteria2:=" -
75a1 de şartlı sayı vermeSub SelonCas() Nombre = ActiveCell.Value Select Case Nombre Case 1 To 5 Range("A1").Value = 0 Case 6, 7, 8, 9, 10 Range("A1").Value = 1 Case Else Range("A1").Value = 1000 End Select End Sub
76a1 deki email adresine mesaj gönderirSub Excel_Serienmail_via_Outlook_Senden() Dim OutApp As Object, Mail As Object Dim i As Integer Dim Nachricht For i = 1 To 10 'Variablen müssen bei jeder Schleife neu initalisiert werden Set OutApp = CreateObject("Outlook.Application") Set Nachricht = OutApp.CreateItem(0) With Nachricht .To = Cells(i, 1)'Adresse .Subject = Cells(i, 2) 'Betreffzeile .Body = Cells(i, 3) 'Sendetext 'Hier wird die Mail gleich in den Postausgang gelegt 'und die Sicherheitsabfrage muss jedesmall bestätigt werden '.Send 'Hier wird die Mail "angezeigt" 'aber gleich versendet,... OHNE Sicherheitsabrage .Display SendKeys "%s",True End With 'Variablen zurücksetzen sonst geht es nicht Set OutApp = Nothing 'CreateObject("Outlook.Application") Set Nachricht = Nothing 'OutApp.CreateItem(0) Application.Wait (Now + TimeValue("0:00:05")) Next i End Sub
77a1 deki formülü öğrenme‘=A1 yaz A1 deki formülü yazsın Function formul_al(hucre) If Left(hucre.Formula, 1) = "=" Then _ formul_al = Right(hucre.Formula, Len(hucre.Formula) - 1) Else _ formul_al = "" End Function
78a1 deki isimle farklı kaydetSub Speichern() test = Application.GetSaveAsFilename([a1]) If test = False Then Exit Sub ActiveWorkbook.SaveAs test End Sub
79a1 deki isimle yeni sayfa + aynısı var ikazıSub Test2() If Not Sheets("Sayfa1").Range("A1") = Empty Then For i = 1 To Worksheets.Count If Sheets(i).Name = Sheets("Sayfa1").Range("A1") Then MsgBox "Bu isimli bir sayfa mevcut..... !" Exit Sub End If Next Set NewSh = Worksheets.Add(After:=Sheets(Sheets.Count)) NewSh.Name = Sheets("Sayfa1").Range("A1") End If Set NewSh = Nothing End Sub
80a1 deki isimle yeni sayfa oluşturmaSub Test() Set NewSh = Worksheets.Add(After:=Sheets(Sheets.Count)) NewSh.Name = Sheets("Sayfa1").Range("A1") Set NewSh = Nothing End Sub
81a1 deki isimleri listboxta sıralı olarak gösterirSub List_Alphab() Dim i As Integer, j As Integer Dim Entree As String Dim Cel As Range Set Cel = Range("A1") 'Pour chaque enregistrement For i = 0 To Cel.End(xlDown).Row - 1 'Récupère la valeur Entree = Cel.Offset(i) With UserForm1 'Pour chaque valeur de la listBox For j = 0 To .ListBox1.ListCount - 1 'Si la valeur de la listbox est > à la valeur à entrer 'on récupère l'index j et on sort de la boucle If .ListBox1.List(j) > Entree Then Exit For End If Next j 'ajout de la valeur à son emplacement spécifié par l'index j .ListBox1.AddItem Entree, j End With Next i UserForm1.Show End Sub
82a1 deki kelimeyi sesli ve sessiz olarak ayırırSub Cons_Voy() Dim i As Integer Dim Chaine As String Dim Caract As String * 1 Dim Conson As String, Voyel As String Chaine = Range("A1") For i = 1 To Len(Chaine) Caract = Mid(Chaine, i, 1) Select Case LCase(Caract) Case "a", "e", "i", "o", "u", "y" Voyel = Voyel & Caract Case Else Conson = Conson + Caract End Select Next i Range("A2") = Conson Range("A3") = Voyel End Sub
83a1 den itibaren ne kadar sayfa varsa yazarSub Blattname() i = 1 For Each Blatt In Sheets Range("A" & i) = Blatt.Name i = i + 1 Next End Sub
84a1 den itibaren veri olan hücreye kadar seçerSub SelectActiveArea() Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select End Sub
85a1 den itibaren verili hücrelere 1 er satır eklerSub ValMaxi() Dim i As Integer i = 1 Do While Range("A1").Offset(i) "" Rows(i + 1).Insert i = i + 2 Loop End Sub -
86a1 den sayfa oluşturmaSub Test2() If Not Sheets("Sayfa1").Range("A1") = Empty Then For i = 1 To Worksheets.Count If Sheets(i).Name = Sheets("Sayfa1").Range("A1") Then MsgBox "Bu isimli bir sayfa mevcut..... !" Exit Sub End If Next Set NewSh = Worksheets.Add(After:=Sheets(Sheets.Count)) NewSh.Name = Sheets("Sayfa1").Range("A1") End If Set NewSh = Nothing End Sub
87a1 den sıra numarası verir veya aktif satır numarasını versin(klavye-fare seç)Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) rowoffset = 0 Intersect(ActiveCell.EntireRow, Columns("A")).Value = ActiveCell.Row + rowoffset End Sub
88a1 devamlı a2 de toplanacakPrivate Sub Worksheet_Change(ByVal Target As Range) Static kod If Target.Address = "$A$1" Then Range("A2").Value = kod + Target End If kod = Target.Value End Sub
89a1 e değer girin ce makro kodları çalıştırmaPrivate Sub Worksheet_Change(ByVal Target As Excel.Range) If Not Intersect(Target, Range("a1")) Is Nothing Then "MAKROCODE" End If End Sub
90a1 e değer girince 10 ile çarp a2 ye yazSub RecupValeur() Dim Val1 'Dim Resultat As Integer (pour un résultat en entier) Val1 = Sheets("Feuil1").[a1].Value Resultat = Val1 * 10 Sheets("Feuil1").[a2].Value = (Resultat) MsgBox "Opération effectuée." & Chr(13) & Chr(13) _ & "Résultat :" & CStr(Resultat) End Sub
91a1 e her veri girişinde b1,c1 sırasıyla hep yan kolona artarak yazarPrivate Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = "$A$1" Then Set actcell = [C1] Do While actcell "" Set actcell = actcell.Offset(0, 1) Loop actcell.Value = Target.Value End If End Sub -
92a1 e kullanıcı adını yazdırmaSub Username() Range("A1").Value = Environ("USERNAME") End Sub
93a1 e mail linki vermek ve outloook’u a1 deki maille açmaSub HyperlinkEmail() Range("A1").Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="mailto:mahmut_bayram38@hotmail.com" End Sub Sub HyperlinkAktive() Range("A1").Select Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True End Sub
94a1 e mesajla veri girme ve mesaj kutusunda a1 deki veriyi görmeSub Vorschlagwert_in_InputBox() Dim vorschlag As String vorschlag = InputBox("Geben Sie bitte einen Namen ein", "Name", Range("A1").Value) If vorschlag = "" Then Exit Sub Range("A1").Value = vorschlag End Sub
95a1 e sadece rakam girer (yazı girince 0 yapar) ve devamlı a1 de toplarPrivate Sub Worksheet_Change(ByVal Target As Excel.Range) Static dAccumulator As Double With Target If .Address(False, False) = "A1" Then If Not IsEmpty(.Value) And IsNumeric(.Value) Then dAccumulator = dAccumulator + .Value Else dAccumulator = 0 End If Application.EnableEvents = False .Value = dAccumulator Application.EnableEvents = True End If End With End Sub
96a1 e tarihi gir b1 de kaçıncı hafta olduğunu bulsunB1 e aşağıdaki formülü gir =NSAT((A1-HAFTANINGÜNÜ(A1;2)-TARİH(YIL(A1+4-HAFTANINGÜNÜ(A1;2));1;-10))/7)
97a1 e veri girildikten sonra 100 e bölünmesiPrivate Sub Worksheet_Change(ByVal Target As Excel.Range) Application.EnableEvents = False If Target.AddressLocal = "$A$1" Then Target = Target / 100 End If Application.EnableEvents = True End Sub
98a1 e veri yazılınca solda üstbilgi eklemePrivate Sub Worksheet_Change(ByVal Target As Range) If (Target = Range("A1")) Then Worksheets("Tabelle1").PageSetup.LeftHeader = Range("A1") End If End Sub
99a1 e yaz b1 de devamlı toplasınPrivate Sub Worksheet_Change(ByVal Target As Excel.Range) With Target If .Address(False, False) = "A1" Then If IsNumeric(.Value) Then Application.EnableEvents = False Range("B1").Value = Range("B1").Value + .Value Application.EnableEvents = True End If End If End With End Sub
100a1 e yazılan (i) harfinin 90 derece yatık olmasıPrivate Sub Worksheet_Change(ByVal Target As Range) If Not Application.Intersect(Target, Range("A1")) Is Nothing Then Target.Orientation = 0 If Target = "I" Then Target.Orientation = 90 End If End If End Sub