Çözüldü Yazının sonundan sonra hep aynı mesafede imza hanesinin açılması

[By.TRabZonLutm]

İmza kaşe bloku ile ilgili 3 adet örnek daha ekliyorum. Mümkün olduğunca font çeşitliliği eklendi. Bunlar üzerinde oynanarak kendi stilimizi elde edebiliriz.

Örnek 1
Hücreye düz yazı yazar gibi imza bloku eklemek:

Sub imza_Duz_Yazi()
Dim imz As Range

Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 10, 7)
With imz
    .Offset(0, 0).Resize(3, 3).Merge
    .Value = "ABC FİRMASI LTD. ŞTİ." & vbLf & "Ali Veli Selami" & vbLf & "Gn.Md."
    .Characters(1, 21).Font.Color = vbRed
    .Characters(1, 21).Font.Bold = True
    .Characters(22, Len(imz)).Font.Color = vbBlack
End With
End Sub

Örnek 2
Hücreye imza blokunu metin kutusu olarak eklemek:

Sub imza_Kutu_Ekle2()
Dim imz As Range
Dim sh As Shape

With ActiveSheet
    On Error Resume Next
    .Shapes("imzam").Delete
    On Error GoTo 0

    Set sh = .Shapes.AddTextbox(msoTextOrientationHorizontal, 30, 50, 150, 50)
    With sh
        .Select
        .Line.Visible = msoFalse
        .TextFrame.Characters.Text = "ABC FİRMASI LTD. ŞTİ." & Chr(13) & "Ali Veli Selami" & Chr(13) & "Gn.Md."
        .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .TextFrame.Characters.Font.Name = "Tahoma"
        .TextFrame.Characters.Font.Size = 10
        .TextFrame.Characters.Font.Bold = msoTrue
        .TextFrame2.TextRange.Paragraphs(2).Font.Size = 12
        .TextFrame2.TextRange.Paragraphs(2).Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
        .Name = "imzam"
        Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 10, 7)
        .Top = imz.Top
        .Left = imz.Left
        imz.Select
    End With
End With
End Sub

Örnek 3
Hücreye imza blokunu daha önceden klasöre kaydedilen kaşe resmi olarak eklemek:

Sub imza_Resim()
Dim hcr As Range, PicFile As String, resim As Shape
Dim PicTop As Integer, PicLeft As Integer, PicW As Integer, PicH As Integer

With ActiveSheet
    On Error Resume Next
    .Shapes("imzam").Delete
    On Error GoTo 0
'imza resminin bulunduğu konum
    PicFile = ThisWorkbook.Path & "\" & "imzam.jpg"
   
    If Dir(PicFile) = Empty Then
        MsgBox "Resim bulunamadı..!", vbCritical
        Exit Sub
    End If
'Son satırdan 10 satır aşağıda ve 7. sütun hizasında
    Set hcr = .Cells(Cells(Rows.Count, 1).End(3).Row + 10, 7)
    PicTop = hcr.Top
    PicLeft = hcr.Left
    PicW = 150  'imza genişliği
    PicH = 90   'imza yüksekliği
    Set resim = .Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
    resim.Name = "imzam"
End With

End Sub

Hocam denedim çok güzel çalışıyor. Tek bir eksiği kaldı. Ben sırayla yazdiracagim zaman , yazdirmadan önce hep makro çalıştırmam gerekiyor ki belirttiğimiz bölüme gelsin. Ben hiç uğraşmadan sürekli aktif olsa otomatik olarak o bölüme kendisi gelse

 

[necati]

Excelin yazdırmadan önce otomatik çalışan prosedürü var. Onu kullanabilirsiniz. Mesela "Thisworkbook" koduna aşağıdaki gibi bir kod yazarsanız, "imza_Resim" adlı makro otomatikman devreye girer. "imza_Resim" çalışacak makronun ismidir. Siz dilediğiniz makro ismini buraya yazın.

Private Sub Workbook_BeforePrint(Cancel As Boolean)
imza_Resim
End Sub

 

[By.TRabZonLutm]

Excelin yazdırmadan önce otomatik çalışan prosedürü var. Onu kullanabilirsiniz. Mesela "Thisworkbook" koduna aşağıdaki gibi bir kod yazarsanız, "imza_Resim" adlı makro otomatikman devreye girer. "imza_Resim" çalışacak makronun ismidir. Siz dilediğiniz makro ismini buraya yazın.

Private Sub Workbook_BeforePrint(Cancel As Boolean)
imza_Resim
End Sub

çok teşekkür ederim ilginiz için muazzam oldu.

 

