Запуск такого же макроса excel в нескольких файлах excel

Ответ 1

Предполагая, что вы помещаете файлы в каталог "Файлы" относительно вашей основной книги, ваш код может выглядеть так:

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\Files\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        DoWork wb
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub

Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

В этом примере DoWork() - это ваш макрос, который применяется ко всем вашим файлам. Убедитесь, что вы выполняете всю свою обработку в своем макросе всегда в контексте wb (в настоящее время открытая книга).

Отказ от ответственности: вся возможная обработка ошибок пропущена для краткости.

Ответ 2

Возможно, часть вопроса может быть, как я могу запустить это на 1000 файлов?... Нужно ли добавлять этот макрос во все 1000 книг?

Один из способов сделать это - добавить макрос централизованно в файл PERSONAL.XLSB (иногда расширение может быть другим). Этот файл будет загружен в фоновом режиме при каждом запуске Excel и сделает ваш макрос доступным в любое время.

Изначально файл PERSONAL.XLSB НЕ будет. Чтобы автоматически создать этот файл, просто запустите запись макроса "dummy" (с кнопкой записи в левой нижней части таблицы) и выберите "Личная книга макросов", чтобы сохранить его.

После записи вашего макроса вы можете открыть редактор VBA с помощью Alt + F11, и вы увидите файл PERSONAL.XLSB с макросом "dummy".

Я использую этот файл для хранения загрузок общего макроса, которые всегда доступны, независимо от того, какой файл .xlsx у меня открыт. Я добавил эти макросы в свою ленту меню.

Одним из недостатков этого общего файла макросов является то, что при запуске более одного экземпляра Excel вы получите сообщение об ошибке, что файл PERSONAL.XLSB уже используется экземпляром Excel Nr. 1. Это не проблема, если вы не добавляете новый макрос в данный момент.

Ответ 3

Большое спасибо за это

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "C:\Users\jkatanan\Desktop\20170206Glidepath\V37\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        BSAQmacro wb

        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub
Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

Ответ 4

Вместо передачи значений в DoWork можно также выполнить задания в Processfiles().

Sub ProcessFiles()

    Dim Filename, Pathname As String
    Dim wb1 As Workbook
    Dim wb2 As Workbook

    Dim Sheet As Worksheet
    Dim PasteStart As Range
    Dim Counter As Integer

    Set wb1 = ActiveWorkbook
    Set PasteStart = [RRimport!A1]

    Pathname = ActiveWorkbook.Path & "\For Macro to run\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb2 = Workbooks.Open(Pathname & Filename)
        For Each Sheet In wb2.Sheets
                With Sheet.UsedRange
                .Copy PasteStart
                Set PasteStart = PasteStart.Offset(.Rows.Count)
            End With
        Next Sheet
        wb2.Close
        Filename = Dir()
    Loop
End Sub

Ответ 5

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\C:\Users\20098323\Desktop\EXCL\"
    Filename = Dir(Pathname & "*.xlsx")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        DoWork wb
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub

Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

При запуске этого кода отображается неправильное имя или номер файла. Я сохранил весь свой файл в папке EXCL

Ответ 6

Спасибо Peterm!!

Собственно, я сделал свой макрос, используя точно такой же код, который вы разместили (process_fiels и dowork).

Он работал блестяще!! (до моего вопроса)

Каждая из моих 1000 книг имеет 84 листа. Мой собственный макрос (который, наконец, работает!) Разбивает каждую книгу на 85 разных файлов (исходная + короткая версия каждого листа сохраняется как отдельный файл).

Это оставляет мне 1000 файлов + 1000х85 в одной папке, и это было бы очень сложно разобраться.

Мне действительно нужно, чтобы Process_Files взял первый файл, создайте папку с именем первого файла, перенесите первый файл в папку с именем ist, затем запустите мой макрос (в папке с именем после первого файл во вновь созданной папке...), вернитесь назад и возьмите второй файл, создайте папку с именем второго файла, переместите второй файл в папку с именем ist, затем запустите мой макрос (в папке с именем после второго файла во вновь созданной папке...) и т.д.

