#excel #vba
#превосходить #vba
Вопрос:
Я сталкиваюсь с проблемой, когда мой макрос, который работает для одной книги Excel, должен работать для всех книг в папке. Макрос выполняет несколько действий: 1) открывает и сохраняет все листы в книге в определенном месте 2) Извлекает заголовок из графика в T99, если график существует 3) удаляет все строки до того, как какой-либо столбец содержит ключевые слова («данные»). Это работает очень хорошо, но у меня есть 100 книг, на которых я хочу запустить этот макрос.
Вот оригинальный макрос:
Sub b2() Dim wbThis As Workbook Dim wbNew As Workbook Dim ws As Worksheet Dim strFilename As String Dim fRg As Range Set wbThis = ThisWorkbook For Each ws In wbThis.Worksheets strFilename = wbThis.Path amp; "/singlesheets/" amp; ws.Name ws.Copy Set wbNew = ActiveWorkbook On Error Resume Next Sheets(1).ChartObjects(1).Activate If Err.Number lt;gt; 0 Then Else Worksheets(1).Range("T99").Value = Worksheets(1).ChartObjects("Chart 1").Chart.ChartTitle.Text End If Set fRg = Cells.Find(What:="datum", LookAt:=xlWhole) If Not fRg Is Nothing Then If fRg.Row lt;gt; 1 Then Range("A1", fRg.Offset(-1)).EntireRow.Delete Else End If Else End If wbNew.SaveAs strFilename wbNew.Close Next ws End Sub а вот мой нефункционирующий модуль, который неоднократно выполняет вышеуказанный макрос в одной и той же книге, но не переходит к следующей книге в папке:
Sub LoopThroughFiles() Dim xFd As FileDialog Dim xFdItem As Variant Dim xFileName As String Set xFd = Application.FileDialog(msoFileDialogFolderPicker) If xFd.Show = -1 Then xFdItem = xFd.SelectedItems(1) amp; Application.PathSeparator xFileName = Dir(xFdItem amp; "*.xls*") Do While xFileName lt;gt; "" With Workbooks.Open(xFdItem amp; xFileName) 'your code here Dim wbThis As Workbook Dim wbNew As Workbook Dim ws As Worksheet Dim strFilename As String Dim fRg As Range Set wbThis = ThisWorkbook For Each ws In wbThis.Worksheets strFilename = wbThis.Path amp; "/singlesheets/" amp; ws.Name ws.Copy Set wbNew = ActiveWorkbook On Error Resume Next Sheets(1).ChartObjects(1).Activate If Err.Number lt;gt; 0 Then Else Worksheets(1).Range("T99").Value = Worksheets(1).ChartObjects("Chart 1").Chart.ChartTitle.Text End If Set fRg = Cells.Find(What:="datum", LookAt:=xlWhole) If Not fRg Is Nothing Then If fRg.Row lt;gt; 1 Then Range("A1", fRg.Offset(-1)).EntireRow.Delete Else End If Else End If wbNew.SaveAs strFilename wbNew.Close Next ws End With xFileName = Dir Loop End If End Sub Комментарии:
1. Я бы предложил избавиться от этого
On Error Resume Nextили вернуться кOn Error GoTo 0нему сразу же послеIf ErrorобработкиChart 1. Это, по крайней мере, даст шанс понять, что происходит не так.2. Вам нужно подумать, куда вы хотите поместить отдельные листы, т. Е. вам нужно решить, как определить имя папки для отдельных листов каждой книги, поскольку могут быть листы с одинаковым именем, которые будут перезаписаны, если вы поместите их все в одну папку. Например, если есть рабочая книга
Test1.xlsmSheet1и есть рабочая книгаTest2.xlsm, сSheet1которой вы, например, можете поместить их в подпапкуTest1какSheet1.xlsxи в подпапкуTest2какSheet1.xlsxсоответственно. Это рабочая книга.xlsm, но какое расширение имеют другие рабочие книги?3. Было бы лучше иметь по крайней мере две процедуры: одна будет похожа на то, что вы написали, с некоторыми изменениями, а другая будет чем-то вроде кода, в который вы вставили свое решение. Затем вы запустите второй код, который вызовет первый код. Пожалуйста, проясните проблемы с папками и расширениями файлов, рассмотренные в моих предыдущих комментариях, лучше всего, отредактировав свой вопрос.
Ответ №1:
Как отмечалось в комментариях, управлять кодом проще, если вы создаете методы, которые не делают слишком много вещей…
Sub ProcessFolder() Dim xFd As FileDialog, xFdItem As Variant, xFileName As String Dim wb As Workbook Set xFd = Application.FileDialog(msoFileDialogFolderPicker) xFd.AllowMultiSelect = False If xFd.Show lt;gt; -1 Then Exit Sub xFdItem = xFd.SelectedItems(1) amp; Application.PathSeparator xFileName = Dir(xFdItem amp; "*.xls*") Do While xFileName lt;gt; "" Set wb = Workbooks.Open(xFdItem amp; xFileName) ProcessWorkbook wb 'export all sheets wb.Close False xFileName = Dir() 'next file Loop End Sub Sub ProcessWorkbook(wb As Workbook) Dim ws As Worksheet, fRg As Range Dim wsNew As Worksheet For Each ws In wb.Worksheets ws.Copy Set wsNew = ActiveWorkbook.Worksheets(1) 'get the copied sheet On Error Resume Next 'ignore any chart/chart title error wsNew.Range("T99").Value = wsNew.ChartObjects(1).Chart.ChartTitle.Text On Error GoTo 0 Set fRg = wsNew.Cells.Find(What:="datum", LookAt:=xlWhole) If Not fRg Is Nothing Then If fRg.Row gt; 1 Then wsNew.Range("A1", fRg.Offset(-1)).EntireRow.Delete End If 'save and close the sheet copy wsNew.Parent.SaveAs wb.Path amp; "/singlesheets/" amp; ws.Name ' amp; ".xlsx" ? wsNew.Parent.Close False Next ws End Sub Комментарии:
1. Спасибо за это — немного поздновато, чтобы ответить и выразить свое уважение!