Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Объединение пустых ячеек столбцов построчно в заданном диапазоне.
 
#1
28.04.2022 21:59:27
Здравствуйте, уважаемые гуру VBA. Прошу помочь разобраться в следующей ситуации:
При проведении инвентаризации возникла необходимость немного автоматизировать процесс. Из 1С выгружается кривая ведомость (во вложении). Графа №8 (статус объекта учета) делится на 3 столбца (AJ,AK,AL), графа №9 (целевая функция актива) на столбцы AM:AR, а одни должны быть едиными ячейками - как показано на листе "Как должно быть". Для того чтобы объединить столбцы в строках пишу макрос (пока только для графы №8):
Код
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
Но после его выполнения, слетает форматирование и в тех строках, которые не должны меняться. Подскажите пожалуйста, в чём ошибка?

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

Разрабатываемый макрос планируется встроить в другой макрос, который уже вносит изменения в инвентарные описи без их открытия (их больше 1000 шт):
Код
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

Если удастся вписать нужные строки кода в него, то буду безмерно благодарен!

Задал такой же вопрос на форуме http://www.excelworld.ru/forum/10-49799-1
Изменено: Сергей GeSS - 29.04.2022 12:30:00
 
 
 
#2
29.04.2022 09:38:10
Код
Sub Rec()
    Dim ii As Long
    Dim jj As Long
    Dim myRange As Range
    Dim flag As Boolean
    
    ii = Cells(Rows.Count, 1).End(xlUp).Row
    Set myRange = Range(Range("AJ41"), Cells(ii, [AL1].Column))
    Application.DisplayAlerts = False
    
    For ii = 1 To myRange.Rows.Count
        If myRange.Cells(ii, 1).Offset(0, -2).Value <> "" Then
            If IsNumeric(myRange.Cells(ii, 1).Offset(0, -2).Value) Then
                flag = True
                For jj = 1 To myRange.Columns.Count
                    If myRange.Cells(ii, jj).Value <> "" Then
                        flag = False
                        Exit For
                    End If
                Next
                If flag Then
                    myRange.Rows(ii).Merge
                    myRange.Cells(ii, 1).HorizontalAlignment = xlHAlignCenter
                End If
            End If
        End If
    Next
    Application.DisplayAlerts = True
End Sub
 
 
 
#3
29.04.2022 09:40:06
Цитата
написал:
Если удастся вписать нужные строки кода в него
Даже не знаю, в человеческих ли это вообще силах? )
Код
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
    
    Rec
    
   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
 
 
 
#4
29.04.2022 10:50:52
О кроссах сообщать нужно. На всех форумах, где вопрос есть

http://www.excelworld.ru/forum/10-49799-1
Скажи мне, кудесник, любимец ба’гов...
 
 
 
#5
29.04.2022 11:12:58
Сергей GeSS, Вернитесь в первое сообщение и приведите в порядок. Коды должны быть оформлены корректно  ищите <...> на панели сообщения.
По вопросам из тем форума, личку не читаю.
 
 
 
#6
29.04.2022 12:23:33
Спасибо уважаемый МатросНаЗебре! Позвольте уточнить, а как расшить макрос на объединение ячеек в графе №9. Сейчас пробую сам дописать, но чёт не уверен, что справлюсь.

Встроить этот макрос в основной будет следующим уровнем сложности! Будем экспериментировать. Не получится, значит буду их использовать отдельно друг от друга.
Изменено: БМВ - 29.04.2022 12:31:02
 
 
 
#7
29.04.2022 12:40:17
Код
Sub Rec()
    RecRange Range("AJ1"), Range("AL1"), Range("AH1"), 41
    RecRange Range("AM1"), Range("AR1"), Range("AH1"), 41
End Sub

Sub RecRange(rLeft As Range, rRight As Range, rCheck As Range, firstRow As Long)
    Dim ii As Long
    Dim jj As Long
    Dim myRange As Range
    Dim flag As Boolean
    
    ii = Cells(Rows.Count, 1).End(xlUp).Row
    Set myRange = Range(rLeft, rRight.Cells(ii, 1))
    Application.DisplayAlerts = False
    
    For ii = firstRow To myRange.Rows.Count
        If rCheck.Cells(ii, 1).Value <> "" Then
            If IsNumeric(rCheck.Cells(ii, 1).Value) Then
                flag = True
                For jj = 1 To myRange.Columns.Count
                    If myRange.Cells(ii, jj).Value <> "" Then
                        flag = False
                        Exit For
                    End If
                Next
                If flag Then
                    myRange.Rows(ii).Merge
                    myRange.Cells(ii, 1).HorizontalAlignment = xlHAlignCenter
                End If
            End If
        End If
    Next
    Application.DisplayAlerts = True
End Sub

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
    
    Rec
    
   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
Изменено: МатросНаЗебре - 29.04.2022 12:40:53
 
 
 
#8
29.04.2022 15:49:37
Безмерно благодарен Вам МатросНаЗебре!  Всё работает как надо, вы мастер!
 
 
 
Страницы: 1
Наверх