• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Oluşan rapora göre pano çizgilerinin çizilmesi

Merhabalar

Kodunuzu sonuna aşağıdaki gibi Kırmızı satırları ilave etmelisiniz.

Kod: 
Sub AktarSay()
.....
Diğer kodlarınız
.....
[COLOR=red]With s2.Cells
   .Borders(xlDiagonalDown).LineStyle = xlNone
   .Borders(xlDiagonalUp).LineStyle = xlNone
   .Borders(xlEdgeLeft).LineStyle = xlNone
   .Borders(xlEdgeTop).LineStyle = xlNone
   .Borders(xlEdgeBottom).LineStyle = xlNone
   .Borders(xlEdgeRight).LineStyle = xlNone
   .Borders(xlInsideVertical).LineStyle = xlNone
   .Borders(xlInsideHorizontal).LineStyle = xlNone
End With
With s2.Range("A1:H" & s2.Cells(65536, 1).End(xlUp).Row)
    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Borders(xlEdgeTop).LineStyle = xlContinuous
    .Borders(xlEdgeBottom).LineStyle = xlContinuous
    .Borders(xlEdgeRight).LineStyle = xlContinuous
    .Borders(xlInsideVertical).LineStyle = xlContinuous
    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With[/COLOR]
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub
 
aşağıdaki kodları ekle



Columns("A:H").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Range("A1:H" & Range("A65536").End(xlUp).Row).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
 
fpc ustam Mevcud kod dizisine verdiğiniz kod ları ekledim ancak "With s2.Cells" satırında hata veriyor



Sub AKTAR()
Dim SR As Worksheet
Dim SAY, SUT As Long
Set SR = Sheets("RAPOR")
SR.Range("B4:J10000").ClearContents
For SAY = 2 To Sheets.Count
For SUT = 2 To Sheets(SAY).[a65536].End(3).Row
If SR.[L6] = Sheets(SAY).Range("A" & SUT).Value Then
S = S + 1
SR.Range("B" & S + 3 & ":J" & S + 3) = Sheets(SAY).Range("A" & SUT & ":I" & SUT).Value
End If
Next
Next
With s2.Cells
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
With s2.Range("A1:H" & s2.Cells(65536, 1).End(xlUp).Row)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
'*******************************************
MsgBox "LİSTE TAMAMLANDI"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub
 
zfr19 ustam sizin verdiğiniz kod ("A:H") aralığının tamamını çiziyor benim istediğim eğer mümkünse sadece aktarılan bilginin çizilmesi ilginiz için tşkl
 
Ama Sn.yolcu50, nerde kitabınızdaki kodlar, nerde son yazdığınız kodlar ..

Ben size Aktarsay makronuzu değiştirmenizi söyledim siz AKTAR diye başka ir makrodan bahsetmektesiniz. Neyse, son kodlarınızda s2 yazan yerleri SR olarak düzeltiniz. Ayrıca kodunuzun sonundaki s1, s2 nothing yazan satırları da temizleyiniz.
 
fpc ustam özür dilerim iki çalışmamdada aynı sorun vardı. hangisini kopyaladığımı fark edemedim. dediğiniz düzeltmeleri yaptım ancak yine a:h aralığının tamamını çiziyor mesela rapor (a:h16) aralığında bitiyorsa bu aralıkta son bulmuyor (a:h65536) aralığını çiziyor. her nasılsa rapor bitiminde sonlandıramıyorum.


Sub AKTAR()
Dim SR As Worksheet
Dim SAY, SUT As Long
Set SR = Sheets("RAPOR")
SR.Range("B4:J10000").ClearContents
For SAY = 2 To Sheets.Count
For SUT = 2 To Sheets(SAY).[a65536].End(3).Row
If SR.[L6] = Sheets(SAY).Range("A" & SUT).Value Then
S = S + 1
SR.Range("B" & S + 3 & ":J" & S + 3) = Sheets(SAY).Range("A" & SUT & ":I" & SUT).Value
End If
Next
Next
With SR.Cells
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
With SR.Range("A1:H" & SR.Cells(65536, 1).End(xlUp).Row)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
'*******************************************
MsgBox "LİSTE TAMAMLANDI"
[a1].Select
End Sub
 
With SR.Range("A1:H" & SR.Cells(65536, 1).End(xlUp).Row)
Yukarıdaki satırı; şöyle değiştirip deneyin.
With SR.Range("A1:H" & SR.Cells(65536, 2).End(xlUp).Row)
 
fpc ustam 21 nolu mesajda verdiği kod lar normal olarak ilgili dosyamda çalıştı.fakat düzeltme yaptığım diğer çalışmamda çalışmadı. sebebi ne olabilir
 
Çok sayıda ileti olduğundan hepsini inceleyemedim; ama eğer verilerin olduğu kadar bir alana çizgi eklemek istiyorsanız ve bu yazıcıdan çıktı alırken gerekli ise, excelin klavuz çizgiler işlevini de kullanabilirsiniz. Bunun için sayfa önzileme ekranında ayarla düğmesine basınız, Çalışma Sayfası sekmesine gelip, aşağıdaki seçeneklerden Kılavuz çizgileri seçerseniz, veri bulunan alanlara excel kendiliğinden çizgi atacaktır.
 
Meslekİ Sorunumun ÇÖzÜmÜ İÇİn VerdİĞİn İkİncİ Yol İÇİn TŞk Ederİm.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst