Seçili sütunların genişliklerin cm cinsinden toplamak,

[hsayar]

Sub sutun()
On Error Resume Next
Dim genislik As Single, mevcut As Single, text As String, cevap As String

mevcut = (Selection.ColumnWidth + 0.71) / 5.1425
text = "Mevcut sütun genişliği: " & Format(mevcut, "###0.00 cm") & Chr(13) & "Yeni sütun genişliğini girin:"
10
cevap = InputBox(text, "Yeni sütun genişliğini girin (cm)", Format(mevcut, "###0.00"))

    If cevap = "" Then Exit Sub

    If Not IsNumeric(cevap) Then
        MsgBox "Girdiğiniz değer sayı değil. Lütfen kontrol ediniz.", vbInformation
        GoTo 10
    End If

    If cevap < 0 Or cevap > 49.72 Then
        MsgBox "S&#252;tun geni&#351;li&#287;i  0 ile 49,72 cm  aras&#305;nda olmal&#305;d&#305;r.", vbInformation
        GoTo 10
    Else
        genislik = CSng(cevap)
        Selection.ColumnWidth = -0.71 + 5.1425 * genislik
    End If
End Sub

kodları ile sütunların genişliklerini cm cinsinden ayarlayabiliyoruz peki seçili alanın sütun başlıklarını genişliklerini toplamak (mesala A:F)mümkünmü

Sub WrdKopya()
Dim objword As Object
fName = Application.InputBox("Dosya ismi girin...", "Dosya")
'If fName <> 0 Then
'ActiveSheet.Name = fName
Range("A1:F100").Copy
Set objword = CreateObject("Word.Application")
objword.Visible = True
Set Mydoc = objword.Documents.Add(DocumentType:=wdNewBlankDocument)
objword.Selection.PasteSpecial Link:=False, DataType:=10
objword.activedocument.SaveAs "C:\" & fName & ".doc"
'End If
End Sub

kodları ile a:f aralığını worde kopyalyıruz eğer sütun genişlikleri toplamı 16 cm den büyükse word dosyasını yatay olarak ayarlayacak, 24,7 deb büyükse tablonuz wordde boyutlandırılamayacaktır...... diye uyarı verecek mümkünmü?

parça parça cevapda kabul edilir.

 

[isfa5878]

Private Sub CommandButton1_Click()
Range("k1").Value = Range("C1").ColumnWidth + Range("d1").ColumnWidth + Range("e1").ColumnWidth
End Sub

cm ye çevirmek şart değil ki If li koda piksel yazın

 

[isfa5878]

Private Sub CommandButton1_Click()
If Range("k1").Value > 16 Then
MsgBox " olumsuz"
End If
End Sub

veya

Private Sub CommandButton1_Click()
If Range("C1").ColumnWidth + Range("d1").ColumnWidth + Range("e1").ColumnWidth > 16 Then
MsgBox " tablonuz wordde boyutlandırılamayacaktır"
End If
End Sub

 

[hsayar]

teşekkürler... yarın uyarlayacam neticeden bilig veririm bir üyeenin sorusnu çözecem banada lazım zaten

hocam işe yaramıyuor normal sütun genişiliğini 5 yaptım üç hücre 15 yapar yine boyutlandırlamayacktır diyor.

 

[isfa5878]

mesaj kodunu şöyle değiş bakalım ne çıkacak......
gerçekten senin koyduğun sınırdan küçükmüymüş?

MsgBox " tablonuz wordde boyutlandırılamayacaktır" & Range("C1").ColumnWidth + Range("d1").ColumnWidth + Range("e1").ColumnWidth

 

[hsayar]

hocam sonu doğru ama 8,23*3=25,29 sütun genişliği (exce cinsinden bilmiyorum) ama cm cinsinde karşılaştırma yapması lazım.
dur ben uğraşayım onu örnek var nasılsa olmazsa yazarım.

 

[hsayar]

ExcGenTop = (Range("C1").ColumnWidth + 0.71) / 5.1425 + _
            (Range("D1").ColumnWidth + 0.71) / 5.1425 + _
            (Range("E1").ColumnWidth + 0.71) / 5.1425 '+ _

çözdüm işi

 

[mesuttasar]

Sayın hsayar, ilk mesajınızdaki kodda 10 yazısını gördüm.Go to 10 atamaları yapmışsınız. Bunu ünv dönemide gördüğüm Quick Basic te rakamlarla yazıyorduk programı.

Aynı şey bizim vba da da kullanılabiliyormu?
Kodu kopyaladım çalışıyor .

Teşekkürler.

 

[hsayar]

kullanılıyormuş kod alıntı zaten
http://www.excel.web.tr/showthread.php?t=40538
örnek kullanım için dosyayı inceleyin isterseniz... sorunuz varsa o başlıkta sorun lütfen

 

[hsayar]

Sütun genişliklerini nokta cinsinden toplamak (çevirmeden) mümkünmüdür?