Макрос импорта данных из Excel in Word, Адаптировал ранее предложенный макрос Дмитрия Щербакова
Пользователь
Сообщений: Регистрация: 14.12.2023
04.03.2024 11:55:01
Всем привет! Попытался адаптировать под себя макрос импорта из эксель в ворд по меткам Взял за основу работу Щербакова отсюда
Суть адаптации: - Есть вордовский документ "Шаблон.doc" в котором стоят в нужных местах метки в фигурных скобках {Метка1} {Яч1} {Лист1}. - В рабочей книге метками являются имена ячеек (без каких либо скобок) и имена листов (также в фигурных скобках). - Макрос производит замену меток в шаблоне и сохраняет документ под другим именем. Причем метку, которая соответствует наименованию листа рабочей книги макрос должен заменить таблицей с этого листа.
Суть проблемы: - Не пойму как заменить метку в ворде скопированным диапазоном с листа ((
Код с описанием. Проблемный участок между пробелами. Подскажите юному дилетанту пожалуйста.
Скрытый текст
Код
Sub Import_Word()
Dim objWrdApp As Object, objWrdDoc As Object, wdRange As Object
Dim IsAppClose As Boolean
Application.ScreenUpdating = True
'пытаемся подключится к Word
On Error Resume Next
Set objWrdApp = GetObject(, "Word.Application")
If objWrdApp Is Nothing Then
'если приложение закрыто - создаем новый экземпляр
Set objWrdApp = CreateObject("Word.Application")
'сделать видимым
objWrdApp.Visible = True
IsAppClose = True 'Не знаю что это
End If
On Error GoTo 0
If objWrdApp Is Nothing Then
MsgBox "Не удалось подключиться к Word"
Application.ScreenUpdating = True
Exit Sub
End If
'Открываем документ Word - документ "C:\макрос\Шаблон.doc"
'находится в папке с рабочей книгой
Set objWrdDoc = objWrdApp.Documents.Open("C:\макрос\Шаблон.doc")
'сохраняем файл шаблона с как "Расчет+дата.doc"
objWrdDoc.SaveAs ThisWorkbook.Path & "\Расчет " & Format(Now, "dd-mm-yy hh-mm") & ".doc"
'Перебираем именованые ячейки книги и сравниваем с метками в шаблоне, производим замену,
'если есть совпадения.
'Например. Значение ячейки с именем "Яч1" заменит метку в шаблоне {Яч1} по всему документу
Dim nName As Name
For Each nName In ThisWorkbook.Names
Set wdRange = objWrdDoc.Range
wdRange.Find.ClearFormatting
wdRange.Find.Replacement.ClearFormatting
With wdRange.Find
.text = "{" & nName.Name & "}"
.Replacement.text = Range(nName).text
.Forward = True
.Wrap = 1 'wdFindContinue - не знаю что это
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2 'wdReplaceAll - почемуто воспринимается как переменная и не работает :(
End With
Next nName
'Аналогичный перебор с листами книги. Таблица из листа {Лист1} должна заменить метку в шаблоне {Лист1}
Dim List As Worksheet
For Each List In ThisWorkbook.Worksheets
'Чтобы в переборе участвовали только листы с фигурными скобками
If InStr(List.Name, "{") > 0 Then
'Скопировали содержание листа
ThisWorkbook.Worksheets(List.Name).UsedRange.Copy
'Поиск и замена
With wdRange.Find
.text = List.Name
.Replacement.text = Selection.Paste ' Что то делаю не так :(((
.Forward = True
.Wrap = 1 'wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2 'wdReplaceAll
End With
End If
Next List
'закрываем документ Word с сохранением
objWrdDoc.Close True
'закрываем приложение Word - обязательно!
objWrdApp.Quit
'очищаем переменные Word - обязательно!
Set objWrdDoc = Nothing: Set objWrdApp = Nothing
End Sub
Изменено: - 04.03.2024 12:20:56
Bubble Sort, Изучаю VBA Затык с Bubble Sort
Пользователь
Сообщений: Регистрация: 14.12.2023
20.01.2024 01:45:47
Всем привет. В строке рандомные значения. Нужно отсортировать. Изучаю Bubble Sort.
Код
Sub Урок24_DZ()
Dim Mass() As Long
Dim LB As Long
Dim UB As Long
LB = 20
UB = ThisWorkbook.Worksheets("Лист1").Cells(14, Columns.Count).End(xlToLeft).Column
ReDim Mass(LB To UB) As Long
Call Module5.BBS_DZ(Mass)
End Sub
'----------------------------------------------------------
Sub BBS_DZ(list() As Long)
Dim first As Long
Dim lust As Long
Dim i As Long
Dim j As Long
Dim temp As String
first = LBound(list)
lust = UBound(list)
For i = first To lust - 1
For j = i + 1 To lust
If Cells(14, i) > Cells(14, j) Then
temp = Cells(14, j)
Cells(14, j) = Cells(14, i)
Cells(14, i) = temp
End If
Next j
Next i
End Sub
Все работает.
Но тут мне захотелось, чтобы не эта строка сортировалась, а сортировались значения и выводились строкой ниже. Тот же массив. Проверяю заполнен значениями. Но почему то перебор нулей и строка заполняется нулями ((
Код
Sub Урок24_D_Z()
Dim Mass() As Long
Dim LB As Long
Dim UB As Long
LB = 20
UB = ThisWorkbook.Worksheets("Лист1").Cells(14, Columns.Count).End(xlToLeft).Column
ReDim Mass(LB To UB) As Long
'Dim i As Long
'For i = LBound(Mass) To UBound(Mass)
' Debug.Print ThisWorkbook.Worksheets("Лист1").Cells(14, i)
'Next i
Call Module5.BBS_D_Z(Mass)
'----------------------------------------------------------------------
End Sub
Sub BBS_D_Z(list() As Long)
Dim i As Long
Dim j As Long
Dim temp As String
'For i = LBound(list) To UBound(list)
' Debug.Print ThisWorkbook.Worksheets("Лист1").Cells(14, i)
'Next i
For i = LBound(list) To UBound(list) - 1
For j = i + 1 To UBound(list)
If list(i) > list(j) Then
temp = list(j)
list(j) = list(i)
list(i) = temp
End If
Next j
Next i
For i = LBound(list) To UBound(list)
ThisWorkbook.Worksheets("Лист1").Cells(15, i).Value = list(i)
Next i
End Sub
Подскажите где я туплю пож.
Формирование таблицы без пустых строк, Формирование таблицы без пустых строк
Пользователь
Сообщений: Регистрация: 14.12.2023
15.12.2023 00:25:49
Здравствуйте, Подскажите пожалуйста!
Есть таблица с исходными данными А и В рассчитана на 10 вариантов. например для поиска x=a+b. См. пример. На основании исходных данных формируется таблица с результатом. Если в исходных данных присутствуют все 10 вариантов - таблица с результатами заполнится и все ОК. Но если у нас только 2 варианта - то в таблице результатов будет 8 пустых строк. Вопрос - как сделать так чтобы формировалась таблица с результатами исходя из имеющихся вариантов? Т.е. если 2 варианта то и таблица результатов состоит только из 2х строк.
((