Вкладочный вид базы Excel

[Heavyhand]

Доброго времени суток, основная задача состоит в корректировке большой базы с данными для более удобного использования пользователям.
вот логический код программы:
Вводим переменную
Заполняем данными из выделенной ячейки если они отличаются от данных в переменной
смещаем строку, переносим(вырезаем)
спускаться в низ
Если данные ячейки одинаковы с содержанием переменной - удалить
спускаться в низ
Иначе содержание ячейки отличаются от содержания переменной
заполнить переменную данными из ячейки
смещаем строку , переносим(вырезаем)
спускаемся в низ

Если клетка пустая
Спускаемся в низ

-----
вот код программы:
Sub old()
'
' old Макрос
'
' Сочетание клавиш: Ctrl+ц
'
Dim a As Integer ' Вводим переменную
a = Selection
With Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 'Вставка(смещение)
ActiveCell.Offset(1, 0).Select
Selection.Cut
ActiveCell.Offset(-1, 0).Select
ActiveSheet.Paste
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False 'шрифт за границы и приравнивание налево

.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

ActiveCell.Offset(1, 0).Select 'Спускаемся сравниваем значение с а
If Selection = a Then
Selection.ClearContents 'Удаляем если равно



If Selection <> a Then
a = Selection 'если не равно забираем значение из новой клетки
Rows("2:2").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(1, 0).Select
Selection.Cut
ActiveCell.Offset(-1, 0).Select
ActiveSheet.Paste
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False

.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection 'шрифт, смещение
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End
If IsEmpty(ActiveCell.Value) = True Then

ActiveCell.Offset(1, 0).Select


End If
End If
End If


End Sub


Существует 2 проблемы:
1) Цикличность. не знаю как заставить её выполнять повторения впредь до тысяч так 5
2) ошибка в коде из-за которой действующая ячейка не смещается а постоянно находится на а2, при этом сдвигая все вверх(должна реагировать на выделенную ячейку(и действовать от неё(выделенную мышкой))

Объясните пожалуйста как использовать "Rows" и как заставить двигаться от выделенной ячейки вниз

[Hugo121]

Я думаю что всё нужно делать иначе.
Но конечно если увижу файл и пойму задачу - может быть передумаю

[Heavyhand]

Сообщение от Hugo121

Я думаю что всё нужно делать иначе.
Но конечно если увижу файл и пойму задачу - может быть передумаю

Вот вся задача

[IgorGO]

полагаю этот

Sub FIxData()
  Dim r As Long
  r = 1: If Cells(r, 1) = "" Then r = Cells(r, 1).End(xlDown).Row
  Do While Cells(r, 1) <> ""
    Cells(r, 2).Resize(1, 2).Value = Cells(r + 1, 2).Resize(1, 2).Value
    Cells(r + 1, 2).Resize(1, 2).ClearContents
    r = Cells(r, 1).End(xlDown).Row
  Loop
End Sub

может реализовать Вашу задумку (даже если данных будет больше 5 тыс. строк)

[Heavyhand]

Сообщение от IgorGO

полагаю этот

Sub FIxData()
  Dim r As Long
  r = 1: If Cells(r, 1) = "" Then r = Cells(r, 1).End(xlDown).Row
  Do While Cells(r, 1) <> ""
    Cells(r, 2).Resize(1, 2).Value = Cells(r + 1, 2).Resize(1, 2).Value
    Cells(r + 1, 2).Resize(1, 2).ClearContents
    r = Cells(r, 1).End(xlDown).Row
  Loop
End Sub

может реализовать Вашу задумку (даже если данных будет больше 5 тыс. строк)

действие вашей программы.
нужно что бы вставлялась строка а данные из клетки перемещались на 1 клетку вверх что бы быть "оглавлением" (повторяющиеся снизу удаляются, другие аспекты так же становятся оглавлениями)

[IgorGO]

однако...
Ваш код я даже не пытался анализировать.
по первой картинке стало понятно, что надо сделать
а вот по второй... четкие очертания задачи совершенно размылись и не просматриваются

[Heavyhand]

(в коде написано для одного столбца)

[Heavyhand]

Public a As String
Public x1 As Integer
Public y1 As Integer
Public i As Integer
Public x2 As String
Public y2 As Integer


Sub old()
'
' old
'
' : Ctrl+й
'

x1 = Selection.Cells.Column
y1 = Selection.Cells.Row
x2 = ActiveCell.SpecialCells(xlLastCell) .Column
y2 = ActiveCell.SpecialCells(xlLastCell) .Row
i = y1


While i < y2 + 1

If IsEmpty(ActiveCell.Value) = True Then
ActiveCell.Offset(1, 0).Select
i = i + 1

Else




If Selection <> a Then
a = Selection
With ActiveCell.Rows("1:1").EntireRow.Se lect
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(i, x1).Select
ActiveCell.Offset(1, 0).Select
Selection.Cut
ActiveCell.Offset(-1, 0).Select
ActiveSheet.Paste
End With


With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False

.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveCell.Offset(1, 0).Select
i = i + 1
y2 = y2 + 1


Else
Selection.ClearContents
ActiveCell.Offset(1, 0).Select
i = i + 1



End If
End If
Wend

i = 0
End Sub