Ошибка при разбиении текста на символы (на вход данные из Excel) - VB
Формулировка задачи:
Пишу макрос для заполнения документа и для заполнения полей, разбитых на клетки, решил провести посимвольное заполнение.
Но при выполнении программы получаю ошибку Invalid qualifier с указанием на переменную value.
Подпрограмма для разбиения полученного содержимого ячеек на необходимое количество частей:
На всякий случай держите
За основу взят вполне рабочий макрос из интернета.
Поправка.
Ошибка указывает на переменную volume.
Решение задачи: «Ошибка при разбиении текста на символы (на вход данные из Excel)»
textual
Листинг программы
Const NewFileType = ".doc" Dim FindText() As String, ReplaceText() As String, n As Integer Sub СформироватьДоговоры() Dim row As Range, pi As New ProgressIndicator ReDim ReplaceText(1 To 100) As String ReDim FindText(1 To 30) As String r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2 If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub CardType = Cells(2, 2) Select Case CardType Case "Сбербанк-Maestro", "Сбербанк-Visa Electron" TemplateFName = "Doc2.doc" Case "Gold Mastercard", "Visa Gold", "Visa Gold Аэрофлот", "Visa Gold " & Chr(34) & "Подари жизнь" & Chr(34) TemplateFName = "Doc3.doc" Case Else TemplateFName = "Doc1.doc" End Select TemplateDir = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, TemplateFName) NewFolder = NewFolderName & Application.PathSeparator pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc pi.StartNewAction , s1, "Запуск приложения Microsoft Word" ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application ' c подключением библиотеки Word Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application") ' без подключения библиотеки Word For Each row In ActiveSheet.Rows("7:" & r) With row FIO = Trim$(.Cells(2)) & " " & Trim$(.Cells(3)) & " " & Trim$(.Cells(4)) Filename = NewFolder & FIO & NewFileType pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", FIO Set WD = WA.Documents.Add(TemplateDir): DoEvents pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", FIO For i = 1 To 82 Select Case i Case 25 Call x(Len(Trim$(.Cells(i))), Cells(6, i), Trim$(.Cells(i)), False) ' контрольная информация Case 6, 16 Call x(3, Cells(6, i), Trim$(.Cells(i)), True) ' дата Case 31, 41, 51 Call x(6, Cells(6, i), Trim$(.Cells(i)), False) ' идексы Case 29, 63, 76 Call x(10, Cells(6, i), Trim$(.Cells(i)), False) ' номера телефона Case Else FindText(1) = "{" + Cells(6, i) + "}": ReplaceText(1) = Trim$(.Cells(i)) n = 1 End Select ' так почему-то заменяет не всё (не затрагивает таблицу) 'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True 'pi.line3 = "Заменяется поле " & FindText For j = 1 To n ' вставка частей ячейки With WD.Range.Find .Text = FindText(j) .Replacement.Text = ReplaceText(j) .Forward = True .Wrap = 1 .Format = False: .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=2 End With DoEvents Next j Next i pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", FIO, " " WD.SaveAs Filename: WD.Close False: DoEvents p = p + a End With Next row pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " " WA.Quit False: pi.Hide msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & NewFolder MsgBox msg, vbInformation, "Готово" End Sub Sub x(ByVal leng As Integer, ByVal mark As String, ByVal volume As String, ByVal d As Boolean) If d Then ReplaceText() = Split(volume, ".", 3) Else For u% = 1 To Len(volume) ReplaceText(u%) = Mid$(volume, u%, 1) 'asd = Mid$(volume, u%, 1) 'MsgBox asd, vbInformation, "Готово" Next u% End If 'ReDim FindText(1 To leng) As String For j = 1 To leng FindText(j) = "{" & CStr(mark) & CStr(j) & "}" Next j n = leng End Sub Function NewFolderName() As String NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Договоры, сформированные " & Get_Now) MkDir NewFolderName End Function Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д