Нужно чтобы ячейки объединялись при следующем условии: макрос для всего столбца (столбцов) объединяет все ячейки по принципу: находит первую непустую ячейку, идет ниже , находит последнюю пустую ячейку выделяет диапазон между ними и объединяет их (текст из нескольких ячеек должен тоже объединиться), идет вниз и делает то же самое до конца таблицы.
В общем, нужно чтобы из приложенного файл-примера получалась нормальная человеческая таблица
Добрый день!
Нужно чтобы ячейки объединялись при следующем условии: макрос для всего столбца (столбцов) объединяет все ячейки по принципу: находит первую непустую ячейку, идет ниже , находит последнюю пустую ячейку выделяет диапазон между ними и объединяет их (текст из нескольких ячеек должен тоже объединиться), идет вниз и делает то же самое до конца таблицы.
В общем, нужно чтобы из приложенного файл-примера получалась нормальная человеческая таблицаdyhes
Public Sub парапап_тудап() Dim str As String Dim rng_str As Range lrow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count lcoll = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count str = "" Application.ScreenUpdating = False For cl = 1 To lcoll For rw = 1 To lrow If Trim(Cells(rw, cl)) = "" Then Cells(rw, cl) = "" If str <> "" Then rng_str.Value = str Set rng_str = Nothing str = "" GoTo Next_rw End If Else If str = "" Then str = Cells(rw, cl).Value Set rng_str = Cells(rw, cl) Else str = str & Cells(rw, cl).Value Cells(rw, cl).Value = "" End If End If Next_rw: Next rw Next cl
ActiveSheet.UsedRange.WrapText = True For rw = lrow To 1 Step -1 If Trim(Cells(rw, 1)) = "" Then Rows(rw).Delete Else Rows(rw).AutoFit End If Next rw Application.ScreenUpdating = True
Public Sub парапап_тудап() Dim str As String Dim rng_str As Range lrow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count lcoll = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count str = "" Application.ScreenUpdating = False For cl = 1 To lcoll For rw = 1 To lrow If Trim(Cells(rw, cl)) = "" Then Cells(rw, cl) = "" If str <> "" Then rng_str.Value = str Set rng_str = Nothing str = "" GoTo Next_rw End If Else If str = "" Then str = Cells(rw, cl).Value Set rng_str = Cells(rw, cl) Else str = str & Cells(rw, cl).Value Cells(rw, cl).Value = "" End If End If Next_rw: Next rw Next cl
ActiveSheet.UsedRange.WrapText = True For rw = lrow To 1 Step -1 If Trim(Cells(rw, 1)) = "" Then Rows(rw).Delete Else Rows(rw).AutoFit End If Next rw Application.ScreenUpdating = True