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

Вход

Регистрация

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

 

= Мир MS Excel/Объединение пустых ячеек столбцов построчно в диапазоне - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Объединение пустых ячеек столбцов построчно в диапазоне (Макросы/Sub)
Объединение пустых ячеек столбцов построчно в диапазоне
Gestapovich Дата: Четверг, 28.04.2022, 22:08 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 20% ±

Здравствуйте, уважаемые гуру VBA. Прошу помочь разобраться в следующей ситуации:
При проведении инвентаризации возникла необходимость немного автоматизировать процесс. Из 1С выгружается кривая ведомость (во вложении). Графа №8 (статус объекта учета) делится на 3 столбца (AJ,AK,AL), графа №9 (целевая функция актива) на столбцы AM:AR, а одни должны быть едиными ячейками - как показано на листе "Как должно быть". Для того чтобы объединить столбцы в строках пишу макрос (пока только для графы №8):

[vba]
Код
Sub Rec()
Dim i As Long
Dim j As Long
Dim k As Long
Dim myRange As Range
Set myRange = Range("AJ41:AL500")
Application.DisplayAlerts = False

For k = 1 To myRange.Areas.Count
For i = 1 To myRange.Areas(k).Rows.Count
For j = 1 To myRange.Areas(k).Columns.Count
If myRange.Areas(k).Cells(j, i).Value = "" Then
myRange.Areas(k).Rows(i).Merge
myRange.Areas(k).Cells(i, 1).HorizontalAlignment = xlHAlignCenter
End If
Next
Next
Next
Application.DisplayAlerts = True
End Sub
[/vba]

Но после его выполнения, слетает форматирование и в тех строках, которые не должны меняться. Подскажите пожалуйста, в чём ошибка?

На исходном листе нужные диапазоны выделил толстой границей.

Разрабатываемый макрос планируется встроить в другой макрос, который уже вносит изменения в инвентарные описи без их открытия (их больше 1000 шт):

[vba]
Код
Sub Макрос1()

Dim FilesToOpen
Dim x As Integer
Application.ScreenUpdating = False
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xlsx), *.xlsx", _
MultiSelect:=True, Title:="Выберите файлы")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "Не выбрано ни одного файла!"
GoTo ExitHandler
End If
x = 1
Application.Visible = False
While x <= UBound(FilesToOpen)
Workbooks.Open Filename:=FilesToOpen(x)

Sheets(1).Range("BP17").Value = "10.06.2022" 'на листе 1 в ячейку BP17 написать "Новая дата окончания"
Sheets(1).Range("AL1:AL1500").Replace What:="А. А. Корешков", Replacement:="А. А. Котов"
Sheets(1).Range("AJ41:AL41").Merge 'на листе 1 объединить ячейки AJ41:AL41
Sheets(1).Range("AM41:AR41").Merge 'на листе 1 объединить ячейки AM41:AR41

ActiveWorkbook.Close savechanges:=True
x = x + 1
Wend

ExitHandler:
Application.ScreenUpdating = True
Application.Visible = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
[/vba]

Если удастся вписать нужные строки кода в него, то буду безмерно благодарен!
Такой же вопрос разместил на форуме: https://www.planetaexcel.ru/forum....1196974
К сообщению приложен файл: 4574357.xlsx(72.4 Kb)


Сообщение отредактировал Gestapovich - Пятница, 29.04.2022, 12:34
 
Ответить
СообщениеЗдравствуйте, уважаемые гуру VBA. Прошу помочь разобраться в следующей ситуации:
При проведении инвентаризации возникла необходимость немного автоматизировать процесс. Из 1С выгружается кривая ведомость (во вложении). Графа №8 (статус объекта учета) делится на 3 столбца (AJ,AK,AL), графа №9 (целевая функция актива) на столбцы AM:AR, а одни должны быть едиными ячейками - как показано на листе "Как должно быть". Для того чтобы объединить столбцы в строках пишу макрос (пока только для графы №8):

[vba]
Код
Sub Rec()
Dim i As Long
Dim j As Long
Dim k As Long
Dim myRange As Range
Set myRange = Range("AJ41:AL500")
Application.DisplayAlerts = False

For k = 1 To myRange.Areas.Count
For i = 1 To myRange.Areas(k).Rows.Count
For j = 1 To myRange.Areas(k).Columns.Count
If myRange.Areas(k).Cells(j, i).Value = "" Then
myRange.Areas(k).Rows(i).Merge
myRange.Areas(k).Cells(i, 1).HorizontalAlignment = xlHAlignCenter
End If
Next
Next
Next
Application.DisplayAlerts = True
End Sub
[/vba]

