Задолбал меня чат-бот, или я его. Есть код который надо подправить, это макрос известный сбора листов из разных книг в одну пытаюсьь вразумить его что мне надо-а никак,, начинает сам путаться. А все что осталось-это ширина столбцов D,E,F по максимальной ширине содержимого ячеек ниже 10 строки.. может людской мозг всетаки лучше? подскажет кто?
Код
Sub Consolidated_Range_of_Books_and_Sheets()
Dim iBeginRange As Object, lCalc As Long, lCol As Long
Dim oAwb As String, sCopyAddress As String, sSheetName As String
Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
Dim wsSh As Object, wsDataSheet As Object, bPolyBooks As Boolean, avFiles
Dim wbAct As Workbook
Dim bPasteValues As Boolean
Dim maxWidthD As Double, maxWidthE As Double, maxWidthF As Double
Dim cell As Range
On Error Resume Next
'Выбираем диапазон выборки с книг
Set iBeginRange = Range("A1") 'диапазон указывается нужный
'Если диапазон не выбран - завершаем процедуру
If iBeginRange Is Nothing Then Exit Sub
'Указываем имя листа
If sSheetName = "" Then sSheetName = "*"
On Error GoTo 0
'Запрос - вставлять на результирующий лист все данные
'или только значения ячеек (без формул и форматов)
bPasteValues = False 'Вставляем и значения, и все остальное
'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги)
avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", "E:\", True)
If VarType(avFiles) = vbBoolean Then Exit Sub
bPolyBooks = True
lCol = 1
'отключаем обновление экрана, автопересчет формул и отслеживание событий
'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
With Application
lCalc = .Calculation
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
End With
'создаем новый лист в книге для сбора
Set wsDataSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
'очищаем первый столбец на новом листе
wsDataSheet.Columns(1).ClearContents
'цикл по книгам
For li = LBound(avFiles) To UBound(avFiles)
If bPolyBooks Then
Set wbAct = Workbooks.Open(Filename:=avFiles(li))
Else
Set wbAct = ThisWorkbook
End If
oAwb = wbAct.Name
'цикл по листам
For Each wsSh In wbAct.Sheets
If wsSh.Name Like sSheetName Then
'Если имя листа совпадает с именем листа, в который собираем данные
'и сбор идет только с активной книги - то переходим к следующему листу
If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
With wsSh
Select Case iBeginRange.Count
Case 1 'собираем данные начиная с указанной ячейки и до конца данных
lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
iLastColumn = .Cells.SpecialCells(xlLastCell).Column
sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address
Case Else 'собираем данные с фиксированного диапазона
sCopyAddress = iBeginRange.Address
End Select
lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
'вставляем имя книги, с которой собраны данные
If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = oAwb
If bPasteValues Then 'если вставляем только значения
.Range(sCopyAddress).Copy
wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues
Else
.Range(sCopyAddress).Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
End If
End With
End If
NEXT_:
Next wsSh
If bPolyBooks Then wbAct.Close False
Next li
'устанавливаем ширину столбцов D, E и F по максимальной длине текста в строках начиная с 11
maxWidthD = 0
maxWidthE = 0
maxWidthF = 0
For Each cell In wsDataSheet.Range("D11:D" & wsDataSheet.Cells(wsDataSheet.Rows.Count, "D").End(xlUp).Row)
If Len(Trim(cell.Value)) > maxWidthD Then maxWidthD = Len(Trim(cell.Value))
Next cell
For Each cell In wsDataSheet.Range("E11:E" & wsDataSheet.Cells(wsDataSheet.Rows.Count, "E").End(xlUp).Row)
If Len(Trim(cell.Value)) > maxWidthE Then maxWidthE = Len(Trim(cell.Value))
Next cell
For Each cell In wsDataSheet.Range("F11:F" & wsDataSheet.Cells(wsDataSheet.Rows.Count, "F").End(xlUp).Row)
If Len(Trim(cell.Value)) > maxWidthF Then maxWidthF = Len(Trim(cell.Value))
Next cell
wsDataSheet.Columns("D").ColumnWidth = maxWidthD * 1.2
wsDataSheet.Columns("E").ColumnWidth = maxWidthE * 1.2
wsDataSheet.Columns("F").ColumnWidth = maxWidthF * 1.2
'автоподбор высоты строк
wsDataSheet.Rows.AutoFit
'очищаем первый столбец на новом листе
wsDataSheet.Columns("A").ClearContents
With Application
.ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
End With
End Sub