Макрос бесконечного цикла Excel продолжает запрашивать ввод пользователя и не может "входить" в отладку. Цикл excel макрос

vba - Цикл макросов в Excel

Я хотел бы прокрутить лист Excel и сохранить значения на основе уникального идентификатора в текстовом файле.

У меня возникают проблемы с циклом, и я провел исследование по нему без везения, и мой текущий вложенный цикл постоянно переполняется. Вместо обновления соответствующей ячейки при изменении управляющей переменной она продолжает сохранять начальное значение индекса для всех итераций 32767.

Пожалуйста, может кто-нибудь объяснить, почему это происходит, и обеспечить способ его исправления?

Sub SortLetr_Code() 'sort columns for Letr_Code files Dim lr As Long Application.ScreenUpdating = False lr = Cells(Rows.Count, 1).End(xlUp).Row Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1 Application.ScreenUpdating = True 'Value of cell for example B1 starts out as X Dim x As Integer Dim y As Integer x = 2 y = 2 'Cell References Dim rwCounter As Range Dim rwCorresponding As Range Dim rwIndexValue As Range Dim rwIndexEnd As Range Dim rwIndexStore As Range 'Variables for files that will be created Dim FilePath As String Dim Filename As String Dim Filetype As String 'Variables defined FilePath = "C:\Users\Home\Desktop\SURLOAD\" Filetype = ".dat" 'Use Cell method for Loop rwIndex = Cells(x, "B").Value Set rwCounter = Range("B" & x) 'Use Range method for string manipulation Set rwCorresponding = Range("A" & x) Set rwIndexValue = Range("B" & y) Set rwIndexStore = Range("B" & x) Set rwIndexEnd = Range("B:B").End(xlUp) 'Objects for creating the text files Dim FileCreate As Object Set FileCreate = CreateObject("Scripting.FileSystemObject") 'Object for updating the file during the loop Dim FileWrite As Object For Each rwIndexStore In rwIndexEnd.Cells 'Get Substring of cell value in BX for the file name Do Until IsEmpty(rwCounter) Filename = Mid$(rwIndexValue, 7, 5) Set FileWrite = FileCreate.CreateTextFile(FilePath + Filename + Filetype) 'Create the file FileWrite.Write (rwCorresponding & vbCrLf) Do 'Add values to the textfile x = x + 1 FileWrite.Write (rwCorresponding & vbCrLf) Loop While rwCounter.Value Like rwIndexValue.Value 'Close this file FileWrite.Close y = x Loop Next rwIndexStore End Sub источник поделиться

qaru.site

vba - Макрос бесконечного цикла Excel продолжает запрашивать ввод пользователя и не может "входить" в отладку

Я создаю несколько макросов, чтобы сделать следующее в Excel 2010: 1. Создав новый лист, спросите, что пользователь хочет назвать своим листом, и задает новый рабочий лист указанному имени; вызывает Sort_Active_Book и Rebuild_TOC в порядке 2. Sort_Active_Book: спрашивает пользователя, хочет ли он/она сортировать рабочие листы в порядке возрастания/убывания и продолжает это делать. 3. Rebuild_TOC: удаляет страницу оглавления и перестраивает ее на основе всех листов в рабочей книге за вычетом самого ООС.

Моя проблема заключается в том, что Excel продолжает просить меня ввести имя нового рабочего листа, который будет создан, и не будет продвигаться дальше в коде. Я замечаю, что ему удается создать именованный рабочий лист и спрашивает меня, хочу ли я сортировать восходящий или нисходящий, а затем снова спрашивает имя нового рабочего листа. Может ли кто-нибудь указать, как исправить это и предоставить исправление кода (если возможно), пожалуйста?

Что я уже

Эта часть кода из этой книги, это то, что подсказывает пользователю имя рабочего листа при его создании.

