Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Удаление пустых ячеек из столбца, функция с этого сайта дает не тот результат, что ожидается
 
На сайте нашел функцию
Код
Function NoBlanks(DataRange As Range) As Variant()
Dim N As Long
Dim N2 As Long
Dim Rng As Range
Dim MaxCells As Long
Dim Result() As Variant
Dim R As Long
Dim C As Long
MaxCells = Application.WorksheetFunction.Max( _
Application.Caller.Cells.Count, DataRange.Cells.Count)
For Each Rng In DataRange.Cells
    If Rng.Value <> vbNullString Then
         N2 = N2 + 1
    End If
Next Rng
ReDim Result(1 To N2, 1 To 1)
For Each Rng In DataRange.Cells
     If Rng.Value <> vbNullString Then
          N = N + 1
          Result(N, 1) = Rng.Value
     End If
Next Rng
If Application.Caller.Rows.Count = 1 Then
      NoBlanks = Application.Transpose(Result)
Else
      NoBlanks = Result
End If
End Function 

Попробовал применить ее к диапозону который будет рости (т.е. значения будут добавляться и нужно оперативно их обрабатывать Соответственно диаппозон обработки задал в 9999 строк и диапозон входных данных 9999 строк. При единственном значении во входном диапозоне все значения результата равнялись единственному числу из входного диапозона. Кажется это не совсем тот результат который описывался для этой функции. Что в ней не так?
 
alex_j,  мой Вам совет, опишите свою задачу(с примером, как положено), а не Ваше видение ее решения. Может получите гораздо более эффективный результат. И еще - прочитайте наконец Правила форума!
Цитата
2.2. Опишите максимально подробно вашу задачу и желаемый результат. Желательно уточнить вашу версию Excel.
2.3. Приложите файл(ы) с примером (общим весом не более 100 Кб) в реальной структуре и форматах данных того, что есть сейчас и того, что хотелось бы на выходе.
Где у Вас все это?! Мы должны догадываться, что делает ЮДФ и что именно она должна делать?
Изменено: kuklp - 28 Июл 2017 13:37:58
Я сам - дурнее всякого примера! ...
 
Пример того с чем я работаю
 
В модуль листа:
Код
Public Sub www()
    On Error Resume Next
    With Intersect(UsedRange, [a:a])
        .Value = .Value: .SpecialCells(4).Delete xlUp
    End With
End Sub
Я сам - дурнее всякого примера! ...
 
Супер!!! Спасибо огромное!
 
Только у меня формула пропала проверочная. Интересно могу ли я условие проверки в этот макрос записать? И как я понимаю он работает при открытии книги или принудительном пуске?
 
что то типа такого:
Код
Const iPath = "áàçà çàêàçîâ.xlsx"
Const iPath2 = "ïðèìåð.xlsm"
Dim job As Workbook
Dim f As Integer
Set job = Workbooks.Open(iPath)
Set job2 = Workbooks.Open(iPath2)
Dim iRow, i, p As Integer
With job.Sheets("Àâãóñò")
Range("a:b,j").Copy
aktivebook.Close
With job.Sheets("ëèñò 2")
ActiveSheet.past
iRow = .Range("A" & .Rows.Count).End(xlUp).Row
For f = 1 To iRow
If Range(f, j).Value = "îôñåò" Then
.Cells(f, d) = Range(f, a).Value
.Cells(f, e) = Range(f, b).Value
Else
.Cells(f, d) = ""
.Cells(f, ó) = ""
Next
On Error Resume Next
    With Intersect(UsedRange, [d:e])
        .Value = .Value: .SpecialCells(4).Delete xlUp
    End With
aktivebook.Close
End Sub


только у меня выскочила ошибка на первом next с заявкой что он ни к какому циклу не привязан :(
 
Цитата
alex_j написал:
только у меня выскочила ошибка на первом next
ну потому что там должно быть End If
и еще - у вас три With, и только один End With. Тут он тоже будет ругаться

PS когда копируете код, включайте русскую раскладку - а то "кракозябры" получаются
Изменено: webley - 28 Июл 2017 18:40:19
 
спасибо поправил теперь
Код
Public Sub www()

Const iPath = "база.xlsx"
Const iPath2 = "пример.xlsm"
Dim job As Workbook
Dim f As Integer
Set job = Workbooks.Open(iPath)
Set job2 = Workbooks.Open(iPath2)
Dim iRow, i, p As Integer
With job.Sheets("Август")
Range("a:b,j").Select
End With
aktivebook.Close
With job.Sheets("Лист 3")
ActiveSheet.past
iRow = .Range("A" & .Rows.Count).End(xlUp).Row
For f = 1 To iRow
   If Range(f, j).Value = "îôñåò" Then
      .Cells(f, d) = Range(f, a).Value
      .Cells(f, e) = Range(f, b).Value
   Else
      .Cells(f, d) = ""
      .Cells(f, e) = ""
   End If
Next
End With
 On Error Resume Next
     With Intersect(UsedRange, [d:e])
          .Value = .Value: .SpecialCells(4).Delete xlUp
     End With
 End Sub

теперь ошибок не выдает, радостно моргает экраном .... без всякого результата на выходе.
Изменено: alex_j - 28 Июл 2017 18:42:25
 
К сожалению и у меня не работает функция Noblanks. Вместо скрытия пустых строк выдает повторы в количестве пустых. (в примере условное форматирование столбца на повторы).
В чем может быть ошибка? Спасибо заранее.
Страницы: 1
Читают тему (гостей: 1)
Наверх