Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Автоматическое подтягивание цифр в пустые (удаленные) ячейки - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Автоматическое подтягивание цифр в пустые (удаленные) ячейки (Формулы/Formulas)
Автоматическое подтягивание цифр в пустые (удаленные) ячейки
noobik Дата: Четверг, 19.07.2018, 16:54 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 20% ±

Excel 2010
Здравствуйте, подскажите как в таблице сделать автоматическое перетягивание ячеек? В примере понятнее)
К сообщению приложен файл: 3890211.xls (27.0 Kb)
 
Ответить
СообщениеЗдравствуйте, подскажите как в таблице сделать автоматическое перетягивание ячеек? В примере понятнее)

Автор - noobik
Дата добавления - 19.07.2018 в 16:54
sboy Дата: Четверг, 19.07.2018, 17:01 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
В примере понятнее

мне, например вообще не понятно :)


Яндекс: 410016850021169
 
Ответить
Сообщение
В примере понятнее

мне, например вообще не понятно :)

Автор - sboy
Дата добавления - 19.07.2018 в 17:01
noobik Дата: Четверг, 19.07.2018, 17:03 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 20% ±

Excel 2010
Ну, удалили цифру 38 и в эту ячейку "подвинулась" соседняя и подтянулась вся таблица. Самая последняя ячейка получилась пустая.
 
Ответить
СообщениеНу, удалили цифру 38 и в эту ячейку "подвинулась" соседняя и подтянулась вся таблица. Самая последняя ячейка получилась пустая.

Автор - noobik
Дата добавления - 19.07.2018 в 17:03
sboy Дата: Четверг, 19.07.2018, 17:53 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
Работает для верхнего блока (А2:К5), удалять по одной
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, Range("A2:K5")) Is Nothing Then Exit Sub
    If Target.Value = "" Then
        Application.EnableEvents = False
            r = Target.Row
                If Target.Column < 11 Then
                   Range(Target, Cells(r, 10)).Value = Range(Cells(r, Target.Column + 1), Cells(r, 11)).Value
                End If
                Cells(r, 11) = Cells(r + 1, 1)
                If r < 5 Then
                    For r = r + 1 To 5
                        Range(Cells(r, 1), Cells(r, 10)).Value = Range(Cells(r, 2), Cells(r, 11)).Value
                        Cells(r, 11) = Cells(r + 1, 1)
                    Next
                End If
        Application.EnableEvents = True
    End If
End Sub
[/vba]
К сообщению приложен файл: 6723736.xls (40.0 Kb)


Яндекс: 410016850021169
 
Ответить
СообщениеРаботает для верхнего блока (А2:К5), удалять по одной
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, Range("A2:K5")) Is Nothing Then Exit Sub
    If Target.Value = "" Then
        Application.EnableEvents = False
            r = Target.Row
                If Target.Column < 11 Then
                   Range(Target, Cells(r, 10)).Value = Range(Cells(r, Target.Column + 1), Cells(r, 11)).Value
                End If
                Cells(r, 11) = Cells(r + 1, 1)
                If r < 5 Then
                    For r = r + 1 To 5
                        Range(Cells(r, 1), Cells(r, 10)).Value = Range(Cells(r, 2), Cells(r, 11)).Value
                        Cells(r, 11) = Cells(r + 1, 1)
                    Next
                End If
        Application.EnableEvents = True
    End If
End Sub
[/vba]

Автор - sboy
Дата добавления - 19.07.2018 в 17:53
_Boroda_ Дата: Четверг, 19.07.2018, 18:07 | Сообщение № 5
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Для любого блока с шапкой. Стирать можно сразу несколько (даже несвязанных) ячеек
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim d As Range
    With Target.CurrentRegion
        rn_ = .Rows.Count
        If rn_ > 1 Then
            If Target(1) = "" Then
                If Intersect(Target, .Rows(1)) Is Nothing Then
                    Set d = .Offset(1).Resize(rn_ - 1)
                    n_ = WorksheetFunction.CountA(d)
                    Application.ScreenUpdating = 0
                    Application.EnableEvents = 0
                    For i = 1 To d.Cells.Count
                        If d(i) <> "" Then
                            j = j + 1
                            If d(j) <> d(i) Then
                    d(j) = d(i)
                    d(i).ClearContents
                            End If
                        End If
                    Next i
                    Application.EnableEvents = 1
                    Application.ScreenUpdating = 1
                End If
            End If
        End If
    End With
End Sub
[/vba]

* Добавлено
Немного переписал и файл перевложил
К сообщению приложен файл: 3890211_2.xls (45.5 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995


Сообщение отредактировал _Boroda_ - Четверг, 19.07.2018, 18:19
 
Ответить
СообщениеДля любого блока с шапкой. Стирать можно сразу несколько (даже несвязанных) ячеек
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim d As Range
    With Target.CurrentRegion
        rn_ = .Rows.Count
        If rn_ > 1 Then
            If Target(1) = "" Then
                If Intersect(Target, .Rows(1)) Is Nothing Then
                    Set d = .Offset(1).Resize(rn_ - 1)
                    n_ = WorksheetFunction.CountA(d)
                    Application.ScreenUpdating = 0
                    Application.EnableEvents = 0
                    For i = 1 To d.Cells.Count
                        If d(i) <> "" Then
                            j = j + 1
                            If d(j) <> d(i) Then
                    d(j) = d(i)
                    d(i).ClearContents
                            End If
                        End If
                    Next i
                    Application.EnableEvents = 1
                    Application.ScreenUpdating = 1
                End If
            End If
        End If
    End With
End Sub
[/vba]

* Добавлено
Немного переписал и файл перевложил

Автор - _Boroda_
Дата добавления - 19.07.2018 в 18:07
noobik Дата: Пятница, 20.07.2018, 22:17 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 30
Репутация: 0 ±
Замечаний: 20% ±

Excel 2010
Парни, спасибо, Выручили, как всегда))))
 
Ответить
СообщениеПарни, спасибо, Выручили, как всегда))))

Автор - noobik
Дата добавления - 20.07.2018 в 22:17
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Автоматическое подтягивание цифр в пустые (удаленные) ячейки (Формулы/Formulas)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!