Но после его выполнения, слетает форматирование и в тех строках, которые не должны меняться. Подскажите пожалуйста, в чём ошибка?

На исходном листе нужные диапазоны выделил толстой границей.

Разрабатываемый макрос планируется встроить в другой макрос, который уже вносит изменения в инвентарные описи без их открытия (их больше 1000 шт):

[vba]
Код
Sub Макрос1()

Dim FilesToOpen
Dim x As Integer
Application.ScreenUpdating = False
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xlsx), *.xlsx", _
MultiSelect:=True, Title:="Выберите файлы")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "Не выбрано ни одного файла!"
GoTo ExitHandler
End If
x = 1
Application.Visible = False
While x <= UBound(FilesToOpen)
Workbooks.Open Filename:=FilesToOpen(x)

Sheets(1).Range("BP17").Value = "10.06.2022" 'на листе 1 в ячейку BP17 написать "Новая дата окончания"
Sheets(1).Range("AL1:AL1500").Replace What:="А. А. Корешков", Replacement:="А. А. Котов"
Sheets(1).Range("AJ41:AL41").Merge 'на листе 1 объединить ячейки AJ41:AL41
Sheets(1).Range("AM41:AR41").Merge 'на листе 1 объединить ячейки AM41:AR41

ActiveWorkbook.Close savechanges:=True
x = x + 1
Wend

ExitHandler:
Application.ScreenUpdating = True
Application.Visible = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
[/vba]

Если удастся вписать нужные строки кода в него, то буду безмерно благодарен!
Такой же вопрос разместил на форуме: https://www.planetaexcel.ru/forum....1196974

Автор - Gestapovich
Дата добавления - 28.04.2022 в 22:08
китин Дата: Пятница, 29.04.2022, 07:38 | Сообщение № 2
Группа: Модераторы
Ранг: Экселист
Сообщений: 6810
Репутация: 1046 ±
Замечаний: 0% ±

Excel 2007;2010;2016
Gestapovich, - Прочитайте Правила форума
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)
Помогающим просьба воздержаться от ответов в этой теме до исправления замечания


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852
 
Ответить
СообщениеGestapovich, - Прочитайте Правила форума
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)
Помогающим просьба воздержаться от ответов в этой теме до исправления замечания

Автор - китин
Дата добавления - 29.04.2022 в 07:38
_Boroda_ Дата: Пятница, 29.04.2022, 10:23 | Сообщение № 3
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16138
Репутация: 6260 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Такой вариант

[vba]
Код
Sub tt()
    c1_ = 36
    n1_ = 3
    c2_ = 39
    n2_ = 6
    c_ = 11
    r0_ = Cells(1, c_).End(4).Row
    nr_ = Cells(Rows.Count, c_).End(3).Row - r0_ + 2
    ar0 = Cells(r0_, c_).Resize(nr_).Value
    For i = 1 To nr_
        If ar0(i, 1) = 3 Then
            r00_ = i + r0_
        End If
        If IsEmpty(ar0(i, 1)) Then
            If r00_ Then
                r01_ = i + r0_ + 1
                Cells(r00_, c1_).Resize(r01_ - r00_, n1_).Merge True
                Cells(r00_, c2_).Resize(r01_ - r00_, n2_).Merge True
                r00_ = 0
            End If
        End If
    Next i
End Sub
[/vba]


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТакой вариант

[vba]
Код
Sub tt()
    c1_ = 36
    n1_ = 3
    c2_ = 39
    n2_ = 6
    c_ = 11
    r0_ = Cells(1, c_).End(4).Row
    nr_ = Cells(Rows.Count, c_).End(3).Row - r0_ + 2
    ar0 = Cells(r0_, c_).Resize(nr_).Value
    For i = 1 To nr_
        If ar0(i, 1) = 3 Then
            r00_ = i + r0_
        End If
        If IsEmpty(ar0(i, 1)) Then
            If r00_ Then
                r01_ = i + r0_ + 1
                Cells(r00_, c1_).Resize(r01_ - r00_, n1_).Merge True
                Cells(r00_, c2_).Resize(r01_ - r00_, n2_).Merge True
                r00_ = 0
            End If
        End If
    Next i
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 29.04.2022 в 10:23
Gestapovich Дата: Пятница, 29.04.2022, 15:51 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 20% ±

Уважаемые гуру, благодарю за внимание. Решение предоставлено на другом форуме, ссылка на тему в первом сообщении!
 
Ответить
СообщениеУважаемые гуру, благодарю за внимание. Решение предоставлено на другом форуме, ссылка на тему в первом сообщении!

Автор - Gestapovich
Дата добавления - 29.04.2022 в 15:51
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Объединение пустых ячеек столбцов построчно в диапазоне (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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