Excel'le Adım Adım Program Yazma

Aktif sayfada rakama göre zemin rengi verme


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
End Sub

Aktif sayfada rakama göre zemin rengi verme2


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
End Sub

Aktif sayfada rakamla kelime birleştirme

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
End Sub

Aktif sayfada tüm hücrelerde aynı hücreye devamlı rakam yaz, toplasın

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.DisplayCommentInd icator = 0
    End If
ErrorHandler:
    Application.EnableEvents = True
End Sub

Aktif sayfada Üst bilgi "my report" yazar "a1 den alır" (14 punto)

Sub Printr()
    ActiveSheet.PageSetup.CenterH eader = "&""Arial,Bold Italic""&14My Report" & Chr(13) _
        & Sheets(1).Range("A1")
    ActiveWindow.SelectedSheets.P rintOut Copies:=1
End Sub

Aktif sayfada veri girilen hücrelere veri girildiği tarih ve saati açıklama olarak ekler

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.BuiltinDocumen tProperties(7).Value & " geändert."
End Sub
'Modül bölümüne
Sub Kommentare_löschen()
    Application.DisplayCommentInd icator = xlCommentAndIndicator
    Cells.Select
    Selection.ClearComments
    Range("A1").Select
    Selection.ClearComments
    Application.CommandBars("Reviewing").Visible = False
    Application.DisplayCommentInd icator = xlCommentIndicatorOnly
End Sub

Aktif sayfada yazı yaz tarih ve saat,dakika,saniyesi ile açıklama ekler ve açıklamaları siler.

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.BuiltinDocumen tProperties(7).Value & " geändert." End Sub

Sub Kommentare_löschen()
    Application.DisplayCommentInd icator = xlCommentAndIndicator
    Cells.Select
    Selection.ClearComments
    Range("A1").Select
    Selection.ClearComments
    Application.CommandBars("Reviewing").Visible = False
    Application.DisplayCommentInd icator = xlCommentIndicatorOnly
End Sub

Aktif sayfada yazılan harfler büyük

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Target = UCase(Target)
End Sub

Aktif sayfada yazılan kelimeler büyü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

Aktif sayfadaki dikdörtgendeki yazıyı hücreye kopyalar

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
End Sub

Aktif sayfadaki formülleri bulur yeni sayfaya listeler


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
End Sub

Aktif sayfadan modüldeki makroyu çalıştırma


Option Explicit
Const hedefsahife = "Sayfa1"

Sub auto_open()
    Worksheets(hedefsahife).OnDoubleClick = "pir"
End Sub

Sub auto_close()
    Worksheets(hedefsahife).OnDoubleClick = ""
End Sub

Sub pir()
MsgBox "a ha da çalıştı"
End Sub

Aktif sayfanın adını aktif hücreye yazdırır

Sub sayfaismi()
ActiveCell.Value = ActiveSheet.Name
End Sub

Aktif sayfanın ismi a1 hücresinde


Sub A1nomfeuil()
Application.ScreenUpdating = False
For Each x In ActiveWorkbook.Sheets
x.Activate
[A1] = ActiveSheet.Name
Next
End Sub

Aktif sayfanın ismi sayfa1 ise dosya kapanmasıın

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If ActiveSheet.Name = "Liste2" Then
        Cancel = True
    End If
End Sub

'Aktif sayfa ismi
Sub ornek()
MsgBox "Active Sheet : " & ActiveSheet.Name
End Sub