Kesim2019

DKTY KESİM MERKEZİ

2019 yılı

KNO	DURUM	KESIM SAAT	MASA SAAT	MASA NO	TESLIM SAAT

Excelden Outlook toplantı verilerini Aktarma

Sub Outlook_Takvime_Gonder()
    Dim EvnOUT As Object, OutRandevu As Object, say As Long
    say = 0
    For s = 3 To Range("C65536").End(xlUp).Row
    If Cells(s, "B") <> "OK" Then
    
    On Error Resume Next
    Set EvnOUT = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Set EvnOUT = CreateObject("Outlook.application")
    End If
    On Error GoTo 0
    Set OutRandevu = EvnOUT.CreateItem(1)
    On Error Resume Next
        With OutRandevu
            .Start = Cells(s, "C") + Cells(s, "D")
            .End = Cells(s, 5) + Cells(s, 6)
            .Subject = Cells(s, 7)
            .Location = Cells(s, 8)
            .Body = Cells(s, "I")
            If Len(Cells(s, "J")) > 0 Then
                If IsNumeric(Cells(s, "J")) Then
                    .ReminderMinutesBeforeStart = Cells(s, "J")
                    .ReminderSet = True
                End If
            End If
            If Err <> 0 Then
                Cells(s, "B") = "HATA"
            Else
                .Save
                Cells(s, "B") = "OK"
                Err = 0
                say = say + 1
            End If
        End With
    

    Set EvnOUT = Nothing
    Set OutRandevu = Nothing
    End If
    Next s
    If say > 0 Then
        MsgBox say & " adet kayıt aktarıldı.", vbInformation
    Else
        MsgBox "Aktarılan kayıt yok!", vbExclamation
    End If
End Sub

Örnek excel_dosyası indir

Excel VBA Hücreye Açıklama Ekleme

Sub AciklamaEkle()

   Dim S1 As Worksheet

   Set S1 = Worksheets("Sayfa1")

   Call Aciklama_Ekle (S1.Cells(1, 1), "Açıklama Eklendi")

End Sub

Function Aciklama_Ekle(hucre As Range, note As String)

   Dim cmt As Comment

   Set cmt = hucre.Comment

   If cmt Is Nothing Then

      Set cmt = hucre.AddComment

      cmt.Text Text:=note

   Else

      note = note & Chr(10) & cmt.Text

      cmt.Text Text:=note

      If cmt.Shape.Height < 150 Then cmt.Shape.Height = cmt.Shape.Height + 20

   End If

   cmt.Visible = False

End Function

Excel VBA Hücreye link verme

Sub linkverdene()

   Dim S1 As Worksheet

   Dim S2 As Worksheet

   Set S1 = Worksheets("Sayfa1")

   Set S2 = Worksheets("Sayfa2")

   Call linkver(S1.Cells(1, 1),S2.Cells(1, 1))

   Call linkver(S2.Cells(1, 1),S1.Cells(2, 1))

End Sub

  

Function linkver(nereye As Range, neresi As Range)

     Dim adres As String

     adres = neresi.Address(RowAbsolute:=False)

     Mid(adres, 1, 1) = "!"

     adres = neresi.Worksheet.Name & adres

     nereye.Hyperlinks.Add nereye, Address:="", SubAddress:=adres, ScreenTip:=adres

End Function