- Katılım
- 5 Ocak 2009
- Mesajlar
- 1,586
- Excel Vers. ve Dili
- 2003 Türkçe
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub Kenarlik()
Dim CizgiKalinligi As Integer, _
SonSat As Long, _
i As Long, _
BasSat As Long, _
SonKol As Integer, _
DoluAdet As Integer, _
Rng As String
SonSat = Selection.SpecialCells(xlCellTypeLastCell).Row + 1
SonKol = Range("B5").End(xlToRight).Column
CizgiKalinligi = 3
Application.ScreenUpdating = False
ActiveWindow.DisplayGridlines = False
Cells.Borders.LineStyle = xlNone
For i = 6 To SonSat
If Not Cells(i, "B") = "" Then BasSat = i
DoluAdet = Application.WorksheetFunction.CountA(Range(Cells(i, "B"), Cells(i, SonKol)))
If DoluAdet > 0 And BasSat = 0 Then BasSat = i
If DoluAdet = 0 And BasSat > 0 Then
Rng = Range(Cells(BasSat, "B"), Cells(i - 1, SonKol)).Address
Cizdir Rng, CizgiKalinligi
BasSat = 0
End If
Next i
Application.ScreenUpdating = False
MsgBox "İşlem Tamamdır", vbInformation, "N.YEŞERTENER - [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub
Sub Cizdir(Adres As String, CizgiKalinligi)
Range(Adres).Borders.Weight = 1
With Range(Adres).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = CizgiKalinligi
End With
With Range(Adres).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = CizgiKalinligi
End With
With Range(Adres).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = CizgiKalinligi
End With
With Range(Adres).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = CizgiKalinligi
End With
End Sub
Merhaba,
Hem kodları hem dosyayı yeniledim.
Hücrelerin içi de çizildi. Satır ve Sütuna bağılımlı olmadan tabloyu genişletebilirsiniz.
Güle güle kullanın.
SonSat = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
olarak değiştirdim dediğinizi denemiştim ki sizde yanıtınızı değiştirmişsiniz
Çünkü F sütununun epey aşağısına yazdığım değeri görmemişti.
Aynı sorun Sayın dentex'in kodlarında da var. aşağılara yazılan değerleri dikkate almıyor.
SonSat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Merhaba,
Necdet üstadın kodları yanında el yapımı gibi olmuş ama alternatif olsun.
Çizim kısmı macro kaydet ile yapılmıştır. iyi çalışmalar.
Satırında "Run-time error 438" hatasını veriyor..TintAndShade = 0
.TintAndShade = 0
Option Explicit
Sub KENARLIK_ÇİZ()
Dim X1 As Long, X2 As Integer, X3 As Long, X4 As Integer, Kontrol As Boolean
Dim Son_Satır As Long, Son_Sütun As Integer, İlk As Long, Son As Long
Dim Dış_Çizgi_Stili As Variant, Dış_Çizgi_Kalınlığı As Variant
Dim İç_Çizgi_Stili As Variant, İç_Çizgi_Kalınlığı As Variant
Dim İlk_Satır As Variant, İlk_Sütun As Variant, Adres As String, Onay As Byte
İlk_Satır = Application.InputBox("Lütfen tablonuzun başlangıç satır değerini giriniz !" _
& Chr(10) & Chr(10) & "Örnek : 1 gibi")
If İlk_Satır = "" Or İlk_Satır = False Then
MsgBox "İşleme devam edebilmek için tablonuzun başlangıç satır değerini girmeniz gerekiyor !", vbCritical
Exit Sub
ElseIf Not IsNumeric(İlk_Satır) Then
MsgBox "Lütfen sayısal değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Satır Girişi"
Exit Sub
End If
If İlk_Satır <= 0 Or İlk_Satır > Rows.Count Then
MsgBox "Lütfen 1-" & Rows.Count & " değerleri arasında giriş yapınız !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Satır Girişi"
Exit Sub
End If
İlk_Sütun = Application.InputBox("Lütfen tablonuzun başlangıç sütun değerini giriniz !" _
& Chr(10) & Chr(10) & "Örnek : A gibi")
If İlk_Sütun = "" Or İlk_Sütun = False Then
MsgBox "İşleme devam edebilmek için tablonuzun başlangıç sütun değerini girmeniz gerekiyor !", vbCritical
Exit Sub
ElseIf IsNumeric(İlk_Sütun) Then
MsgBox "Lütfen metinsel değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Sütun Girişi"
Exit Sub
End If
If Columns.Count = 256 Then
If İlk_Sütun < "A" Or İlk_Sütun > "IV" Then
MsgBox İlk_Sütun & " bu isimde bir sütun yok !" & Chr(10) & Chr(10) & "Lütfen A-IV" & " değerleri arasında giriş yapınız !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Sütun Girişi"
Exit Sub
End If
End If
If Columns.Count = 16384 Then
If İlk_Sütun < "A" Or İlk_Sütun > "IV" Then
MsgBox İlk_Sütun & " bu isimde bir sütun yok !" & Chr(10) & Chr(10) & "Lütfen A-XFD" & " değerleri arasında giriş yapınız !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Sütun Girişi"
Exit Sub
End If
End If
If Cells(1, İlk_Sütun).Column <= 0 Or Cells(1, İlk_Sütun).Column > Columns.Count Then
MsgBox "Lütfen 1-" & Columns.Count & " değerleri arasında giriş yapınız !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Sütun Girişi"
Exit Sub
End If
Dış_Çizgi_Stili = Application.InputBox("Lütfen uygulamak istediğiniz dış çizgi stili değerini giriniz !" _
& Chr(10) & Chr(10) & "1-13 arası bir değer giriniz !", , 3)
If Dış_Çizgi_Stili = "" Or Dış_Çizgi_Stili = False Then
MsgBox "İşleme devam edebilmek için uygulamak istediğiniz dış çizgi stili değerini girmeniz gerekiyor !", vbCritical
Exit Sub
ElseIf Not IsNumeric(Dış_Çizgi_Stili) Then
MsgBox "Lütfen sayısal değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Dış Çizgi Stili Girişi"
Exit Sub
ElseIf Dış_Çizgi_Stili < 1 Or Dış_Çizgi_Stili > 13 Then
MsgBox "Lütfen 1-13 arası bir değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Dış Çizgi Stili Girişi"
Exit Sub
End If
Dış_Çizgi_Kalınlığı = Application.InputBox("Lütfen uygulamak istediğiniz dış çizgi kalınlık değerini giriniz !" _
& Chr(10) & Chr(10) & "1-3 arası bir değer giriniz !", , 3)
If Dış_Çizgi_Kalınlığı = "" Or Dış_Çizgi_Kalınlığı = False Then
MsgBox "İşleme devam edebilmek için uygulamak istediğiniz dış çizgi kalınlık değerini girmeniz gerekiyor !", vbCritical
Exit Sub
ElseIf Not IsNumeric(Dış_Çizgi_Kalınlığı) Then
MsgBox "Lütfen sayısal değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Dış Çizgi Kalınlığı Girişi"
Exit Sub
ElseIf Dış_Çizgi_Kalınlığı < 1 Or Dış_Çizgi_Kalınlığı > 3 Then
MsgBox "Lütfen 1-3 arası bir değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı Dış Çizgi Kalınlığı Girişi"
Exit Sub
End If
İç_Çizgi_Stili = Application.InputBox("Lütfen uygulamak istediğiniz iç çizgi stili değerini giriniz !" _
& Chr(10) & Chr(10) & "1-13 arası bir değer giriniz !", , 8)
If İç_Çizgi_Stili = "" Or İç_Çizgi_Stili = False Then
MsgBox "İşleme devam edebilmek için uygulamak istediğiniz iç çizgi stili değerini girmeniz gerekiyor !", vbCritical
Exit Sub
ElseIf Not IsNumeric(İç_Çizgi_Stili) Then
MsgBox "Lütfen sayısal değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı İç Çizgi Stili Girişi"
Exit Sub
ElseIf İç_Çizgi_Stili < 1 Or İç_Çizgi_Stili > 13 Then
MsgBox "Lütfen 1-13 arası bir değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı İç Çizgi Stili Girişi"
Exit Sub
End If
İç_Çizgi_Kalınlığı = Application.InputBox("Lütfen uygulamak istediğiniz iç çizgi kalınlık değerini giriniz !" _
& Chr(10) & Chr(10) & "1-3 arası bir değer giriniz !", , 3)
If İç_Çizgi_Kalınlığı = "" Or İç_Çizgi_Kalınlığı = False Then
MsgBox "İşleme devam edebilmek için uygulamak istediğiniz iç çizgi kalınlık değerini girmeniz gerekiyor !", vbCritical
Exit Sub
ElseIf Not IsNumeric(İç_Çizgi_Kalınlığı) Then
MsgBox "Lütfen sayısal değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı İç Çizgi Kalınlığı Girişi"
Exit Sub
ElseIf İç_Çizgi_Kalınlığı < 1 Or İç_Çizgi_Kalınlığı > 3 Then
MsgBox "Lütfen 1-3 arası bir değer giriniz !" & Chr(10) & "İşleminiz iptal edilmiştir !", vbCritical, "Hatalı İç Çizgi Kalınlığı Girişi"
Exit Sub
End If
Application.ScreenUpdating = False
If WorksheetFunction.CountA(Cells) > 0 Then
Son_Satır = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
If WorksheetFunction.CountA(Cells) > 0 Then
Son_Sütun = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
End If
Adres = Cells(İlk_Satır, İlk_Sütun).Address & ":" & Cells(Son_Satır, Son_Sütun).Address
Onay = MsgBox(Adres & " hücrelerinin kenarlıklarını değiştirmek istiyor musunuz?", vbCritical + vbYesNo, "Dikkat !")
If Onay = vbNo Then
MsgBox "İşleminiz iptal edilmiştir.", vbInformation
Exit Sub
End If
Range(Adres).Borders.LineStyle = xlNone
For X1 = İlk_Satır To Son_Satır
For X2 = Cells(1, İlk_Sütun).Column To Son_Sütun
If Cells(X1, X2) <> "" Then
İlk = X1
GoTo Devam1
End If
Next
If İlk = 0 Then GoTo Yeniden
Devam1:
For X3 = X1 + 1 To Son_Satır
If Kontrol = True Then GoTo Devam3
For X4 = Cells(1, İlk_Sütun).Column To Son_Sütun
If Cells(X3, X4) <> "" Then
Son = X3
Kontrol = False
GoTo Devam2
End If
Kontrol = True
Next
Devam2:
Next
Devam3:
If Son = 0 Then
Son = İlk
End If
With Range(Cells(İlk, İlk_Sütun), Cells(Son, Son_Sütun).Address)
.Borders(xlEdgeLeft).LineStyle = Val(Dış_Çizgi_Stili)
.Borders(xlEdgeLeft).Weight = Val(Dış_Çizgi_Kalınlığı)
.Borders(xlEdgeRight).LineStyle = Val(Dış_Çizgi_Stili)
.Borders(xlEdgeRight).Weight = Val(Dış_Çizgi_Kalınlığı)
.Borders(xlEdgeBottom).LineStyle = Val(Dış_Çizgi_Stili)
.Borders(xlEdgeBottom).Weight = Val(Dış_Çizgi_Kalınlığı)
.Borders(xlEdgeTop).LineStyle = Val(Dış_Çizgi_Stili)
.Borders(xlEdgeTop).Weight = Val(Dış_Çizgi_Kalınlığı)
If (Son - İlk) >= 1 Then
.Borders(xlInsideHorizontal).LineStyle = Val(İç_Çizgi_Stili)
.Borders(xlInsideHorizontal).Weight = Val(İç_Çizgi_Kalınlığı)
End If
If (Son_Sütun - 2) >= 1 Then
.Borders(xlInsideVertical).LineStyle = Val(İç_Çizgi_Stili)
.Borders(xlInsideVertical).Weight = Val(İç_Çizgi_Kalınlığı)
End If
End With
X1 = Son
İlk = 0
Son = 0
Kontrol = False
Yeniden:
Next
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation, "[URL="http://www.excel.web.tr"]www.excel.web.tr[/URL]"
End Sub
Selamlar,
Bende bir örnek dosya hazırladım. Alternatif olarak incelermisiniz.
Merhaba Ergün bey,
haklısınız. Ben format kısmını 2010 versiyonda kaydettim. Sanırım 2007'den önce desteklenmiyor. Aşağıdaki satırlar format prosedüründen silinirse sorun kalmaz sanırım. İyi çalışmalar.
Kod:.TintAndShade = 0
Sub bicimle()
Dim sh As Worksheet
Dim CizgiKalinligi As Integer
Dim Rng As String
Set sh = Sheets("Sayfa1")
[COLOR="Red"]CizgiKalinligi = 3[/COLOR]
[COLOR="Red"]sn = sh.Range("B5:F65536").Find(What:="*", After:=Range("B5"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sh.Range("B6:F65536").Borders.LineStyle = xlNone[/COLOR]
For i = 6 To sn
t = 0
For j = 1 To 5
If IsEmpty(sh.Cells(i, 1 + j)) = False Then t = t + 1 'dolu hücreler için
Next j
If t >= 1 Then w = w + 1 'her dolu satırda
If t = 0 And w > 0 Then 'boş satıra geldiğinde
[COLOR="red"]Rng = sh.Range("b" & i - (w) & ":f" & i - 1).Address
Cizdir1 Rng, CizgiKalinligi[/COLOR]
w = 0
End If
If i = sn Then 'son satıra geldiğinde
[COLOR="red"] Rng = sh.Range("b" & i - (w - 1) & ":f" & i).Address
Cizdir1 Rng, CizgiKalinligi[/COLOR]
w = 0
End If
Next i
Set sh = Nothing
End Sub
[COLOR="red"]Sub Cizdir1(Adres As String, CizgiKalinligi)
Range(Adres).Borders.Weight = 1
With Range(Adres).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = CizgiKalinligi
End With
With Range(Adres).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = CizgiKalinligi
End With
With Range(Adres).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = CizgiKalinligi
End With
With Range(Adres).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = CizgiKalinligi
End With
End Sub
Sub Cizdir2(Adres As String, CizgiKalinligi)
Range(Adres).Borders.Weight = 1
End Sub[/COLOR]
Selamlar,
Ergün bey iş çıkışında dosyayı ve kodları biraz aceleyle foruma eklemiştim. Tüm kontrolleri yapamamıştım. Şimdi sanıyorum tüm kontrolleri sağladım.
2003 ve üzeri versiyonlarda sorun çıkarmadan çalışması gerekiyor.
Üstteki mesajımdaki kodu ve dosyayı güncelledim. İncelermisiniz.
Rng = Range(Cells(BasSat, "B"), Cells(i - 1, SonKol)).Address
Selam Necdet Hocam,
sizin kodladığınız Sub Cizdir'i Public Sub Cizdir olarak yapacağım. bu yüzden birkaç şey sormak istiyorum.
örneğin yukarıdaki kod'un sonucu $B$6:$F$30 olarak okunuyor bunu nasıl Sayfa1!$B$6:$F$30 okuyabiliriz? Kısa bir yolu var mıdır?
İyi çalışmalar.
Rng = "Sayfa1!" & Range(Cells(BasSat, "B"), Cells(i - 1, SonKol)).Address
Selamlar,
Kodlarda küçük hatalar tesbit ettim. Üstteki mesajımdaki dosyayı ve kodları yeniden güncelledim. İncelermisiniz.