[Insiders]

#vba #excel

Hej Mirki, możecie pomóc mi udoskonalić moje nagrane makro?

Co robi aktualnie?
Zaznacza fragmenty w arkuszu, wyszukuje pustych komórek i uzupełnia je zerami..

Co chciałbym żeby robiło?

Jeżeli w kolumnie B jest jakieś nazwisko to wyszukuje w odpowiednim do tego wierszu w kolumnach od D do H pustych komórek i uzupełnia je zerami. Jeżeli w kolumnie B nie ma już żadnego nazwiska to kończy w tym przedziale i przeskakuje kilka komórek niżej w kolumnie B do następnego zakresu (max ok 180 komórek). I dodatkowo jeżeli w pierwszym zakresie wszytsko jest uzupełnione to też przeskakuje dalej. Bo teraz jak raz uzupełni zerami to poźniej wywala błąd że nie ma co uzupełnić :/

Moje nagranie :)

Sub Makro6()
'
' Makro6 Makro
'

Application.ScreenUpdating = False
 Range("D2:H17").Select
 Selection.SpecialCells(xlCellTypeBlanks).Select
 Selection.FormulaR1C1 = "0"
 Range("D27:H45").Select
 Selection.SpecialCells(xlCellTypeBlanks).Select
 Selection.FormulaR1C1 = "0"
 Range("D54:H67").Select
 Selection.SpecialCells(xlCellTypeBlanks).Select
 Selection.FormulaR1C1 = "0"
 Range("D77:H92").Select
 Selection.SpecialCells(xlCellTypeBlanks).Select
 Selection.FormulaR1C1 = "0"
 Range("D102:H117").Select
 Selection.SpecialCells(xlCellTypeBlanks).Select
 Selection.FormulaR1C1 = "0"
 Range("D127:H142").Select
 Selection.SpecialCells(xlCellTypeBlanks).Select
 Selection.FormulaR1C1 = "0"
 Range("D152:H168").Select
 Selection.SpecialCells(xlCellTypeBlanks).Select
 Selection.FormulaR1C1 = "0"
 Range("D177:H191").Select
 Selection.SpecialCells(xlCellTypeBlanks).Select
 Selection.FormulaR1C1 = "0"

 Range("B2").Select
 Application.ScreenUpdating = True

End Sub

[brak_nicku]

@Insiders:
Być może chodzi o coś takiego:

Option Explicit

Sub Test()

Dim LastRow As Long
Dim Rng As Range

With ActiveSheet
 LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
 Set Rng = .Range("B2:B" & LastRow).SpecialCells(xlCellTypeConstants)
End With

Set Rng = Union(Rng.Offset(, 2), Rng.Offset(, 3), Rng.Offset(, 4), Rng.Offset(, 5), Rng.Offset(, 6))
On Error Resume Next
Rng.SpecialCells(xlCellTypeBlanks).Value2 = 0
End Sub

[Insiders]

@brak_nicku: pomyliłem się z kolumną bo chodziło o C i sie przestraszylem bo zle zadziałało ale już sobie zmieniłem :P

I działa :) bardzo dziękuję! Naprawdę :)