Доброго времени суток, Планетяне! Вроде как удалось найти оптимальное решение этого популярного вопроса
Итак - в чём были проблемы: 1. Метод заполнения блоками через формулу, заменяемую на значения, не сработает в текстовых ячейках, т.к. в текстовых ячейках формулы не живут))) 2. Метод выделения пустых ячеек xlCellTypeBlanks некорректно себя ведёт при выделении 1 пустой/непустой ячейки
Ссответственно, добавил проверки с перестраховкой и мэсэджами (подскажут, что не так). Так как использовал Offset, то и в манипуляциях с форматами ячеек отпала необходимость — заполняет и текст и дату, не трогая существующие форматы.
А вот и вся коллекция
Код
'Операции с видимыми пустыми ячейками
'Тема на форуме: http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=83098&TITLE_SEO=83098-zapolnit-pustye-yacheyki-znacheniyami-iz-verkhnikh
'===============================================================================================================================================================
Option Explicit
Sub SelectVisibleBlanks()
If Selection.Cells.Count = 1 And Not IsEmpty(Selection) Then
MsgBox "Выделена 1 непустая!", vbExclamation, "Ошибка выделения"
Exit Sub
End If
If Selection.Cells.Count = 1 And IsEmpty(Selection) Then
MsgBox "Выделена 1 пустая!", vbExclamation, "Ошибка выделения"
Exit Sub
End If
On Error GoTo er:
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
GoTo ender:
er:
MsgBox "Отсутствуют пустые ячейки!" & Chr(10) & "Ячейки с формулами, возвращающими пустоту, не считаются пустыми.", vbExclamation, "Ошибка выделения"
ender:
End Sub
'===============================================================================================================================================================
Sub FillVisibleBlanks()
Dim rngBlanks As Range, cl As Range
If Selection.Cells.Count = 1 And Not IsEmpty(Selection) Then
MsgBox "Выделена 1 непустая!", vbExclamation, "Ошибка выделения"
Exit Sub
End If
If Selection.Cells.Count = 1 And IsEmpty(Selection) Then
Selection = Selection.Offset(-1, 0)
Exit Sub
End If
On Error GoTo er:
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
On Error GoTo 0
Set rngBlanks = Selection
If rngBlanks(1).Row = 1 Then
MsgBox "Пустая в 1 строке!", vbExclamation, "Ошибка выделения"
Exit Sub
End If
For Each cl In rngBlanks.Cells
cl = cl.Offset(-1, 0)
Next cl
rngBlanks.Select
GoTo fin:
er:
MsgBox "Отсутствуют пустые ячейки!" & Chr(10) & "Ячейки с формулами, возвращающими пустоту, не считаются пустыми.", vbExclamation, "Ошибка выделения"
Exit Sub
fin:
End Sub
'===============================================================================================================================================================
Sub FillEmpty_kuklp()
Dim a As Range, c As Range
On Error GoTo ErrorHandler
Application.ScreenUpdating = 0
For Each c In ActiveWorkbook.ActiveSheet.UsedRange.Columns
For Each a In Intersect(ActiveWorkbook.ActiveSheet.UsedRange, c).SpecialCells(4).Areas
a.Value = a(1)(0)
Next a
Next c
Exit Sub
Application.ScreenUpdating = 1
ErrorHandler:
MsgBox Error, vbExclamation + vbOKOnly
Application.ScreenUpdating = 1
End Sub
'===============================================================================================================================================================
Sub FillEmpty_Kuzmich()
Dim iLastRow As Long
iLastRow = Cells(Rows.Count, 4).End(xlUp).Row
On Error Resume Next
With Selection
With .SpecialCells(xlCellTypeBlanks)
.NumberFormat = "General"
.FormulaR1C1 = "=R[-1]C"
End With
.Value = .Value
End With
On Error GoTo 0
End Sub
Спасибо всем местным мастерам за помощь и подсказки!
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
kuklp, по макросу попыток нет - сейчас попробую что-то изобразить…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
kuklp, а для Selection просто заменить UsedRange, [a:a]?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Бог с ней, с 1 ячейкой - буду просто вставлять значениями в таком случае… А вот с текстовым форматом - это реально проблема. Исходный макрос в принципе всё круто делает, только из-за того, что он сначала формулы прописывает - не работает с текстовыми форматами
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: буду просто вставлять значениями
Бог в помощь.
Код
Public Sub www()
On Error GoTo ErrorHandler
Dim a As Range, c As Range
For Each c In UsedRange.Columns
For Each a In Intersect(UsedRange, c).SpecialCells(4).Areas
a.Value = a(1)(0)
Next: Next
Exit Sub
ErrorHandler:
MsgBox Error, vbExclamation + vbOKOnly
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
...
For Each c In ActiveWorkbook.ActiveSheet.UsedRange.Columns
For Each a In Intersect(ActiveWorkbook.ActiveSheet.UsedRange, c).SpecialCells(4).Areas
...
kuklp, большое вам спасибо! Всё отлично работает Я-то думал, что цикла с Offset хватит…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
А вот с текстовым форматом - это реально проблема.
Код
'заполнение пустых ячеек данными из вышестоящей ячейки
With .Range("A1:E" & iLastRow)
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Kuzmich, дак да)))) но он не может формулой посчитать, т.к. формат текстовый и менять его нельзя из-за номеров типа "0002569". Я проверил ваш макрос - результат точно такой же, как и в исходном
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Dim iLastRow As Long
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
With Range("A2:A" & iLastRow).SpecialCells(xlCellTypeBlanks)
.NumberFormat = "General"
.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
Kuzmich, сделал так (для Selection) - заполнило значениями из верхней левой или ошибками Я очень мало понимаю в VBA, но думаю, что преобразование форматов в общий и обратно не поможет, т.к. при преобразовании в общий у артикулов с нулями в начале типа "00005987" оторвёт ведущие нули
Код
Sub www()
On Error Resume Next
With Selection.SpecialCells(xlCellTypeBlanks)
.NumberFormat = "General"
.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Dim iLastRow As Long
iLastRow = Cells(Rows.Count, 4).End(xlUp).Row
On Error Resume Next
With Range("A2:D" & iLastRow)
With .SpecialCells(xlCellTypeBlanks)
.NumberFormat = "General"
.FormulaR1C1 = "=R[-1]C"
End With
.Value = .Value
End With
Kuzmich, Работает из личной надстройки, но странно)))))) Если выделить диапазон ТОЛЬКО с текстовыми форматами, то всё гуд. А если в диапазоне присутствует общий, то во вставленном формат общий и обрезаны (как следствие) нули kuklp, попробовал из личной надстройки запустить в другом документе - ошибку выдаёт
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