Макрос Excel для автоматической генерации данных и сохранения файла - PullRequest
Новая
       41

Макрос Excel для автоматической генерации данных и сохранения файла

0 голосов
/ 28 сентября 2018

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

Теперь мне нужно, чтобы макрос делал то же самое для всего списка вконкретная папка.Я имею в виду, что он должен автоматически генерировать данные и сохранять файл в соответствии с упомянутым соглашением об именах для всех кодов.

Может кто-нибудь мне помочь? 

Sub BringData()

Sheets("FBL Data").Select
    Rows("3:3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A3").Select


    Dim fNameAndPath$
    Dim wsData As Worksheet, wsMacro As Worksheet
    Dim wbMacro As Workbook

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set wsMacro = ThisWorkbook.Sheets("FBL Data")

    MsgBox "File should be in name Blue Print Data Dump.xlsm"
    fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSM), *.XLSM", Title:="Select File To Be Opened")
    If Len(fNameAndPath) = 0 Then Exit Sub
    Set wbMacro = Workbooks.Open(fNameAndPath)
    Set wsData = wbMacro.Sheets("Data")

    With wsMacro
        .Range("BA1") = .Range("F2"): .Range("BA2") = .Range("A1")
        wsData.Range("A1").CurrentRegion.AdvancedFilter 2, _
            .Range("BA1:BA2"), .Range("A2", .Range("A2").End(xlToRight))
        .Range("BA1:BA2").ClearContents
    End With

    wbMacro.Close False

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True


Sheets("Summary").Select
ThisFile = Range("E1").Value
Filename = Range("F1").Value

ActiveWorkbook.SaveAs Filename:=ThisFile
'Open and close the files
currentfile = Range("E1").Value & ".xlsm"
MsgBox ("Macro has been completed for " & Filename)

End Sub
...