VBA Excel, как установить книгу на основе частичного имени и проверить, открыта ли рабочая книга на основе частичного имени

Question

Добрый день, Я никогда не использовал VBA раньше, поэтому мне очень нужна ваша помощь! У меня есть следующий макрос (мой первый), и он отлично работает, но после тестирования с нашими менеджерами округов этот файл («SalesOrderRMTOOL.xlsx») открывается с другим именем на своих компьютерах. Как я могу изменить свой макрос, чтобы читать только частичное имя? Это всегда будет SalesOrderRMTOOL, но после этого может быть что угодно ...... ?? Спасибо за вашу помощь, заранее

Private Sub CommandButton1_Click() 
    Dim wsSource As Worksheet 
    Dim wsTarget As Worksheet 
    Dim wsTool As Worksheet 
    Dim wBook As Workbook 
On Error Resume Next 
    Set wBook = Workbooks("SalesOrderRMTOOL.xlsx") 
    If wBook Is Nothing Then 
     MsgBox "Please open SaleOrderRMTOOL file" 
     Set wBook = Nothing 
     Exit Sub 
    End If   
    Set wsSource = Workbooks("SalesOrderRMTOOL.xlsx").Sheets("Salesorder")  
    Set wsTarget = Workbooks("RMORDERTOOL.xlsm").Sheets("Sales Order")   
    Application.ScreenUpdating = False  
    Workbooks("RMORDERTOOL.xlsm").Sheets("Tool").Range("i7:i1003").Value = "" 
    Workbooks("RMORDERTOOL.xlsm").Sheets("Tool").Range("l7:l1003").Value = "" 
    Workbooks("RMORDERTOOL.xlsm").Sheets("Tool").Range("o7:o1003").Value = "" 
    wsTarget.Cells.Clear  
    ' Copy header row to Target sheet if target is empty 
    If IsEmpty(wsTarget.Range("A1")) Then wsSource.Rows(1).Copy Destination:=wsTarget.Range("A1")  
     ' Define visible filterd cells on source worksheet and copy 
     With wsSource 
      .Range("A2", .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, .Cells(1, Columns.Count).End(xlToLeft).Column)).SpecialCells(xlCellTypeVisible).Copy 
     End With  
     ' Paste to target sheet 
     wsTarget.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False 

     Application.CutCopyMode = True 
     Application.ScreenUpdating = True 

     Workbooks("SalesOrderRMTOOL*.xlsx").Close 0 

End Sub 

Answer 1

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

Sub BrowseWorkbooks() 
Const nPerColumn As Long = 38   'number of items per column 
Const nWidth As Long = 13    'width of each letter 
Const nHeight As Long = 18    'height of each row 
Const sID As String = "___SheetGoto" 'name of dialog sheet 
Const kCaption As String = " Select Workbook" 
             'dialog caption 
Dim i As Long 
Dim TopPos As Long 
Dim iBooks As Long 
Dim cCols As Long 
Dim cLetters As Long 
Dim cMaxLetters As Long 
Dim cLeft As Long 
Dim thisDlg As DialogSheet 
Dim CurrentSheet As Worksheet 
Dim cb As OptionButton 
    Application.ScreenUpdating = False 
    If ActiveWorkbook.ProtectStructure Then 
     MsgBox "Workbook is protected.", vbCritical 
     Exit Sub 
    End If 
    On Error Resume Next 
     Application.DisplayAlerts = False 
     ActiveWorkbook.DialogSheets(sID).Delete 
     Application.DisplayAlerts = True 
    On Error GoTo 0 
    Set CurrentSheet = ActiveSheet 
    Set thisDlg = ActiveWorkbook.DialogSheets.Add 
    With thisDlg 
     .Name = sID 
     .Visible = xlSheetHidden 
     'sets variables for positioning on dialog 
     iBooks = 0 
     cCols = 0 
     cMaxLetters = 0 
     cLeft = 78 
     TopPos = 40 
     For i = 1 To Workbooks.Count 
      If i Mod nPerColumn = 1 Then 
       cCols = cCols + 1 
       TopPos = 40 
       cLeft = cLeft + (cMaxLetters * nWidth) 
       cMaxLetters = 0 
      End If 
      Set CurrentWorkbook = Workbooks(i) 
      cLetters = Len(CurrentWorkbook.Name) 
      If cLetters > cMaxLetters Then 
       cMaxLetters = cLetters 
      End If 
      iBooks = iBooks + 1 
      .OptionButtons.Add cLeft, TopPos, cLetters * nWidth, 16.5 
      .OptionButtons(iBooks).Text = _ 
       Workbooks(iBooks).Name 
      TopPos = TopPos + 13 
     Next i 
     .Buttons.Left = cLeft + (cMaxLetters * nWidth) + 24 
     CurrentWorkbook.Activate 
     With .DialogFrame 
      .Height = Application.Max(68, _ 
       Application.Min(iBooks, nPerColumn) * nHeight + 10) 
      .Width = cLeft + (cMaxLetters * nWidth) + 24 
      .Caption = kCaption 
     End With 
     .Buttons("Button 2").BringToFront 
     .Buttons("Button 3").BringToFront 
     Application.ScreenUpdating = True 
     If .Show Then 
      For Each cb In thisDlg.OptionButtons 
       If cb.Value = xlOn Then 
        'Store the name of the Woorkbook to use it later 
        SelectedWorkBookName = cb.Caption 
        Exit For 
       End If 
      Next cb 
     Else 
      MsgBox "Nothing selected" 
     End If 
     Application.DisplayAlerts = False 
     .Delete 
    End With 
End Sub 

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

Set wBook = Workbooks(SelectedWorkBookName) 

Answer 2

Я бы создал короткую функцию, чтобы вернуть книгу заказа клиента, если она существует. В верхней части модуля с функцией, я хотел бы использовать Constant (Const) провести в начале имени рабочей книги, в случае, если она когда-либо изменения:

'Constant at top of module  
Const WORKBOOK_NAME As String = "SalesOrderRMTOOL" 

'Anywhere else in same module  
Function GetSalesOrderWb() As Excel.Workbook 
Dim wb As Excel.Workbook 

For Each wb In Application.Workbooks 
    If Left(wb.Name, Len(WORKBOOK_NAME)) = WORKBOOK_NAME Then 
     Set GetSalesOrderWb = wb 
     Exit Function 
    End If 
Next 
End Function 

Затем вызовите его следующим образом:

Set wBook = GetSalesOrderWb 
If wBook Is Nothing Then 
    MsgBox "Please open SaleOrderRMTOOL file" 
    Exit Sub 
End If