В конце я должен был переместить все файлы в папки с тем же именем, что и файлы, а содержимое исходной папки\Files\было бы 1000 папок с именем исходных файлов, содержащих исходные файлы + 84 файла, которые уже выполняется моим собственным макросом.

Возможно, с кодом проще:

Sub ProcessFiles()   Dim Filename, Pathname As String   Dim wb В качестве рабочей книги

Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""

(Здесь он должен прочитать имя файла, создать папку с именем файла, переместить файл в эту вновь созданную папку)

    Set wb = Workbooks.Open(Pathname & Filename)  <- open file, just as is.
    DoWork wb   <- do my macro,just as is
    wb.Close SaveChanges:=False      <- not save, to keep the original file

(вернитесь к исходной папке \Files \)

    Filename = Dir()   <-   Next file, just as is
Loop

Конец Sub

Sub DoWork (wb As Workbook)   С wb               MyMacro   Конец с End Sub

Большое спасибо, этот сайт замечательный!

__________________ edit, теперь макрос работает _________________________

Как вы можете видеть, я не эксперт VBA, но макрос, наконец, работает. Код не совсем чистый, я не программист на ПО.

Вот он, это может помочь кому-то однажды.

Sub ProcessFiles_All()    Dim Filename, Pathname, NewPath, FileSource, FileDestination As String    Dim wb В качестве рабочей книги

    Pathname = ActiveWorkbook.Path & "\Files\"
    Filename = Dir(Pathname & "*.csv")

 Do While Filename <> ""

     NewPath = Pathname & Left(Filename, 34) & "\"

 On Error Resume Next
     MkDir (NewPath)
 On Error GoTo 0

 Set wb = Workbooks.Open(Pathname & Filename)

    DoWorkPlease wb   '  <------------   It is important to say please!!

Вкл.       wb.Close SaveChanges: = False если Err.Number < > 0, то   Здесь нужен обработчик ошибок End if

    Filename = Dir()

 Loop

Конец Sub

Sub DoWorkPlease (wb As Workbook)    С помощью wb

'Поскольку мое приложение имеет более 1800 ячеек для каждого столбца, и это занимает много времени "Я использую" режим тестирования ", если бы я играл только с 18 значениями.

 Dim TestingMode As Integer
 Dim ThisRange(1 To 4) As Variant

 TestingMode = 0

If TestingMode = 1 Then
   ThisRange(1) = "B2:CG18"
   ThisRange(2) = "CT2:CT18"
   ThisRange(3) = "CH2:CN18"
   ThisRange(4) = "CN2:CS18"
   Rows("19:18201").Select
   Selection.Delete Shift:=xlUp
End If

If TestingMode = 0 Then
   ThisRange(1) = "B2:CG18201"
   ThisRange(2) = "CT2:CT18201"
   ThisRange(3) = "CH2:CN18201"
   ThisRange(4) = "CN2:CS18201"
End If

'ускорить макрос, отключить обновление и оповещения
        Приложение .ScreenUpdating = False         Application.DisplayAlerts = False

'Вот мой код, который управляет значениями ячеек из цифр (значения, считанные датчиками, должны быть "переведены" в реальные значения. Кодекс здесь не на самом деле.

'Затем я копирую все это в просто цифры, больше нет формул, проще работать таким образом.

'_____________________________________  "Получить только значения - больше формул

 Sheets.Add After:=Sheets(Sheets.Count)
 Sheets("Sheet1").Select
 Columns("A:CT").Select
 Selection.Copy
 Sheets("Sheet2").Select
 Columns("A:A").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
     :=False, Transpose:=False
 Application.CutCopyMode = False
 Selection.NumberFormat = "0"
 With Selection
     .HorizontalAlignment = xlCenter
     .VerticalAlignment = xlBottom
     .WrapText = False
     .Orientation = 0
     .AddIndent = False
     .IndentLevel = 0
     .ShrinkToFit = False
     .ReadingOrder = xlContext
     .MergeCells = False
 End With

