Здравствуйте, уважаемые гуру VBA. Прошу помочь разобраться в следующей ситуации:
При проведении инвентаризации возникла необходимость немного автоматизировать процесс. Из 1С выгружается кривая ведомость (во вложении). Графа №8 (статус объекта учета) делится на 3 столбца (AJ,AK,AL), графа №9 (целевая функция актива) на столбцы AM:AR, а одни должны быть едиными ячейками - как показано на листе "Как должно быть". Для того чтобы объединить столбцы в строках пишу макрос (пока только для графы №8):
Но после его выполнения, слетает форматирование и в тех строках, которые не должны меняться. Подскажите пожалуйста, в чём ошибка?
На исходном листе нужные диапазоны выделил толстой границей.
Разрабатываемый макрос планируется встроить в другой макрос, который уже вносит изменения в инвентарные описи без их открытия (их больше 1000 шт):
Если удастся вписать нужные строки кода в него, то буду безмерно благодарен!
Задал такой же вопрос на форуме
При проведении инвентаризации возникла необходимость немного автоматизировать процесс. Из 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
|
Если удастся вписать нужные строки кода в него, то буду безмерно благодарен!
Задал такой же вопрос на форуме
Изменено: - 29.04.2022 12:30:00
