Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Проверить объединение ячеек
 
#1
15.05.2024 15:13:54
Добрый день!

Сложилась такая ситуация, получил Эксель файл, который нужно загрузить в 1с. Проблема в объединенных ячейках
Что нужно сделать:
Проверять Объединена ли ячейка в столбце A, и если объединена то ячейки в столбце B нужно объединить на такой же диапазон как в ячейке A
Сохранять значение нужно только верхней ячейки, но есть ячейки в столбце B, у которых значение не в 1 ячейке хранится, т.е 1 ячейка пустая, а во второй есть значение

Сам перерыл пол интернета, смог найти что то, но под свои нужды переделать не получилось.
В макросах полный 0
Буду очень благодарен за помощь.

Предоставляю поле для тестирования)
 
 
 
#2
15.05.2024 15:33:33
Код
Sub UnMergeSelection()
    Dim arr As Variant
    arr = Intersect(Selection, ActiveSheet.UsedRange).Columns(1).Resize(, 2).Value
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To 2)
    
    Dim xa As Long
    Dim ya As Long
    Dim yb As Long
    For ya = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(ya, 1)) Then
            yb = yb + 1
            For xa = 1 To UBound(arr, 2)
                brr(yb, xa) = arr(ya, xa)
            Next
        End If
    Next
    
    PrintArray brr
End Sub

Private Sub PrintArray(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Value = arr
            End With
        End With
        .Saved = True
    End With
End Sub
 
 
 
#3
15.05.2024 15:37:06
МатросНаЗебре, не совсем понимаю как это должно работать, если не выделять ячейки выдает ошибку, а при выделении ячеек в столбце B создает новый лист, в который просто столбец B переносится

UPD Понял как это работает, спасибо
Изменено: RedIsDead - 15.05.2024 15:38:03
 
 
 
#4
15.05.2024 15:42:12
Предполагалось, что выделите все ячейки, которые надо обработать. Или, учитывая название "Проверить объединение ячеек", выделите хотя бы объединённые.

Анекдот. В офисе программистов кто-то навалил кучу на крышку унитаза. Подозрение сразу пало на тестировщика.
 
 
 
#5
15.05.2024 15:44:43
МатросНаЗебре, А есть ли возможность сделать, чтобы он не новый лист создавал, а объединял именно ячейки в моем листе, у меня помимо этих двух столбцов есть и другие, и будут добавляться еще, и там есть такие же объединенные ячейки, просто перенести на новый лист их я тоже не могу
 
 
 
#6
15.05.2024 15:50:45
Код
Sub UnMergeSelection()
    Dim rr As Range
    Set rr = Intersect(Selection, ActiveSheet.UsedRange).Columns(1).Resize(, 2)
    
    Dim arr As Variant
    arr = rr.Value
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To 2)
    
    Dim xa As Long
    Dim ya As Long
    Dim yb As Long
    For ya = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(ya, 1)) Then
            yb = yb + 1
            For xa = 1 To UBound(arr, 2)
                brr(yb, xa) = arr(ya, xa)
            Next
        End If
    Next
    
    rr.Columns(1).UnMerge
    rr.Value = brr
End Sub
 
 
 
#7
15.05.2024 15:55:34
МатросНаЗебре, вы получается берете значения из ячеек и просто в верхнюю ячейку их переносите, но
Цитата
Проверять Объединена ли ячейка в столбце A, и если объединена то ячейки в столбце B нужно объединить на такой же диапазон как в ячейке A
Я писал в теме, что нужно объединять ячейки в столбце B, изменять столбец A не нужно
При использовании вашего макроса получается так, что у меня образуются пустоты, и получается так, что ничего не меняется, у меня вместо 3 заполненных строк остается 1 заполненная и 2 пустые.
 
 
 
#8
15.05.2024 16:00:22
Можно через pq попробовать.
 
 
 
#9
15.05.2024 16:03:21
Код
Sub UnMergeSelection()
    Dim rr As Range
    Set rr = Intersect(Selection, ActiveSheet.UsedRange).Columns(1).Resize(, 2)
    
    Dim arr As Variant
    arr = rr.Value
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To 2)
    
    Application.DisplayAlerts = False
    
    Dim nRow As Long
    Dim xa As Long
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(ya, 1)) Then
            nRow = rr.Cells(ya, 1).MergeArea.Rows.Count
            If nRow > 1 Then rr.Cells(ya, 2).Resize(nRow).Merge
            For xa = 1 To UBound(arr, 2)
                brr(ya, xa) = arr(ya, xa)
            Next
        End If
    Next
    Application.DisplayAlerts = True
    
    rr.Value = brr
End Sub
 
 
 
#10
15.05.2024 16:03:38
Artem_1990, опять же количество строк уменьшается, не совсем мне подходит
 
 
 
#11
15.05.2024 16:05:02
МатросНаЗебре, Спасибо вам большое! Прекрасно работает
 
 
 
#12
15.05.2024 16:09:05
Код
Sub UnMergeSelection()
    Dim rr As Range
    Set rr = Intersect(Selection, ActiveSheet.UsedRange).Columns(1).Resize(, 2)
    
    Application.DisplayAlerts = False
    
    Dim nRow As Long
    Dim ya As Long
    For ya = 1 To rr.Rows.Count
        nRow = rr.Cells(ya, 1).MergeArea.Rows.Count
        If nRow > 1 Then rr.Cells(ya, 2).Resize(nRow).Merge
        ya = ya + nRow - 1
    Next
    Application.DisplayAlerts = True
End Sub
 
 
 
Страницы: 1
Читают тему
Наверх