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

Вход

Регистрация

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

 

= Мир MS Excel/Объединить ячейки - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Объединить ячейки (Макросы/Sub)
Объединить ячейки
tulakov77 Дата: Суббота, 13.08.2022, 18:43 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 48
Репутация: 0 ±
Замечаний: 60% ±

Добрый вечер. Нужен макрос для объедение ячейки. Макрос дольжен искат в листе ячейки с одинаковым данним и объеденит их сохраняя левый верхный. Приложено пример
К сообщению приложен файл: 3777195.xlsx(11.4 Kb)
 
Ответить
СообщениеДобрый вечер. Нужен макрос для объедение ячейки. Макрос дольжен искат в листе ячейки с одинаковым данним и объеденит их сохраняя левый верхный. Приложено пример

Автор - tulakov77
Дата добавления - 13.08.2022 в 18:43
tulakov77 Дата: Суббота, 13.08.2022, 18:46 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 48
Репутация: 0 ±
Замечаний: 60% ±

[vba]
Код
Sub Test()
Dim irow As Range, icel As Range, mergeVal As String
Application.DisplayAlerts = False
For Each irow In Selection.Rows
For Each icel In irow.Cells
If icel.Value <> "" Then mergeVal = mergeVal
Next icel
If mergeVal <> "" Then irow(1).Value = Left(mergeVal, Len(mergeVal) - 1)
mergeVal = ""
irow.Merge
Next irow
Application.DisplayAlerts = True
End Sub
[/vba]

Вот я нашел макрос но он работаеть только в выдленним фрагментам.


Сообщение отредактировал Serge_007 - Понедельник, 15.08.2022, 16:48
 
Ответить
Сообщение[vba]
Код
Sub Test()
Dim irow As Range, icel As Range, mergeVal As String
Application.DisplayAlerts = False
For Each irow In Selection.Rows
For Each icel In irow.Cells
If icel.Value <> "" Then mergeVal = mergeVal
Next icel
If mergeVal <> "" Then irow(1).Value = Left(mergeVal, Len(mergeVal) - 1)
mergeVal = ""
irow.Merge
Next irow
Application.DisplayAlerts = True
End Sub
[/vba]

Вот я нашел макрос но он работаеть только в выдленним фрагментам.

Автор - tulakov77
Дата добавления - 13.08.2022 в 18:46
Kuzmich Дата: Понедельник, 15.08.2022, 16:31 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 682
Репутация: 150 ±
Замечаний: 0% ±

Excel 2003
Попробуйте такой код
[vba]
Код
Option Explicit
Sub iConcatenate()
Dim i As Long
Dim iLastRow As Long
Dim j As Long
Dim k As Long
Dim j_col As Long
Application.DisplayAlerts = False
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
    For i = 5 To iLastRow
      For j = 14 To 5 Step -1
        If Cells(i, j) <> "" Then
          j_col = Cells(i, j).Column
          If j_col > 5 Then
            For k = j_col To 5 Step -1
              If IsEmpty(Cells(i, k)) Or k <= 5 Then
                Range(Cells(i, k), Cells(i, j_col - 1)).MergeCells = True
                Exit For
              End If
            Next
          End If
        End If
      Next
    Next
Application.DisplayAlerts = True
End Sub
[/vba]
 
Ответить
СообщениеПопробуйте такой код
[vba]
Код
Option Explicit
Sub iConcatenate()
Dim i As Long
Dim iLastRow As Long
Dim j As Long
Dim k As Long
Dim j_col As Long
Application.DisplayAlerts = False
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
    For i = 5 To iLastRow
      For j = 14 To 5 Step -1
        If Cells(i, j) <> "" Then
          j_col = Cells(i, j).Column
          If j_col > 5 Then
            For k = j_col To 5 Step -1
              If IsEmpty(Cells(i, k)) Or k <= 5 Then
                Range(Cells(i, k), Cells(i, j_col - 1)).MergeCells = True
                Exit For
              End If
            Next
          End If
        End If
      Next
    Next
Application.DisplayAlerts = True
End Sub
[/vba]

Автор - Kuzmich
Дата добавления - 15.08.2022 в 16:31
tulakov77 Дата: Понедельник, 15.08.2022, 17:40 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 48
Репутация: 0 ±
Замечаний: 60% ±

Попробуйте такой код


Спасибо но не дасть ожидаемого результата. Ещё раз прикреплю пример файл
К сообщению приложен файл: 5387125.xlsx(11.7 Kb)


Сообщение отредактировал tulakov77 - Понедельник, 15.08.2022, 17:40
 
Ответить
Сообщение
Попробуйте такой код


Спасибо но не дасть ожидаемого результата. Ещё раз прикреплю пример файл

Автор - tulakov77
Дата добавления - 15.08.2022 в 17:40
msi2102 Дата: Вторник, 16.08.2022, 09:16 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 198
Репутация: 79 ±
Замечаний: 0% ±

Excel 2007
Тогда пробуйте такой код
[vba]
Код
Sub Макрос1()
Dim n As Integer, m As Integer, rng As Range
Application.DisplayAlerts = False
arr1 = Range("A1:N" & Cells(Rows.Count, "C").End(xlUp).Row)
    For n = 5 To UBound(arr1)
        For m = 5 To UBound(arr1, 2) - 2 Step 2
            If arr1(n, m) = arr1(n, m + 2) And arr1(n, m) <> "" Then
                If rng Is Nothing Then Set rng = Range(Cells(n, m), Cells(n, m + 2)) Else Set rng = Union(rng, Cells(n, m + 1), Cells(n, m + 2))
            Else
                If Not rng Is Nothing Then rng.MergeCells = True: Set rng = Nothing
            End If
        Next
    Next