[By.TRabZonLutm]

Excelin yazdırmadan önce otomatik çalışan prosedürü var. Onu kullanabilirsiniz. Mesela "Thisworkbook" koduna aşağıdaki gibi bir kod yazarsanız, "imza_Resim" adlı makro otomatikman devreye girer. "imza_Resim" çalışacak makronun ismidir. Siz dilediğiniz makro ismini buraya yazın.

Private Sub Workbook_BeforePrint(Cancel As Boolean)
imza_Resim
End Sub

Hocam işyerinde denedim fakat şöyle bir hata alıyorum. Thisworkbook adında sol tarafta bir isim yok. BuCalismaKitabi bölümüne aşağıdaki kodu ekledim ama hata alıyorum yazdirmadan önce. Makro da çalışmıyor.

 

[necati]

Thisworkbook ile BuCalismaKitabi aynı şeydir.
Kullandığınız imza makrosunu işyerindeki bilgisayarda bir modül içine kopyalamalısınız. Sanırım bu işlemi yapmadınız.

 

[By.TRabZonLutm]

Thisworkbook ile BuCalismaKitabi aynı şeydir.
Kullandığınız imza makrosunu işyerindeki bilgisayarda bir modül içine kopyalamalısınız. Sanırım bu işlemi yapmadınız.

Kesinlikle öyle yapmamisim.

İmza kısmını adı soyadı, unvanı, ve görevi bölümünü excelde bir yerden çekmesi için kutucuklu kodu nasıl düzeltmem gerekir. ( İmza atan farklı olunca her seferinde kodu düzeltmem gerekiyor)

 

[necati]

Ben bir örnek veriyorum, buna benzer şekilde yapabilirsiniz. M1 de firma adı, M2 de isim, M3 de ünvan varsa:
.TextFrame.Characters.Text = Trim(Range("M1")) & Chr(13) & Trim(Range("M2")) & Chr(13) & Trim(Range("M3"))

 

[By.TRabZonLutm]

Ben bir örnek veriyorum, buna benzer şekilde yapabilirsiniz. M1 de firma adı, M2 de isim, M3 de ünvan varsa:
.TextFrame.Characters.Text = Trim(Range("M1")) & Chr(13) & Trim(Range("M2")) & Chr(13) & Trim(Range("M3"))

sonsuz teşekkür ederim, tüm işim çözülmüş oldu. Helal olsun !

 

[necati]

Rica ederim.

 

[By.TRabZonLutm]

Rica ederim.

Hocam tekrar merhaba . Birleştirilmiş hücrelerde kelimenin son satırından nasıl yapabiliriz. Birleştirilmiş olduğu için ilk hücreden alıyor bu sefer de sonuç istedigimiz gibi olmuyor

 

[necati]

Rica etsem örnek üzerinden hatalı durumu gösterebilir misiniz? Hangi makroyu kullanıyorsunuz, birleştirilmiş hücreler nerelerde bulunuyor?

 

[By.TRabZonLutm]

Rica etsem örnek üzerinden hatalı durumu gösterebilir misiniz? Hangi makroyu kullanıyorsunuz, birleştirilmiş hücreler nerelerde bulunuyor?

Yazı başlangıç hücresi A1 , hücreler birleştirildiği için sürekli A1 hücresinden baz alıyor. Metin azaldıkça imza blogu aynı yerde kalıyor.
Birleştirilen hücrenin en sonundaki satırdan alarak imza bloğunu yerlestirsin istiyorum hocam

Sub imza_Kutu_Ekle2()
Dim imz As Range
Dim sh As Shape

With ActiveSheet
    On Error Resume Next
    .Shapes("imzam").Delete
    On Error GoTo 0

    Set sh = .Shapes.AddTextbox(msoTextOrientationHorizontal, 30, 50, 150, 50)
    With sh
        .Select
        .Line.Visible = msoFalse
        .TextFrame.Characters.Text = Trim(Range("M1")) & Chr(13) & Trim(Range("M2")) & Chr(13) & Trim(Range("M3"))
        .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .TextFrame.Characters.Font.Name = "Tahoma"
        .TextFrame.Characters.Font.Size = 10
        .TextFrame.Characters.Font.Bold = msoTrue
        .Name = "imzam"
        Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 10, 7)
        .Top = imz.Top
        .Left = imz.Left
        imz.Select
    End With
End With
End Sub

 

[necati]

