Блог

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

Вот первая часть проекта, в которой мне нужна новая рабочая книга, чтобы извлекать извлеченные отчеты Excel из папки, копировать определенный рабочий лист (через окно ввода сообщения), изменять имя рабочего листа, чтобы отразить отчет приложения, и вставлять его в новую рабочую книгу.

Поскольку эта рабочая тетрадь с макросами будет доступна другим моим коллегам, я бы хотел, чтобы в ней было поле «выбрать каталог пути», чтобы они могли выбрать каталог пути.

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

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

 Sub CopySheets()

    Dim path As String
    Dim FileName As String
    Dim whichSheet As String

    path = "/Users/timothy.wong/Downloads/Project Clean Up/2019/"
    FileName = Dir(path amp; "*.xlsx")
    whichSheet = InputBox("Which month would you like to copy? Enter month (eg. Jan, Feb, Mar)")

    Do While FileName <> ""
        Workbooks.Open FileName:=path amp; FileName, ReadOnly:=True
        Sheets(whichSheet).Select
        ActiveWorkbook.ActiveSheet.Copy after:=ThisWorkbook.Sheets(1)
        Workbooks(FileName).Close
        ActiveSheet.Name = Left(FileName, Application.WorksheetFunction.Search(" ", FileName) - 1)
        FileName = Dir()

    Loop

End Sub
  

Базовый код работает хорошо, мне нужно сделать его немного более продвинутым.

Вы можете попробовать это:

 Option Explicit
Sub CopySheets()

    Dim path As String
    Dim FileName As String
    Dim whichSheet As String
    Dim SheetNames As String
    Dim wb As Workbook

    path = GetFolder
    If path = vbNullString Then
        MsgBox "No folder was selected. Ending the procedure."
        End
    End If
    FileName = Dir(path amp; "*.xlsx")
    whichSheet = InputBox("Which month would you like to copy? Enter month (eg. Jan, Feb, Mar)")

    Do While FileName <> ""
        Set wb = Workbooks.Open(FileName:=path amp; FileName, ReadOnly:=True)
        On Error Resume Next
        If Len(wb.Sheets(whichSheet).Name) = 0 Then 'Here we handle an error on the inputname for the sheet.
        On Error GoTo 0
            SheetNames = GetSheetNames(wb)
            MsgBox "The input sheet does not exist in this workbook. The current worksheet names are: " amp; SheetNames
            whichSheet = InputBox("Which month would you like to copy? Enter month (eg. Jan, Feb, Mar)")
        End If
        With wb.Sheets(whichSheet)
            .Copy after:=ThisWorkbook.Sheets(1)
            .Close
        End With
        ThisWorkbook.Sheets(2).Name = Left(FileName, Application.WorksheetFunction.Search(" ", FileName) - 1)
        FileName = Dir()
    Loop

End Sub
Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Selecciona una carpeta"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing

End Function
Function GetSheetNames(wb As Workbook) As String

    Dim ws As Worksheet

    For Each ws In wb.Worksheets
        GetSheetNames = GetSheetNames amp; ", " amp; ws.Name
    Next ws

End Function