Добрый день знатокам. Подскажите, как мне автоматизировать преобразование таблицы, когда к одной строке относятся еще подстроки, чтобы перенести их в одну строчку друг за другом. Это нужно для дальнейшей миграции таблицы в Access. При миграции таблицы в существующем варианте, строки теряются (вносятся как новые строки, не относящиеся к основной строке). Надеюсь я понятно объяснил. Должно получиться примерно так как на втором скрине
Sub stroki()
'aequit 23.02.2020
Dim i As Long, lLC As Long
Application.ScreenUpdating = False
For i = 2 To Worksheets("исходник").Cells(Rows.Count, 4).End(xlUp).Row
If Cells(i, 3) = "" Then
Do While Cells(i, 3) = ""
If Cells(i, 5) = "" Then Exit For
lLC = Worksheets(1).Cells(i - 1, Columns.Count).End(xlToLeft).Column
Range(Cells(1, 4), Cells(1, 8)).Copy Range(Cells(1, lLC + 1), Cells(1, lLC + 5))
Range(Cells(i, 4), Cells(i, 8)).Copy Range(Cells(i - 1, lLC + 1), Cells(i - 1, lLC + 5))
Range(Cells(i - 1, lLC + 1), Cells(i - 1, lLC + 5)).EntireColumn.AutoFit
Rows(i).Delete
Loop
End If
Next i
Application.ScreenUpdating = True
End Sub
Прошу прощения. выявился небольшой баг. У Вас программа отслеживает конец строки и дописывает переносимую строку в конец предыдущей. Если в данных отсутствует информация в последней строке (например нет даты рождения), то строки сдвигаются и табличный вариант ломается. Есть ли вариант переносить строки на столбец 9 и дальше следующие строки на +5 (зафиксировать начала перенесенных строк)
Pol76 написал: (например нет даты рождения), то строки сдвигаются
Проверил. Убрал день рождения из нижней правой ячейки. Табличный вариант не поломался.
Цитата
Pol76 написал: У Вас программа отслеживает конец строки
Привязка идёт к 4 столбцу (должность). Можно исправить на 5 столбец - фамилия, если есть вероятность, что ячейка должность будет пустой. Приложите пример, который воспроизводит ошибку, я пока её не увидел.
Pol76 написал: А попробуйте убрать дату из первой строки
Только это не "баг", а внесение изменений в условия ТЗ после согласования с исполнителем Внес это обстоятельство в код, проверяйте:
Скрытый текст
Код
Sub stroki2()
'aequit 25.02.2020
Dim i As Long, lLC As Long
Application.ScreenUpdating = False
For i = 2 To Worksheets("исходник").Cells(Rows.Count, 4).End(xlUp).Row
If Cells(i, 3) = "" Then
Do While Cells(i, 3) = ""
If Cells(i, 5) = "" Then Exit For
lLC = Worksheets(1).Cells(i - 1, Columns.Count).End(xlToLeft).Column
If Cells(i - 1, 8) = Empty And lLC = 7 Then lLC = 8
Range(Cells(1, 4), Cells(1, 8)).Copy Range(Cells(1, lLC + 1), Cells(1, lLC + 5))
Range(Cells(i, 4), Cells(i, 8)).Copy Range(Cells(i - 1, lLC + 1), Cells(i - 1, lLC + 5))
Range(Cells(i - 1, lLC + 1), Cells(i - 1, lLC + 5)).EntireColumn.AutoFit
Rows(i).Delete
Loop
End If
Next i
Application.ScreenUpdating = True
End Sub