Application.WorksheetFunction.Count sonucu 0 çıkıyor

[mancubus]

Merhaba.

Diğer sütunlarda farklı veri ve formüller olmak üzere AA sütununda (27 no.lu sütun) 95000-120000 arası değişen satırda veri bulunan bir dosyam var. Bu satırların önemli bir kısmı boş ve en altta 3000-10000 arası dolu hücre var.

Yapmak istediğim, AA2 hücresindeki formülü AA3 hücresinden başlayarak sütundaki ilk dolu hücreye kadar kopyalamak. Bunun için aşağıdaki gibi bir macro var. Toplam kayıt sayısı değiştiği için kopyalanacak aralık'ın satır değerini "toplam satır sayısı" - "dolu olan satır sayısı" olarak vermek istedim. Fakat makro çalıştığında A sütunundan elde ettiğim SonSat değerine dolu olan hücreler dahil kopyalamakta.

Önce CountBlank("AA3:AA & SonSat") ile başlamıştım. Hatalı olunca bu tanımlara girdim.

2003 Eng ve 2007 Eng kullanıyoruz.

Varsa görüş ve önerilerinizi rica ederim.

Sub x()

Dim SonSat As Long
Dim Dolu As Long
Dim Bos As Long

With ActiveSheet
SonSat = .Cells(.Rows.Count, "AA").End(xlUp).Row
[COLOR="red"]Dolu = Application.WorksheetFunction.Count("AA:AA")[/COLOR]
Bos = SonSat - Dolu
End With

Range("AA2").Copy
Range(Cells(3, 27), [COLOR="SeaGreen"]Cells(Bos, 27[/COLOR]).Select
Selection.pastespecial Paste:=xlPasteFormulas, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Calculate
Application.Wait Now + TimeValue("00:00:15")

End Sub

Düzeltme:
Sayın Evren Gizlen'in başka bir konuda verdiği bir örnekten hareketle nerede hata yaptığımı anladım. Range ibaresini eklemek gerekiyormuş.
Bilvesile kendisine teşekkür ederim.

With ActiveSheet
SonSat = .Cells(.Rows.Count, "AA").End(xlUp).Row
'veya
'SonSat = .Cells.SpecialCells(xlCellTypeLastCell).Row

Dolu = Application.WorksheetFunction.Count([COLOR="Red"]Range[/COLOR](Cells(3, 27), Cells(SonSat, 27)))
Bos = SonSat - Dolu
End With

 

[Levent Menteşoğlu]

sonsat değişkenini aşağıdaki ile değiştirerek deneyin.

SonSat = .Cells(.Rows.Count, "AA").End(xlDown).Row

 

[mancubus]

İlginize teşekkür ederim. Mecvut tanım ile SanSat bu şekilde elde ediyorum. Doğru değeri veriyor. (Başka yerlerin kopyalanmasında da ihtiyacım var bu değere.) Down ile olanı da bir yerde record macro ile yapmıştım ve değişen bir şey olmamıştı galiba. Tekrar deneyeyim.

Şöyle bir şey denemiştim. O da dolu hücreler dahil sütunun tamamına kopyaladı

Dim r As Range
Set r = Intersect(Range("AA:AA"), Cells.SpecialCells(xlCellTypeBlanks))
Range("AA2").Copy
r1.Select
Selection.pastespecial Paste:=xlPasteFormulas, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

 

[mancubus]

Merhaba.

SonSat = .Cells(.Rows.Count, "AA").End(xlDown).Row

ile denediğimde

Cells.SpecialCells(xlCellTypeBlanks)

ile aynı sonucu verdi. Yani AA3'ten başlayarak sütunun tamamına kopyaladı.

 

[mancubus]

Merhaba.

Sabahtan beri arıyordum. Nihayet benim işimi gören bir tane buldum. Belki ihtiyaç duyan olabilir diye ekliyorum. Bunu görünce forumda da benzer örnekler gördüğümü hatırlıyorum.

Nasıl arayacağını bilmek önemli.

:redface: :kafa:

Sub FillColBlanks()

'by Dave Peterson  2004-01-06
'fill blank cells in column with value above
'http://www.contextures.com/xlDataEntry02.html

Dim wks As Worksheet
Dim rng As Range
Dim LastRow As Long
Dim col As Long

Set wks = ActiveSheet
With wks
   col = activecell.column
   'or
   'col = .range("b1").column

   Set rng = .UsedRange  'try to reset the lastcell
   LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
   Set rng = Nothing
   On Error Resume Next
   Set rng = .Range(.Cells(2, col), .Cells(LastRow, col)) _
                  .Cells.SpecialCells(xlCellTypeBlanks)
   On Error GoTo 0

   If rng Is Nothing Then
       MsgBox "No blanks found"
       Exit Sub
   Else
       rng.FormulaR1C1 = "=R[-1]C"
   End If

   'replace formulas with values
   With .Cells(1, col).EntireColumn
       .Value = .Value
   End With

End With

End Sub

 

[mancubus]

Tekrar teşekkür ederim.


Benim örneğime şu şekilde uyarladık.

kod içinde fonksiyonun neden 0 verdiği konusunda görüşü olan varsa da çok makbule geçer.

Sub Bosluk_Doldur()

'by Dave Peterson  2004-01-06
'fill blank cells in column with value above
'http://www.contextures.com/xlDataEntry02.html

Dim wks As Worksheet
Dim rng As Range
Dim LastRow As Long
'Dim col As Long

Set wks = ActiveSheet
With wks
   'col = ActiveCell.Column
   'or
   'col = .range("b1").column

   Set rng = .UsedRange 
   LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
   Set rng = Nothing
   On Error Resume Next
   Set rng = .Range(.Cells(3, 27), .Cells(LastRow, 27)) _
                  .Cells.SpecialCells(xlCellTypeBlanks)
   On Error GoTo 0

   If rng Is Nothing Then
       MsgBox "Boş hücre bulunamadı"
       Exit Sub
   Else
       rng.FormulaR1C1 = "=IF(RC[-13]>=RC[-1],RC[-13],0)"
        End If

  End With

End Sub