Ekli resimleri göremiyorum. Tahmin ile bir cevap verebilirim.
Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 10, 7)
Buradaki , 7 (virgülden sonraki yedi) yedinci sütuna göre yani "G" ye göre son satırı belirle demektir. İşinize yarayacak olan bir sütun numarasını buraya yazıp deneyin.

 

[By.TRabZonLutm]

Ekli resimleri göremiyorum. Tahmin ile bir cevap verebilirim.
Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 10, 7)
Buradaki , 7 (virgülden sonraki yedi) yedinci sütuna göre yani "G" ye göre son satırı belirle demektir. İşinize yarayacak olan bir sütun numarasını buraya yazıp deneyin.

Hocam birleştirilmiş hucre olduğu için A1 i hep baz alıyor. Metin kisalsa da imza aynı yerde kalıyor.

İmza blogu aynı yerde. Metin azalsa da aynı. Birleştirilmemis hücrelerde sorun yok son satırdaki yazıdan sonra boşluk bırakıyor. Birleştirilmiş hücrelerde birleştirilen hücrenin ilk hücresini baz alıyor hocam

 

[necati]

Yine tahmini bir cevap veriyorum. Satır belirleyen kodumuz buydu.
Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 10, 7)
Bu koda "A1" deki birleştirilmiş hücrelerin satır uzunluğunu ekletebiliriz.
Bir hücre standart olarak 15 piksel olduğuna göre
Range("A1").RowHeight /15 ekkletelim. Yeni satırı şu şekilde dener misiniz.
Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 10 + Range("A1").RowHeight /15, 7)

 

[By.TRabZonLutm]

Yine tahmini bir cevap veriyorum. Satır belirleyen kodumuz buydu.
Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 10, 7)
Bu koda "A1" deki birleştirilmiş hücrelerin satır uzunluğunu ekletebiliriz.
Bir hücre standart olarak 15 piksel olduğuna göre
Range("A1").RowHeight /15 ekkletelim. Yeni satırı şu şekilde dener misiniz.
Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 10 + Range("A1").RowHeight /15, 7)

Denedim hocam. Fakat olmadı. Aşağı ve yana doğru birleştirilen hücrelerde imza bloğu sabit bir yerde kalıyor.

Görsel size nasıl ulaştırabilirsiniz. Hızliresim sitesine yükledim fakat yine acamadiniz galiba.

https://i.hizliresim.com/981xn9u.png

https://i.hizliresim.com/edss0vl.png

 

[necati]

Metnin bir kısmı silinmiş fakat boşalan yerlerde satır yüksekliği kapatılmamış. Dolayısıyla teknik olarak her iki metin de aynı yüksekliğe sahip.

 

[By.TRabZonLutm]

Metnin bir kısmı silinmiş fakat boşalan yerlerde satır yüksekliği kapatılmamış. Dolayısıyla teknik olarak her iki metin de aynı yüksekliğe sahip.

Metni otomatik olarak çektiğini düşünün hocam. Bazılarında çok fazla bazılarında çok az olabiliyor. Hücre birleştirilmiş olduğu için hep A1 i baz alıyor ama halbuki metin kısmı az.. sayfanın yapısı ile maalesef ki oynamıyorum. Her seferinde metin yüksekliği satır kisaltsam bu sefer de imza bloğunun anlamı kalmıyor maalesef

 

[necati]

Satır yüksekliğini de makro içine alalım. Rows("1:1").RowHeight = uzunluk * 0.45 buradaki 0.45 satır yüksekliği ayarlama katsayısıdır. Gerektiği kadar +/- oynayınız.

Sub imza_Kutu_Ekle3()
Dim imz As Range
Dim sh As Shape
Dim uzunluk As Long

With ActiveSheet
    On Error Resume Next
    .Shapes("imzam").Delete
    On Error GoTo 0

    Set sh = .Shapes.AddTextbox(msoTextOrientationHorizontal, 30, 50, 150, 50)
    With sh
        .Select
        .Line.Visible = msoFalse
        .TextFrame.Characters.Text = Trim(Range("M1")) & Chr(13) & Trim(Range("M2")) & Chr(13) & Trim(Range("M3"))
        .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .TextFrame.Characters.Font.Name = "Tahoma"
        .TextFrame.Characters.Font.Size = 10
        .TextFrame.Characters.Font.Bold = msoTrue
        .Name = "imzam"
        uzunluk = Len(Range("A1"))
        Rows("1:1").RowHeight = uzunluk * 0.45
        Set imz = Cells(Cells(Rows.Count, 1).End(3).Row + 0 + (Range("a1").RowHeight / 15), 7)
        .Top = imz.Top
        .Left = imz.Left
        imz.Select
    End With
End With
End Sub