Private Sub Workbook_NewSheet(ByVal Sh As Object) Dim sName As String Dim bValidName As Boolean Dim i As Long bValidName = False Do While bValidName = False sName = InputBox("Please name this new worksheet:", "New Sheet Name", Sh.Name) If Len(sName) > 0 Then For i = 1 To 7 sName = Replace(sName, Mid(":\/?*[]", i, 1), " ") Next i sName = Trim(Left(WorksheetFunction.Trim(sName), 31)) If Not Evaluate("ISREF('" & sName & "'!A1)") Then bValidName = True End If Loop Sh.Name = sName Call Sort_Active_Book Call Rebuild_TOC End Sub

Эти два макроса находятся в "Модуле 1":

Sub Sort_Active_Book() Dim TotalSheets As Integer Dim p As Integer Dim iAnswer As VbMsgBoxResult ' Move the TOC to the begining of the document. Sheets("TOC").Move Before:=Sheets(1) ' Prompt the user as to which direction they wish to ' sort the worksheets. iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) & "Clicking No will sort in Descending Order", vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets") For TotalSheets = 1 To Sheets.Count For p = 2 To Sheets.Count - 1 ' If the answer is Yes, then sort in ascending order. If iAnswer = vbYes Then If UCase$(Sheets(p).Name) = "TOC" Then Sheets(p).Move Before:=Sheets(1) ElseIf UCase$(Sheets(p).Name) > UCase$(Sheets(p + 1).Name) Then Sheets(p).Move After:=Sheets(p + 1) End If ' If the answer is No, then sort in descending order. ElseIf iAnswer = vbNo Then If UCase$(Sheets(p).Name) = "TOC" Then Sheets(p).Move Before:=Sheets(1) ElseIf UCase$(Sheets(p).Name) < UCase$(Sheets(p + 1).Name) Then Sheets(p).Move After:=Sheets(p + 1) End If End If Next p Next TotalSheets End Sub

а также

Sub Rebuild_TOC() Dim wbBook As Workbook Dim wsActive As Worksheet Dim wsSheet As Worksheet Dim lnRow As Long Dim lnPages As Long Dim lnCount As Long Set wbBook = ActiveWorkbook With Application .DisplayAlerts = False .ScreenUpdating = False End With ' If the TOC sheet already exist delete it and add a new worksheet. On Error Resume Next With wbBook .Worksheets("TOC").Delete .Worksheets.Add Before:=.Worksheets(1) End With On Error GoTo 0 Set wsActive = wbBook.ActiveSheet With wsActive .Name = "TOC" With .Range("A1:B1") .Value = VBA.Array("Table of Contents", "Sheet # – # of Pages") .Font.Bold = True End With End With lnRow = 2 lnCount = 1 ' Iterate through the worksheets in the workbook and create sheetnames, add hyperlink ' and count & write the running number of pages to be printed for each sheet on the TOC. For Each wsSheet In wbBook.Worksheets If wsSheet.Name <> wsActive.Name Then wsSheet.Activate With wsActive .Hyperlinks.Add .Cells(lnRow, 1), "", _ SubAddress:="‘" & wsSheet.Name & "‘!A1", _ TextToDisplay:=wsSheet.Name lnPages = wsSheet.PageSetup.Pages().Count .Cells(lnRow, 2).Value = "‘" & lnCount & "-" & lnPages End With lnRow = lnRow + 1 lnCount = lnCount + 1 End If Next wsSheet wsActive.Activate wsActive.Columns("A:B").EntireColumn.AutoFit With Application .DisplayAlerts = True .ScreenUpdating = True End With End Sub

qaru.site

Макрос цикла Excel заканчивается раньше и требует, чтобы файлы открывались для копирования нескольких циклов (разных файлов)

У меня проблема с этим кодом VBA