'Затем я сохраняю эту новую книгу в папку со своим именем (и под папкой \FILES\

'_____________________________________  'Сохраните работу под своей собственной папкой

Dim CleanName, CleanPath, CleanNewName как вариант   CleanPath = ActiveWorkbook.Path   CleanName = ActiveWorkbook.Name   CleanName = Left (CleanName, 34) 'Я вынимаю расширение   CleanPath = CleanPath + "\" + CleanName   CleanNewName = CleanPath + "\" + CleanName   CleanNewName = CleanNewName + "_clean.csv", и теперь я добавляю "чистый", чтобы иметь другое имя.

Вкл.   ActiveWorkbook.SaveAs Имя файла: = CleanNewName, FileFormat: = xlCSV, CreateBackup: = False

'Если есть ошибка, я создаю пустую папку с именем файла, чтобы узнать, какой файл нуждается в доработке.

If Err.Number <> 0 Then
    MkDir (CleanPath + "_error_" + CleanName)
End If    

'Продолжить дальше

ActiveSheet.Move _  После: = ActiveWorkbook.Sheets(1)

'Затем я разбил книгу на отдельные файлы с данными, которые мне нужны для отдельных датчиков.

'Вот отдельные диапазоны, которые мне нужны для каждого файла. Поскольку у меня более 1000 файлов, это стоит усилий.

'_______________ Сплит!! ______________________________