Application.DisplayAlerts = True
End Sub
[/vba]
К сообщению приложен файл: 5387125.xlsm(20.3 Kb)


Сообщение отредактировал msi2102 - Вторник, 16.08.2022, 10:32
 
Ответить
СообщениеТогда пробуйте такой код
[vba]
Код
Sub Макрос1()
Dim n As Integer, m As Integer, rng As Range
Application.DisplayAlerts = False
arr1 = Range("A1:N" & Cells(Rows.Count, "C").End(xlUp).Row)
    For n = 5 To UBound(arr1)
        For m = 5 To UBound(arr1, 2) - 2 Step 2
            If arr1(n, m) = arr1(n, m + 2) And arr1(n, m) <> "" Then
                If rng Is Nothing Then Set rng = Range(Cells(n, m), Cells(n, m + 2)) Else Set rng = Union(rng, Cells(n, m + 1), Cells(n, m + 2))
            Else
                If Not rng Is Nothing Then rng.MergeCells = True: Set rng = Nothing
            End If
        Next
    Next
Application.DisplayAlerts = True
End Sub
[/vba]

Автор - msi2102
Дата добавления - 16.08.2022 в 09:16
tulakov77 Дата: Вторник, 16.08.2022, 13:04 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 48
Репутация: 0 ±
Замечаний: 60% ±

Тогда пробуйте такой код

Спасибо большой. Ваш код работаль но таблица может меняться налево-направо или вверх-вниз в это время он пересталь работать
 
Ответить
Сообщение
Тогда пробуйте такой код

Спасибо большой. Ваш код работаль но таблица может меняться налево-направо или вверх-вниз в это время он пересталь работать

Автор - tulakov77
Дата добавления - 16.08.2022 в 13:04
msi2102 Дата: Вторник, 16.08.2022, 14:14 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 198
Репутация: 79 ±
Замечаний: 0% ±

Excel 2007
Ищет слово "Пары" в диапазоне "A1:Z100", по адресу этой ячейки определяет последнюю заполненную строку и столбец, а также ячейку начала обработки одну строку вниз и через столбец), структура таблицы должна сохраняться (группа, аудитория, группа, аудитория и т.д.)
[vba]
Код
Sub Макрос1()
Dim n As Integer, m As Integer, lr As Integer, lc As Integer, rng As Range
Application.DisplayAlerts = False
Set myCell = Range("A1:Z100").Find("Пары")
lr = Cells(Rows.Count, myCell.Column).End(xlUp).Row
lc = Cells(myCell.Row, Columns.Count).End(xlToLeft).Column
arr1 = Range(Cells(1, 1), Cells(lr, lc))
    For n = myCell.Row + 1 To UBound(arr1)
        For m = myCell.Column + 2 To UBound(arr1, 2) - 2 Step 2
            If arr1(n, m) = arr1(n, m + 2) And arr1(n, m) <> "" Then
                If rng Is Nothing Then Set rng = Range(Cells(n, m), Cells(n, m + 2)) Else Set rng = Union(rng, Cells(n, m + 1), Cells(n, m + 2))
            Else
                If Not rng Is Nothing Then rng.MergeCells = True: Set rng = Nothing
            End If
        Next
    Next
Application.DisplayAlerts = True
End Sub
[/vba]
К сообщению приложен файл: 2303199.xlsm(19.3 Kb)


Сообщение отредактировал msi2102 - Вторник, 16.08.2022, 14:18
 
Ответить
СообщениеИщет слово "Пары" в диапазоне "A1:Z100", по адресу этой ячейки определяет последнюю заполненную строку и столбец, а также ячейку начала обработки одну строку вниз и через столбец), структура таблицы должна сохраняться (группа, аудитория, группа, аудитория и т.д.)
[vba]
Код
Sub Макрос1()
Dim n As Integer, m As Integer, lr As Integer, lc As Integer, rng As Range
Application.DisplayAlerts = False
Set myCell = Range("A1:Z100").Find("Пары")
lr = Cells(Rows.Count, myCell.Column).End(xlUp).Row
lc = Cells(myCell.Row, Columns.Count).End(xlToLeft).Column
arr1 = Range(Cells(1, 1), Cells(lr, lc))
    For n = myCell.Row + 1 To UBound(arr1)
        For m = myCell.Column + 2 To UBound(arr1, 2) - 2 Step 2
            If arr1(n, m) = arr1(n, m + 2) And arr1(n, m) <> "" Then
                If rng Is Nothing Then Set rng = Range(Cells(n, m), Cells(n, m + 2)) Else Set rng = Union(rng, Cells(n, m + 1), Cells(n, m + 2))
            Else
                If Not rng Is Nothing Then rng.MergeCells = True: Set rng = Nothing
            End If
        Next
    Next
Application.DisplayAlerts = True
End Sub
[/vba]

Автор - msi2102
Дата добавления - 16.08.2022 в 14:14
tulakov77 Дата: Вторник, 16.08.2022, 16:09 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 48
Репутация: 0 ±
Замечаний: 60% ±

Спасибо, супер.


Сообщение отредактировал Serge_007 - Вторник, 16.08.2022, 16:33
 
Ответить
СообщениеСпасибо, супер.

Автор - tulakov77
Дата добавления - 16.08.2022 в 16:09
tulakov77 Дата: Среда, 24.08.2022, 06:47 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 48
Репутация: 0 ±
Замечаний: 60% ±

msi2102, Добрый утро можете еще раз помоч сделат код противоположный отменит объедение ячейки в этом примере.
 
Ответить
Сообщениеmsi2102, Добрый утро можете еще раз помоч сделат код противоположный отменит объедение ячейки в этом примере.

Автор - tulakov77
Дата добавления - 24.08.2022 в 06:47
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Объединить ячейки (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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