Option Explicit Sub ConsolidateZachetki() Dim fd As Fil...
Prompt
Option Explicit Sub ConsolidateZachetki() Dim fd As FileDialog Dim folderPath As String Dim fileName As String Dim wbSource As Workbook, wbDest As Workbook Dim wsSource As Worksheet, wsDest As Worksheet Dim lastRowDest As Long, lastRowSource As Long Dim r As Long Dim srcHeaderRow As Long, destHeaderRow As Long Dim lastSrcHeaderCol As Long, lastDestHeaderCol As Long ' Устанавливаем целевой файл (текущий открытый шаблон) Set wbDest = ThisWorkbook Set wsDest = wbDest.Sheets(1) ' Ищем строку с заголовками в новом шаблоне destHeaderRow = FindHeaderRow(wsDest) lastDestHeaderCol = wsDest.Cells(destHeaderRow, wsDest.Columns.Count).End(xlToLeft).Column ' Запрашиваем у пользователя папку с исходными файлами Set fd = Application.FileDialog(msoFileDialogFolderPicker) fd.Title = "Выберите папку с файлами старого шаблона" If fd.Show = -1 Then folderPath = fd.SelectedItems(1) & "\" Else MsgBox "Папка не выбрана. Отмена.", vbExclamation Exit Sub End If ' Отключаем обновление экрана и пересчет формул для ускорения работы Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlCalculationManual fileName = Dir(folderPath & "*.xls*") If fileName = "" Then MsgBox "В выбранной папке не найдено файлов Excel.", vbInformation GoTo Cleanup End If ' Задаем ключевые слова для поиска начала каждого блока в шапке Dim keys As Variant, searchStrings As Variant keys = Array("ВКР", "НИР", "Промежуточная", "Факультативные", "Курсовые", "Практика", "Гос") searchStrings = Array("Форма выпускной", "Вид научно", "Сведения о результатах промежуточной", _ "Сведения о факультативных", "Сведения о курсовых", "Сведения о практике", "Сведения о государственном") ' Задаем порядок следования блоков в Старом и Новом шаблонах Dim srcOrder As Variant, destOrder As Variant srcOrder = Array("НИР", "ВКР", "Промежуточная", "Факультативные", "Курсовые", "Практика", "Гос") destOrder = Array("ВКР", "НИР", "Промежуточная", "Факультативные", "Курсовые", "Практика", "Гос") ' Определяем начальные столбцы для каждого блока в НОВОМ шаблоне Dim destCols As Object Set destCols = CreateObject("Scripting.Dictionary") Dim i As Long For i = LBound(keys) To UBound(keys) destCols.Add keys(i), GetBlockStart(wsDest, destHeaderRow, searchStrings(i)) Next i ' Находим последнюю заполненную строку в новом шаблоне для добавления данных lastRowDest = wsDest.Cells(wsDest.Rows.Count, 2).End(xlUp).Row If lastRowDest <= destHeaderRow Then lastRowDest = destHeaderRow + 1 Dim filesProcessed As Long, studentsProcessed As Long filesProcessed = 0 studentsProcessed = 0 ' Цикл по всем файлам в папке Do While fileName <> "" If fileName <> wbDest.Name Then On Error Resume Next Set wbSource = Workbooks.Open(folderPath & fileName, ReadOnly:=True) If Err.Number <> 0 Then Err.Clear fileName = Dir GoTo NextFile End If On Error GoTo 0 Set wsSource = wbSource.Sheets(1) srcHeaderRow = FindHeaderRow(wsSource) lastSrcHeaderCol = wsSource.Cells(srcHeaderRow, wsSource.Columns.Count).End(xlToLeft).Column ' Определяем начальные столбцы для каждого блока в СТАРОМ шаблоне Dim srcCols As Object Set srcCols = CreateObject("Scripting.Dictionary") For i = LBound(keys) To UBound(keys) srcCols.Add keys(i), GetBlockStart(wsSource, srcHeaderRow, searchStrings(i)) Next i ' Находим последнюю строку с данными в исходном файле lastRowSource = wsSource.Cells(wsSource.Rows.Count, 2).End(xlUp).Row ' Цикл по строкам студентов For r = srcHeaderRow + 1 To lastRowSource ' Проверяем, что строка не пустая (смотрим на Фамилию - столбец 2) If Trim(wsSource.Cells(r, 2).Value) <> "" And UCase(Trim(wsSource.Cells(r, 2).Value)) <> "ФАМИЛИЯ" Then ' 1. Копируем базовую информацию (Столбцы 1-7: UID, Фамилия, Имя, Отчество, Курс, Номер, Дата) wsSource.Range(wsSource.Cells(r, 1), wsSource.Cells(r, 7)).Copy _ wsDest.Cells(lastRowDest, 1) ' 2. Копируем смысловые блоки с учетом их ширины и порядка Dim key As Variant For Each key In keys If srcCols(key) > 0 And destCols(key) > 0 Then Dim srcWidth As Long, destWidth As Long, copyWidth As Long ' Вычисляем ширину блока в старом и новом шаблоне srcWidth = GetBlockWidth(srcCols, key, srcOrder, lastSrcHeaderCol) destWidth = GetBlockWidth(destCols, key, destOrder, lastDestHeaderCol) ' Выбираем минимальную ширину, чтобы не затереть соседние блоки в новом шаблоне If srcWidth > 0 And destWidth > 0 Then copyWidth = IIf(srcWidth < destWidth, srcWidth, destWidth) ElseIf srcWidth > 0 Then copyWidth = srcWidth Else copyWidth = 0 End If ' Копируем блок If copyWidth > 0 Then wsSource.Range(wsSource.Cells(r, srcCols(key)), wsSource.Cells(r, srcCols(key) + copyWidth - 1)).Copy _ wsDest.Cells(lastRowDest, destCols(key)) End If End If Next key lastRowDest = lastRowDest + 1 studentsProcessed = studentsProcessed + 1 End If Next r wbSource.Close SaveChanges:=False filesProcessed = filesProcessed + 1 End If NextFile: fileName = Dir Loop Cleanup: ' Возвращаем настройки Excel в исходное состояние Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic MsgBox "Готово!" & vbCrLf & "Обработано файлов: " & filesProcessed & vbCrLf & "Перенесено студентов: " & studentsProcessed, vbInformation End Sub ' Функция поиска строки с заголовками Function FindHeaderRow(ws As Worksheet) As Long Dim r As Long For r = 1 To 10 If UCase(Trim(ws.Cells(r, 2).Value)) Like "*ФАМИЛИЯ*" Or UCase(Trim(ws.Cells(r, 1).Value)) Like "*UID*" Then FindHeaderRow = r Exit Function End If Next r FindHeaderRow = 1 End Function ' Функция поиска начального столбца блока по тексту в шапке Function GetBlockStart(ws As Worksheet, headerRow As Long, searchText As String) As Long Dim c As Range Set c = ws.Rows(headerRow).Find(What:=searchText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False) If Not c Is Nothing Then GetBlockStart = c.Column Else GetBlockStart = 0 End If End Function ' Функция вычисления ширины блока (количества столбцов) Function GetBlockWidth(colsDict As Object, currentKey As String, orderArray As Variant, lastHeaderCol As Long) As Long Dim i As Long, j As Long Dim currentCol As Long currentCol = colsDict(currentKey) If currentCol = 0 Then GetBlockWidth = 0 Exit Function End If For i = 0 To UBound(orderArray) If orderArray(i) = currentKey Then ' Ищем следующий существующий блок, чтобы вычислить ширину текущего For j = i + 1 To UBound(orderArray) If colsDict(orderArray(j)) > 0 Then GetBlockWidth = colsDict(orderArray(j)) - currentCol Exit Function End If Next j ' Если это последний блок, берем ширину до конца заполненной шапки GetBlockWidth = lastHeaderCol - currentCol + 1 Exit Function End If Next i GetBlockWidth = 0 End Function Запрос для ИИ был такой: Напиши мне код вба для эксель 2013, для переноса данных из нескольких файлов одного шаблона в один общий файл другого шаблона Перепиши этот код чтобы он стал идеальным