Dim Col (от 1 до 98) как вариант   Col (1) = "A: A, B: B, CH: CH, CN: CN, CT: CT"   Col (2) = "A: A, C: C, CH: CH, CN: CN, CT: CT"   Col (3) = "A: A, D: D, CH: CH, CN: CN, CT: CT"   Col (4) = "A: A, E: E, CH: CH, CN: CN, CT: CT"   Col (5) = "A: A, F: F, CH: CH, CN: CN, CT: CT"   Col (6) = "A: A, G: G, CH: CH, CN: CN, CT: CT"   Col (7) = "A: A, H: H, CH: CH, CN: CN, CT: CT"   Col (8) = "A: A, I: I, CH: CH, CN: CN, CT: CT"   Col (9) = "A: A, J: J, CH: CH, CN: CN, CT: CT"   Col (10) = "A: A, K: K, CH: CH, CN: CN, CT: CT"   Col (11) = "A: A, L: L, CH: CH, CN: CN, CT: CT"   Col (12) = "A: A, M: M, CH: CH, CN: CN, CT: CT"   Col (13) = "A: A, N: N, CH: CH, CN: CN, CT: CT"   Col (14) = "A: A, O: O, CH: CH, CN: CN, CT: CT"   Col (15) = "A: A, P: P, CI: CI, CO: CO, CT: CT"   Col (16) = "A: A, Q: Q, CI: CI, CO: CO, CT: CT"   Col (17) = "A: A, R: R, CI: CI, CO: CO, CT: CT"   Col (18) = "A: A, S: S, CI: CI, CO: CO, CT: CT"   Col (19) = "A: A, T: T, CI: CI, CO: CO, CT: CT"   Col (20) = "A: A, U: U, CI: CI, CO: CO, CT: CT"   Col (21) = "A: A, V: V, CI: CI, CO: CO, CT: CT"   Col (22) = "A: A, W: W, CI: CI, CO: CO, CT: CT"   Col (23) = "A: A, X: X, CI: CI, CO: CO, CT: CT"   Col (24) = "A: A, Y: Y, CI: CI, CO: CO, CT: CT"   Col (25) = "A: A, Z: Z, CI: CI, CO: CO, CT: CT"   Col (26) = "A: A, AA: AA, CI: CI, CO: CO, CT: CT"   Col (27) = "A: A, AB: AB, CI: CI, CO: CO, CT: CT"   Col (28) = "A: A, AC: AC, CI: CI, CO: CO, CT: CT"   Col (29) = "A: A, AD: AD, CJ: CJ, CP: CP, CT: CT"   Col (30) = "A: A, AE: AE, CJ: CJ, CP: CP, CT: CT"   Col (31) = "A: A, AF: AF, CJ: CJ, CP: CP, CT: CT"   Col (32) = "A: A, AG: AG, CJ: CJ, CP: CP, CT: CT"   Col (33) = "A: A, AH: AH, CJ: CJ, CP: CP, CT: CT"   Col (34) = "A: A, AI: AI, CJ: CJ, CP: CP, CT: CT"   Col (35) = "A: A, AJ: AJ, CJ: CJ, CP: CP, CT: CT"   Col (36) = "A: A, AK: AK, CJ: CJ, CP: CP, CT: CT"   Col (37) = "A: A, AL: AL, CJ: CJ, CP: CP, CT: CT"   Col (38) = "A: A, AM: AM, CJ: CJ, CP: CP, CT: CT"   Col (39) = "A: A, AN: AN, CJ: CJ, CP: CP, CT: CT"   Col (40) = "A: A, AO: AO, CJ: CJ, CP: CP, CT: CT"   Col (41) = "A: A, AP: AP, CJ: CJ, CP: CP, CT: CT"   Col (42) = "A: A, AQ: AQ, CJ: CJ, CP: CP, CT: CT"   Col (43) = "A: A, AR: AR, CK: CK, CQ: CQ, CT: CT"   Col (44) = "A: A, AS: AS, CK: CK, CQ: CQ, CT: CT"   Col (45) = "A: A, AT: AT, CK: CK, CQ: CQ, CT: CT"   Col (46) = "A: A, AU: AU, CK: CK, CQ: CQ, CT: CT"   Col (47) = "A: A, AV: AV, CK: CK, CQ: CQ, CT: CT"   Col (48) = "A: A, AW: AW, CK: CK, CQ: CQ, CT: CT"   Col (49) = "A: A, AX: AX, CK: CK, CQ: CQ, CT: CT"   Col (50) = "A: A, AY: AY, CK: CK, CQ: CQ, CT: CT"   Col (51) = "A: A, AZ: AZ, CK: CK, CQ: CQ, CT: CT"   Col (52) = "A: A, BA: BA, CK: CK, CQ: CQ, CT: CT"   Col (53) = "A: A, BB: BB, CK: CK, CQ: CQ, CT: CT"   Col (54) = "A: A, BC: BC, CK: CK, CQ: CQ, CT: CT"   Col (55) = "A: A, BD: BD, CK: CK, CQ: CQ, CT: CT"   Col (56) = "A: A, BE: BE, CK: CK, CQ: CQ, CT: CT"   Col (57) = "A: A, BF: BF, CL: CL, CR: CR, CT: CT"   Col (58) = "A: A, BG: BG, CL: CL, CR: CR, CT: CT"   Col (59) = "A: A, BH: BH, CL: CL, CR: CR, CT: CT"   Col (60) = "A: A, BI: BI, CL: CL, CR: CR, CT: CT"   Col (61) = "A: A, BJ: BJ, CL: CL, CR: CR, CT: CT"   Col (62) = "A: A, BK: BK, CL: CL, CR: CR, CT: CT"   Col (63) = "A: A, BL: BL, CL: CL, CR: CR, CT: CT"   Col (64) = "A: A, BM: BM, CL: CL, CR: CR, CT: CT"   Col (65) = "A: A, BN: BN, CL: CL, CR: CR, CT: CT"   Col (66) = "A: A, BO: BO, CL: CL, CR: CR, CT: CT"   Col (67) = "A: A, BP: BP, CL: CL, CR: CR, CT: CT"   Col (68) = "A: A, BQ: BQ, CL: CL, CR: CR, CT: CT"   Col (69) = "A: A, BR: BR, CL: CL, CR: CR, CT: CT"   Col (70) = "A: A, BS: BS, CL: CL, CR: CR, CT: CT"   Col (71) = "A: A, BT: BT, CM: CM, CS: CS, CT: CT"   Col (72) = "A: A, BU: BU, CM: CM, CS: CS, CT: CT"   Col (73) = "A: A, BV: BV, CM: CM, CS: CS, CT: CT"   Col (74) = "A: A, BW: BW, CM: CM, CS: CS, CT: CT"   Col (75) = "A: A, BX: BX, CM: CM, CS: CS, CT: CT"   Col (76) = "A: A, BY: BY, CM: CM, CS: CS, CT: CT"   Col (77) = "A: A, BZ: BZ, CM: CM, CS: CS, CT: CT"   Col (78) = "A: A, CA: CA, CM: CM, CS: CS, CT: CT"   Col (79) = "A: A, CB: CB, CM: CM, CS: CS, CT: CT"   Col (80) = "A: A, CC: CC, CM: CM, CS: CS, CT: CT"   Col (81) = "A: A, CD: CD, CM: CM, CS: CS, CT: CT"   Col (82) = "A: A, CE: CE, CM: CM, CS: CS, CT: CT"   Col (83) = "A: A, CF: CF, CM: CM, CS: CS, CT: CT"   Col (84) = "A: A, CG: CG, CM: CM, CS: CS, CT: CT" "Я хочу разбить 84 новых файла, поэтому для тестирования я использую только 1, и для реальной вещи я иду с 84

