dolu hücreleri seç

[prodigy]

değerli arkadaşlar
sayfa1 de a5 den başlayarak çeşitli tablolarım var. bu tablolar arasında boş satırlar var ve tablolar sabit değil. döngü ile her bir tabloya ayrı ayrı çerveve oluşturmak istiyorum.

 

[emrexcel123]

son hücre

arkadaşım son hücre için ne gibi bir tanımlama yapılacak mesela ;
a1:a5 derken a5 hücresi son dolu hücre varsayalım bu şekilde yani...

 

[emrexcel123]

örnek

arkadaşım şu kod sadece a5:g12 aralığı içindir >>
Sub cizim_yap()
With Range("A5:G12").Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("A5:G12").Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("A5:G12").Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("A5:G12").Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("A5:G12").Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("A5:G12").Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub

 

[prodigy]

burada bir buton yardımıyla her bir tabloyu ayrı ayrı çizecek. yani a sutununda dolu hücreye göre

 

[prodigy]

Sub BoslariSil()
Dim son, i As Integer
Dim alan, satir As Range
son = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = son To 1 Step -1
If WorksheetFunction.CountA(Rows(i)) <> 0 Then
Set satir = Rows(i)
If IsEmpty(alan) Then
Set alan = satir
Else: Set alan = Union(satir, alan)
End If
End If
Next
alan.Select
With Selection

.Borders.LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlHairline
.Borders(xlEdgeLeft).LineStyle = xlHairline
.Borders(xlEdgeRight).LineStyle = xlHairline
.Borders(xlEdgeTop).LineStyle = xlHairline
.Borders(xlInsideVertical).LineStyle = xlDot
End With

bu kod tüm dolu satırları çiziyor . burada sadece A sutunundan G sutuna kadar olan hücreleri çizdirmek istiyorum.

 

[prodigy]

cevap olmadığına göre tam anlatmadım galiba.............

 

[AS3434]

Daha hızlı yöntemler olabilir ama yapabildiğim bu kadar.

Sub cızgıcız()
Application.ScreenUpdating = False
 Columns("A:G").Select
 Selection.Borders.LineStyle = xlNone
    For i = 1 To 7
    For X = [A65536].End(3).Row To 5 Step -1
    If Cells(X, 1) > 0 Then
    Cells(X, i).Borders.LineStyle = xlContinuous
    End If
    Next: Next
    [a5].Select
    Application.ScreenUpdating = True
End Sub

Dosyayı inceleyin.

 

[Okyanus101]

Bu benimde &#231;ok i&#351;ime yarad&#305; .
Te&#351;ekk&#252;r ederim.

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak a&#351;a&#287;&#305;dkai koduda kullanabilirsiniz.

Sub ÇİZGİ_ÇİZ()
    [A:G].Borders.LineStyle = xlNone
    For Each ALAN In [A:A].SpecialCells(xlCellTypeConstants, 23).Areas
    ALAN.Resize(ALAN.Count, 7).Borders.LineStyle = xlContinuous
    Next
End Sub