Sub upONGOING_Train1() ScreenUpdating = False 'set variables Dim rFndCell As Range Dim strData As String Dim stFnd As String Dim fCol As Integer Dim oCol As Integer Dim SH As Worksheet Dim WS As Worksheet Dim strFName As String Dim objCell As Object Set WS = ThisWorkbook.Sheets("Trains") For Each objCell In WS.Range("L3:L100") oCol = objCell.Column strFName = WS.Cells(, oCol).Offset(objCell.Row - 1, 0) On Error GoTo BLANK: 'skip macro if no train Workbooks.Open Filename:=strFName 'open ongoing report Set SH = Worksheets("Trains") 'set sheet stFnd = WS.Cells(, oCol).Offset(objCell.Row - 1, 2).Value 'set connote With SH Set rFndCell = .Range("C3:C1100").Find(stFnd, LookIn:=xlValues) If Not rFndCell Is Nothing Then fCol = rFndCell.Column WS.Cells(, oCol).Offset(objCell.Row - 1, 3).Resize(1, 6).Copy SH.Cells(, fCol).Offset(rFndCell.Row - 1, 10).Resize(1, 6).PasteSpecial xlPasteValues 'paste values in ongoing report if connote found ActiveWorkbook.Save 'save ongoing report ActiveWorkbook.Close 'close ongoing report Else 'Can't find the item End If End With BLANK: Next objCell ScreenUpdating = True End Sub

Я хочу, чтобы это было – для каждой строки в L3: L100

Открыть файл, указанный в столбце «L» (если есть или пропустить строку до следующей) и перейти на лист
Значение совпадения от исходного столбца «N» до «C3: C1100» в недавно открытом листе
Копировать столбцы «O: T» и вставить относительно значения соответствия в открытом листе (M: R) и сохранить

Однако, когда я оставляю пробел в 2 строки, он дает мне ошибку для файла, который не найден, вместо того, чтобы перейти к следующему циклу, как это происходит, когда осталось только 1 строка.

Кажется, я не могу опубликовать изображения.

Также, если кто-то может указать мне в хорошем руководстве, как открыть лист в ссылке на ячейку, только если он еще не открыт, у него обычно будет только 2 файла (максимум 4 на конец квартала). Слишком много неприятностей, чтобы щелкнуть OK во всех окнах, которые появляются, когда вы пытаетесь открыть открытую книгу.

Если это поможет, опустите его вокруг. У меня есть 2 отдельных отчета для 2 клиентов (каждый раз каждый квартал, максимум 4 листа за раз), которые уже будут искать имена (2 листа в каждой книге).

Любая помощь будет принята с благодарностью

Благодаря кучам

Спасибо тем, кто выдвинул предложения и код. Я выйду завтра и не получим, что я только что придумал другую идею о том, что для повторного использования какого-то другого кода, который я имел, но не понимал, это помогло бы. Код в основном копирует то, что мне нужно, на пустую вкладку и удаляет строки с заданным значением – с некоторыми формулами для сортировки это даст мне блок строк без перерывов, идущих в один и тот же файл назначения. Таким образом, позволяя мне запускать (немного более оптимизированный, спасибо всем ) цикл над оставшимися строками.

Solutions Collecting From Web of "Макрос цикла Excel заканчивается раньше и требует, чтобы файлы открывались для копирования нескольких циклов (разных файлов)"

On Error GoTo BLANK

Workbooks.Open Filename:=strFName

Измените приведенное выше:

On Error Resume Next Workbooks.Open Filename:=strFName If Err.Number <> 0 Then Goto Blank

Что касается hpw, чтобы открыть рабочую книгу, вы можете оставить ее открытой (нет .close ), но затем, когда вы хотите ее открыть, сначала проверьте, открыта ли она (например, с помощью Workbooks("name") ), с некоторой обработкой ошибок с использованием того же как указано выше, если существует ошибка, тогда wb еще не открыт, вы его открываете.