Dim CounterMode As Integer

Если TestingMode = 1, тогда CounterMode = 1 Else CounterMode = 84

For i = 1 To CounterMode

'этот код требует необходимости в столбцах и вставляет его в новую книгу.

 Sheets("Sheet1").Select
 Cells.Select
 Selection.ClearContents
 Range("A1").Activate
 Sheets(2).Select
 Range(Col(i)).Select
 Selection.Copy
 Sheets("Sheet1").Select
 ActiveSheet.Paste
 Application.CutCopyMode = False
 With Selection
     .HorizontalAlignment = xlCenter
     .VerticalAlignment = xlBottom
     .WrapText = False
     .Orientation = 0
     .AddIndent = False
     .IndentLevel = 0
     .ShrinkToFit = False
     .ReadingOrder = xlContext
     .MergeCells = False
 End With
 Columns("A:E").EntireColumn.AutoFit

'Сохранить отдельный файл

'_____________save the work________________

Dim ThePath, TheName, TheSwitch As String   ThePath = ActiveWorkbook.Path + "\"   TheName = Left (ActiveWorkbook.Name, 34) 'выведет расширение из имени   ThePath = ThePath + TheName   TheSwitch = Cells (3, 2) 'In Cell (3,2) У меня есть имя индивидуального имени, поэтому я добавил имя файла.   TheName = ThePath + "_" + TheSwitch + ".xls"

Range("A1").Select
Sheets("Sheet1").Select
Sheets("Sheet1").Copy

Dim SheetName As Variant

'Я называю листы (1) как Sheet1, так как исходный лист имеет имя и дату теста. "Я делаю это, чтобы иметь одно имя во всех файлах, чтобы сделать сюжет, тогда я переименую лист с помощью 'Оригинальное имя

SheetName = ActiveSheet.Name   ActiveWorkbook.Sheets(1).Name = "Sheet1"

'вот сюжет

Columns("A:E").EntireColumn.AutoFit
Columns("B:E").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("'Sheet1'!$B:$E")
ActiveChart.ChartType = xlXYScatterLinesNoMarkers

ActiveWorkbook.Sheets(1).Name = SheetName

"сохранить   Вкл.   ActiveWorkbook.SaveAs Имя файла: = TheName, FileFormat: = 56, CreateBackup: = False

If Err.Number <> 0 Then
    MkDir (ThePath + "_error_" + TheName)
End If

ActiveWorkbook.Close

Далее i  '____________________Это было Сплит __________________________________   "Включить экран:    Application.ScreenUpdating = True    Application.DisplayAlerts = True    Range (" A1"). Select

 End With

Конец Sub