Используйте функцию соответствия, чтобы найти текст для использования в качестве имени файла - PullRequest
Новая
       2

Используйте функцию соответствия, чтобы найти текст для использования в качестве имени файла

0 голосов
/ 27 августа 2018

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

Sub SaveAs()

    Dim FName           As String
    Dim FPath           As String
    Dim NewBook         As Workbook

    FPath = "\\G:\Exceptions"
    FName = (Application.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0, 2)) & ".xls"

    If Dir(FPath & "\" & FName) <> "" Then
        MsgBox "File " & FPath & "\" & FName & " already exists"
    Else
        ThisWorkbook.SaveAs filename:=FPath & "\" & FName
    End If

End Sub

Можно ли это сделать, или мне лучше найти другой способ сделать это?

Ответы [ 2 ]

0 голосов
/ 27 августа 2018

После ответа Скотта:

Первая ошибка связана с вашим соответствием. 

Application.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0, 2))

должно стать 

Application.Worksheetfunction.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0)

Кроме того, Match возвращает только long, поэтому вам нужно добавить Cells(), чтобы найти нужное имя

Cells(Application.Worksheetfunction.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0),2).value

дает вам имя, которое вам нужно

Теперь, если вы добавите случай, когда совпадение не найдено, вы получите следующий код: 

Sub SaveAs()

    Dim FName           As String
    Dim FPath           As String
    Dim NewBook         As Workbook
    Dim Mtch            As Long

    FPath = "\\G:\Exceptions"
    Mtch = Application.WorksheetFunction.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0)
    FName = Cells(Application.WorksheetFunction.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0), 2) & ".xls"
    MsgBox FName

    If Not IsError(Mtch) Then
        If Dir(FPath & "\" & Worksheets("Sheet 1").Cells(Mtch, 1).Value) <> "" Then
            MsgBox "File " & FPath & "\" & FName & " already exists"
        Else
            ThisWorkbook.SaveAs Filename:=FPath & "\" & FName
        End If
    Else
        MsgBox "the value not found in the column"
    End If

End Sub

В качестве альтернативы вы также можете найти строку следующим образом: 

Mtch = Findval("TEST", Range("A1:A42"))

MsgBox Mtch
FName = Cells(Application.WorksheetFunction.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0), 2) & ".xls"
MsgBox FName


If Not IsError(Mtch) Then
    If Dir(FPath & "\" & Worksheets("Sheet 1").Cells(Mtch, 1).Value) <> "" Then
        MsgBox "File " & FPath & "\" & FName & " already exists"
    Else
        ThisWorkbook.SaveAs Filename:=FPath & "\" & FName
    End If
Else
    MsgBox "the value not found in the column"
End If

End Sub


Function Findval(VALUESEARCHED As String, ra As Range) As Variant

Dim A As Range

    Set A = ra.Find(What:=VALUESEARCHED, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

Findval = A.Row

End Function
0 голосов
/ 27 августа 2018

Match возвращает Long, относительное местоположение в одномерном диапазоне. Вам нужно будет использовать этот номер с чем-то другим, например, Cells(), чтобы вернуть действительное имя. 

Sub SaveAs()

    Dim Mtch as Long
    Dim FPath           As String
    Dim NewBook         As Workbook

    FPath = "\\G:\Exceptions"
    Mtch = (Application.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0)) & ".xls"

    If Dir(FPath & "\" & Worksheets("Sheet 1").Cells(Mtch,2).Value) <> "" Then
        MsgBox "File " & FPath & "\" & FName & " already exists"
    Else
        ThisWorkbook.SaveAs filename:=FPath & "\" & FName
    End If

End Sub

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

Sub SaveAs()

    Dim Mtch as Variant
    Dim FPath           As String
    Dim NewBook         As Workbook

    FPath = "\\G:\Exceptions"
    Mtch = (Application.Match("Test", Worksheets("Sheet 1").Range("A1:A42"), 0)) & ".xls"
    If not iserror(mtch) then
        If Dir(FPath & "\" & Worksheets("Sheet 1").Cells(Mtch,2).Value) <> "" Then
            MsgBox "File " & FPath & "\" & FName & " already exists"
        Else
            ThisWorkbook.SaveAs filename:=FPath & "\" & FName
        End If
    Else
        msgbox "the value not found in the column
    End if

End Sub
...