Наконец, не учитывайте активные элементы, такие как ActiveWorkbook`. Вместо этого сделайте явную ссылку на вас wb, то есть:

Set wb = Workbooks.Open(Filename:=strFName) Set SH = wb.Worksheets("Trains")

для рассмотрения только не пустых ячеек вы можете использовать метод SpecialCells () объекта Range и опустить любые инструкции On Error GoTo , которые должны использоваться в очень немногих ограниченных случаях (один из которых мы увидим в секунду)

кроме того, вы используете некоторые бесполезно длинные «петли» для ссылки на соответствующие ячейки, например:

WS.Cells(, oCol).Offset(objCell.Row - 1, 0)

эквивалентно самому objCell !

и есть еще несколько примеров такого рода

наконец, давайте приступим к открытию / закрытию рабочих книг

ты мог:

используйте объект Dictionary для хранения имени всех открытых книг, чтобы оставить его открытым во всем вашем макросе и закрыть их все к концу
принять вспомогательную функцию, которая пытается установить желаемый лист (т. е. «Поезда») в objCell (то есть тот, чье имя является текущим значением objCell ) и возвращает False, если не удалось

все, что указано выше в этом рефакторинге вашего кода:

Sub upONGOING_Train1bis() Dim rFndCell As Range Dim SH As Worksheet Dim objCell As Range Dim shtDict As New Scripting.Dictionary '<--| this is the dictionary that will store every opened workbook name as its 'keys' Dim key As Variant ' Dim dec As String '<--| do you actually need it? Application.ScreenUpdating = False With ThisWorkbook.Sheets("Trains") '<-- reference your working worksheet ' dec = .Range("L1") '<-- what's this for? in any case take it out of for loops since its value doesn't depend on current loop variables For Each objCell In .Range("L3:L100").SpecialCells(xlCellTypeConstants) '<--| loop through L3:L100 range not blank cells only If TrySetWorksheet(objCell.Value, "Trains", SH) Then '<--|Try to set the wanted worksheet in the wanted workbook: if successful it'd retrun 'True' and leave you with 'SH' variable set to the wanted worksheet shtDict(SH.Parent.Name) = shtDict(SH.Parent.Name) + 1 Set rFndCell = SH.Range("C3:C1100").Find(objCell.Offset(, 2).Value, LookIn:=xlValues, lookAt:=xlWhole) '<--| specify at least 'LookIn' and 'LookAt' parameters If Not rFndCell Is Nothing Then rFndCell.Offset(, 10).Resize(, 6).Value = objCell.Offset(, 3).Resize(, 6).Value End If Next objCell End With For Each key In shtDict.Keys '<--|loop through opened workbooks dictionary keys Workbooks(key).Close True '<--| close workbook whose name corresponds to current dictionary key Next Application.ScreenUpdating = True End Sub Function TrySetWorksheet(fileName As String, shtname As String, sht As Worksheet) As Boolean Set sht = Nothing On Error Resume Next Set sht = Workbooks(Right(fileName, Len(fileName) - InStrRev(fileName, "\"))).Worksheets(shtname) '<--| try looking for an already open workbook with wanted name and wanted sheet If sht Is Nothing Then Set sht = Workbooks.Open(fileName:=fileName).Worksheets(shtname) '<--| if not found then try opening the wanted workbook and set the wanted sheet in it TrySetWorksheet = Not sht Is Nothing '<--| set the return value to the final result of attempts at locating the wanted sheet End Function

excel.bilee.com

Цикл макроса через все листы в книге Excel MS Excel онлайн

Вам нужно фактически перейти на каждый рабочий лист через каждый цикл. Вы в основном просто ссылаетесь на один и тот же. Ваш код должен выглядеть так:

Sub WorksheetLoop() Dim WS_Count As Integer Dim I As Integer ' Set WS_Count equal to the number of worksheets in the active ' workbook. WS_Count = ActiveWorkbook.Worksheets.Count ' Begin the loop. For I = 1 To WS_Count ' Insert your code here. Sheets(I).Select ' Added this command to loop through the sheets 'lRow = .Range("A" & .Rows.Count).End(xlUp).Row Range("P4").Select ActiveCell.FormulaR1C1 = "=RC[-10]&"" ""&RC[-5]" Range("P4").Select Selection.AutoFill Destination:=Range("P4:P65536"), Type:=xlFillDefault Range("P4:P500").Select ActiveWindow.SmallScroll Down:=-24 Selection.Copy Range("R4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Range("$R4:$R500").RemoveDuplicates Columns:=1, Header:=xlNo Selection.TextToColumns Destination:=Range("R4"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _ :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True Range("U4").Select ActiveCell.FormulaR1C1 = "=INDEX(C[-16],MATCH(RC[-3],C[-15],0))" Range("V4").Select ActiveCell.FormulaR1C1 = "=INDEX(C[-12],MATCH(RC[-3],C[-11],0))" Range("U4:V4").Select Selection.AutoFill Destination:=Range("U4:V41"), Type:=xlFillDefault Range("U4:V500").Select ' The following line shows how to reference a sheet within ' the loop by displaying the worksheet name in a dialog box. 'MsgBox ActiveWorkbook.Worksheets(I).Name Next I Exit Sub End Sub

Не проверяли действительность остальной части вашего кода, но добавленная мной команда будет циклически перемещаться по листам. С Уважением,

Вам не нужно. Выберите или .Activate ¹ лист для обработки команд на нем. Ссылка на это с помощью With … End С инструкцией и предисловией всех объектов Range и Range.Cells с периодом (например . ), Чтобы наследовать ссылку на родительский лист.

Sub WorksheetLoop() Dim lRow As Long, w As Long With ActiveWorkbook For w = 1 To .Worksheets.Count With .Worksheets(w) 'the last row should be either from column F or K lRow = .Range("K" & .Rows.Count).End(xlUp).Row .Range("P4:P" & lRow).FormulaR1C1 = "=RC[-10]&CHAR(32)&RC[-5]" '.Range("P4:P" & lRow).Formula = "=F4&CHAR(32)&K4" With .Range("R4:R" & lRow) .Value = .Range("P4:P" & lRow).Value 'direct value transfer is the preferred method for this .RemoveDuplicates Columns:=1, Header:=xlNo .TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=True, Other:=False, _ FieldInfo:=Array(Array(1, 1), Array(2, 1)) End With 'R had duplicates removed; get the new last row lRow = .Range("R" & .Rows.Count).End(xlUp).Row .Range("U4:U" & lRow).FormulaR1C1 = "=INDEX(C[-16],MATCH(RC[-3],C[-15],0))" '.Range("U4:U" & lRow).Formula = "=INDEX(E:E, MATCH(R4, F:F, 0))" .Range("V4:V" & lRow).FormulaR1C1 = "=INDEX(C[-12],MATCH(RC[-3],C[-11],0))" '.Range("V4:V" & lRow).Formula = "=INDEX(J:J, MATCH(S4, K:K, 0))" With .Range("U4:V" & lRow) 'you left your code with columns U and V selected 'maybe more processing here like: '.value = .value '<~~ remove formulas to their values End With End With Next w End With End Sub

Записанный макрокод очень подробный. Всегда полезно работать с кодом, удалять ActiveWindow.SmallScroll Down:=-24 строки кода, такие как ActiveWindow.SmallScroll Down:=-24 и делать общие улучшения там, где можете.

¹ См. Как избежать использования Select в макросах Excel VBA для получения дополнительных методов, чтобы избежать использования выбора и активации для достижения ваших целей.

Не перебирайте количество листов, прокручивайте листы.

Также избавитесь от всех этих строк activewindow.smallscroll, которые вам не нужны, и удалите выбранные. Что-то вроде этого:

Range("A1").Formula = "Hello" вместо Range("A1").Select Selection.formula = "Hello" Обратите внимание, что вы можете просто удалить Select and Selection

Вот пример того, как перемещаться по листам:

Sub WS_Stuff() Dim WS As Worksheet For Each WS In Worksheets MsgBox WS.Name Next End Sub

excel.bilee.com

Excel VBA Macro – объединение в цикл MS Excel онлайн

EDIT: добавлено отсутствующее .EntireRow на выделенной строке

Sub InsertCSV() Const BLOCK_SIZE As Long = 1000 Dim rng As Range, num Set rng = Range("A2").Resize(BLOCK_SIZE) num = Application.CountA(rng) Do While num > 0 rng.Cells(BLOCK_SIZE + 1).EntireRow.Insert With rng.Cells(BLOCK_SIZE + 1).EntireRow '<<edited .Cells(1, "H").Value = Join(Application.Transpose(rng.Value), ",") .Cells(1, "I").Value = Join(Application.Transpose(rng.Offset(0, 1).Value), ",") End With Set rng = rng.Offset(BLOCK_SIZE + 1) num = Application.CountA(rng) Loop End Sub

Я бы рекомендовал использовать оператор Mod:

Dim x For Each x In ActiveSheet.Range("A1:A" & ActiveSheet.UsedRange.Rows.Count) If x.Row Mod 1000 = 0 Then x.EntireRow.Insert End If Next x

Ознакомьтесь с оператором Mod здесь: http://msdn.microsoft.com/en-us/library/se0w9esz.aspx

или более полностью:

Dim x, y, outputText As String For Each x In ActiveSheet.Range("A1:A" & ActiveSheet.UsedRange.Rows.Count) outputText = outputText & x.Value If x.Row Mod 1000 = 0 Then x.EntireRow.Insert x.Value = outputText outputText = "" End If Next x

Ниже код должен предоставить требуемый результат, который вы ищете:

Sub pInsert1000 ()

Dim lngLoop As Long Dim lngTotal As Long Dim lngCounter As Long Dim rngRange As Range Dim strConcatACol As String Dim strConcatBCol As String Set rngRange = Cells.Find("*", Cells(1, 1), xlFormulas, xlWhole, xlByRows, xlPrevious) If Not rngRange Is Nothing Then lngTotal = rngRange.Row Else lngTotal = 0 End If lngCounter = 0 lngLoop = 1 While lngLoop < lngTotal lngCounter = lngCounter + 1 If lngCounter = 1 Then strConcatACol = Cells(lngLoop, 1) strConcatBCol = Cells(lngLoop, 2) Else strConcatACol = strConcatACol & ", " & Cells(lngLoop, 1) strConcatBCol = strConcatBCol & ", " & Cells(lngLoop, 2) End If If lngCounter = 1000 Then Rows(lngLoop + 1).EntireRow.Insert Cells(lngLoop + 1, 8) = strConcatACol Cells(lngLoop + 1, 9) = strConcatBCol lngLoop = lngLoop + 1 lngTotal = lngTotal + 1 lngCounter = 0 End If lngLoop = lngLoop + 1 Wend Set rngRange = Nothing

End Sub

excel.bilee.com

Цикл макросов в Excel MS Excel онлайн

Я хотел бы прокрутить лист Excel и сохранить значения на основе уникального идентификатора в текстовом файле.

Пожалуйста, может кто-нибудь объяснить, почему это происходит, и обеспечить способ его исправления?

Solutions Collecting From Web of "Цикл макросов в Excel"

Я не вижу места, в котором вы устанавливаете rwCounter внутри цикла.

Похоже, что он остался бы на расстоянии («B2»), и x просто продолжал бы увеличиваться, пока не достигнет ошибки, ни на пределе целого, ни на длинном.

добавьте Set rwCounter = Range("B" & x) где-нибудь внутри вашего цикла, чтобы увеличить его

Это решение.

Sub GURMAIL_File() 'sort columns for Letr_Code files Dim lr As Long Application.ScreenUpdating = False lr = Cells(Rows.Count, 1).End(xlUp).Row Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1 Application.ScreenUpdating = True 'Variables that store cell number Dim Corresponding As Integer Dim Index As Integer Dim Counter As Integer Corresponding = 2 Index = 2 Counter = 2 'Cell References Dim rwIndexValue As Range 'Variables for files that will be created Dim l_objFso As Object Dim FilePath As String Dim Total As String Dim Filename As String Dim Filetype As String Dim FolderName As String 'Variables defined FilePath = "C:\Users\Home\Desktop\SURLOAD\" 'Name of the folder to be created FolderName = Mid$(ActiveWorkbook.Name, 9, 8) & "\" 'Folder path Total = FilePath & FolderName 'File Extension Filetype = ".dat" 'Object that creates the folder Set l_objFso = CreateObject("Scripting.FileSystemObject") 'Objects for creating the text files Dim FileCreate As Object Set FileCreate = CreateObject("Scripting.FileSystemObject") 'Object for updating the file during the loop Dim FileWrite As Object 'Get Substring of letter code in order to name the file. End this loop once ID field is null. Do While Len(Range("A" & Corresponding)) > 0 'Create the directory if it does not exist If Not l_objFso.FolderExists(Total) Then l_objFso.CreateFolder (Total) End If 'Refence to cell containing a letter code Set rwIndexValue = Range("B" & Index) 'Substring of that letter code Filename = Mid$(rwIndexValue, 7, 5) 'Create the file using the substring and store it in the proper location Set FileWrite = FileCreate.CreateTextFile(Total + Filename + Filetype, True) 'For each letter code, find the corresponding values. End the loop once the last value for the letter code is stored. Do While Range("B" & Index) Like Range("B" & Counter) 'Add each line to the text file. FileWrite.WriteLine (Range("A" & Corresponding)) 'Incrementer variables that allow you to exit the loop 'if you have reached the last value of the current letter code. Corresponding = Corresponding + 1 Counter = Counter + 1 Loop 'Close the file you were writing to FileWrite.Close 'Make sure that Index value is updated to the next letter code Index = Counter 'In case Index value needs updating (safeguard to make sure that the new letter code is stored to index value). Set rwIndexValue = Range("B" & Index) Loop End Sub

excel.bilee.com

vba - Цикл макросов Excel с использованием VBS

Я хотел бы запустить макрос VBA с именем MyMacro, который сохраняется как MyMacro.bas для многих файлов excel. У меня есть код VBS ниже, но он не делает то, что я хочу. Я был бы очень признателен, если бы кто-нибудь мог взглянуть на него.

Я использую Excel 2013. Файлы сохраняются как .xls.

Спасибо.

Const sRootFolder = "C:\Documents" Const sExportedModule = "C:\Documents\MyMacro.bas" Const sMacroName = "MyMacro" Dim oFSO, oFDR, oFile ' File and Folder variables Dim oExcel, oWB ' Excel variables (Application and Workbook) Start '------------------------------ Sub Start() Initialize ProcessFilesInFolder sRootFolder Finish End Sub '------------------------------ Sub ProcessFilesInFolder(sFolder) ' Process the files in this folder For Each oFile In oFSO.GetFolder(sFolder).Files If IsExcelFile(oFile) Then ProcessExcelFile oFile.Path Next End Sub '------------------------------ Sub Initialize() Set oFSO = CreateObject("Scripting.FileSystemObject") Set oExcel = CreateObject("Excel.Application") End Sub '------------------------------ Sub Finish() oExcel.Quit Set oExcel = Nothing Set oFSO = Nothing End Sub '------------------------------ Function IsExcelFile(oFile) IsExcelFile = (InStr(1, oFSO.GetExtensionName(oFile), "xls", vbTextCompare) > 0) And (Left(oFile.Name, 1) <> "~") End Function '------------------------------ Sub ProcessExcelFile(sFileName) On Error Resume Next wscript.echo "Processing file: " & sFileName ' Comment this unless using cscript in command prompt Set oWB = oExcel.Workbooks.Open(sFileName) oWB.VBProject.VBComponents.Import sExportedModule oExcel.Run sMacroName oWB.Save oWB.Close Set oWB = Nothing End Sub '------------------------------

Вот код vbs для одного файла, который работает:

Option Explicit ExcelMacroExample Sub ExcelMacroExample() Dim xlApp Dim xlBook Dim objWorkbook Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Open("C:\Documents\test.xls", 0, True) Set objWorkbook = xlApp.Workbooks.Open("C:\Documents\test.xls") xlApp.Run "MyMacro" xlApp.Quit Set xlBook = Nothing Set xlApp = Nothing End Sub задан AK88 05 мая '17 в 6:15 источник поделиться

qaru.site