Başka sayfadaki boşları saydırma macrosu

[mersilen]

Merhabalar

Başka sayhadaki boşları saydırmayı macro ile nasıl yapabilirim.
Bu kodlar kata veriyor

Sub dene5()
w = Worksheets("rrrr").Cells(Rows.Count, "A").End(xlUp).Row
Range("e19") = w
Range("e20") = WorksheetFunction.CountIf(Worksheets("rrrr").Cells(1, 1), Worksheets("rrrr").Cells(w, 1), "")
End Sub
Sub dene6()
w = Worksheets("rrrr").Cells(Rows.Count, "A").End(xlUp).Row
Range("e19") = w
Range("e20") = WorksheetFunction.CountIf(Sheets("rrrr").Cells(1, 1), Sheets("rrrr").Cells(w, 1), "")
End Sub
Sub dene7()
w = Worksheets("rrrr").Cells(Rows.Count, "A").End(xlUp).Row
Range("e19") = w
Range("e20") = WorksheetFunction.CountIf(Sheets("rrrr").Cells(1, 1), Sheets("rrrr").Cells(w, 1), Cells(2, 1))
End Sub

 

[zafer]

Merhaba

Hangi sayfadaki sütundaki boş hücreleri saydırmak istiyorsunuz ve bulunan adeti hangi hücreye yazdırmak istiyorsunuz.

 

[zafer]

Merhaba

rrrr sayfasındaki B sütundaki boş satırları sayar mesaj kutusuna adetini yazar

Sub say1()
Set s1 = Sheets("rrrr")
For a = 2 To s1.Cells(65536, 2).End(3).Row
If s1.Cells(a, "b") = 0 Then c = c + 1
Next
MsgBox ("boş hücre adeti= " & c)
End Sub

 

[uzmanamele]

Merhaba

Alternatif olsun

Sub bosluksay()
    MsgBox Range("B2:B65536").SpecialCells(xlCellTypeBlanks).Count & " adet boşluk var"
End Sub

 

[mersilen]

Zafer bey
A sütunundaki boşları saydırmada kullanacağım (bunuda sub dene3-4 içinde kullanacağım)
sizin kodlar çalışıyor
benim kodlar neden çalışmamış olabilir.


Amacım sheets("rrrr") deki a sütunundaki verileri sırayla sayfa1 e aktarmak

Uzmanamele hocam sizin kodlarıda çalıştırdım
ama Sub dene4 ün içine adapte edemedim

Merhaba

Alternatif olsun

Sub bosluksay()
    MsgBox Range("B2:B65536").SpecialCells(xlCellTypeBlanks).Count & " adet boşluk var"
End Sub

 

[zafer]

Merhaba

Kodlarınız düzenledim.
Siz rrrr sayfasında satıra girilen bilgileri diğer sayfaya sütunlara aktarmak istiyorsunuz.
rrrr sayfasında satıra boşluk geldiğinde boşluktan sonraki verileri diğer sayfaya bir alt satıra yine sütunlara denk gelecek şekilde aktarmak istiyorsunuz.

Sub dene4()
Set s1 = Sheets("rrrr")
Set s2 = Sheets("Sayfa1")
Dim i, x, z, y As Integer
Dim bul As Range
Application.Calculation = xlManual
Application.ScreenUpdating = False
s2.Range("a2", "az10") = Clear: s2.Range("e19:e35") = Clear
i = 2
For x = 1 To s1.Cells(Rows.Count, "A").End(xlUp).Row
    If s1.Cells(x, 1) = "" Then i = i + 1
   
   aaa = s1.Cells(x, "A")
   
    Set bul = s2.Range("1:1").Find(s1.Cells(x, "A").Value, LookIn:=xlValues, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
    y = bul.Column
    
    s2.Cells(i, y) = s1.Cells(x, "B").Value
    
Next x
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub

ekli dosyayı inceleyiniz.

 

[mersilen]

Zafer hocam teşekkürler

Kodlar tam istediğim gibi çalışıyor.