虽然这是常见错误,但我试图找到相关主题,但未能学会修复我的代码。当我们从他们那里收到更新时,我试图为特定供应商复制Excel表格的某些单元格,以避免手动复制。
我看到了这个错误Set Source = Workbooks(strFileName).Worksheets("Demand Request Details")
步骤。请帮忙。
Sub MergeInflight01()
Dim j As Long
Dim i As Long
Dim Ret
Dim wbk As Workbook
Dim numofrows As Long
Dim strFileName As String
Dim strVendorName As String
Dim Source As Worksheet, Destination As Worksheet
Dim arrA(1 To 15, 1 To 2) As Variant
Sheets("Demand Request Details").Select
strFileName = InputBox("Please Enter the source file with Path to take data from")
strVendorName = InputBox("Please Enter the Vendor name from XYZ")
If FileInUse(strFileName) Then
' Open the work-book if not opened already
Set wkbSource = Workbooks.Open(strFileName)
End If
'ERROR HERE
Set Source = Workbooks(strFileName).Worksheets("Demand Request Details")
numofrows = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row + 5
strFileName = InputBox("Please Enter the Destination file with Path to take data from")
If FileInUse(strFileName) Then
' Open the work-book if not opened already
Set wkbSource = Workbooks.Open(strFileName)
End If
Set Destination = Workbooks(strFileName).Worksheets("Demand Request Details")
For i = 1 To numofrows
If (Source.Cells(i, 22).Value = "DELIVERY") And (Source.Cells(i, 14).Value = strVendorName) Then
For j = 1 To numofrows
If (Source.Cells(i, 1).Value = Destination.Cells(j, 1).Value) And (Source.Cells(i, 6).Value = Destination.Cells(j, 6).Value) Then
Source.Cells(i, 20).Value = Destination.Cells(j, 20).Value
Source.Cells(i, 38).Value = Destination.Cells(j, 38).Value
Source.Cells(i, 39).Value = Destination.Cells(j, 39).Value
Source.Cells(i, 40).Value = Destination.Cells(j, 40).Value
Source.Cells(i, 41).Value = Destination.Cells(j, 41).Value
Source.Cells(i, 42).Value = Destination.Cells(j, 42).Value
ElseIf (Source.Cells(i, 1).Value = Destination.Cells(j, 1).Value) And (Source.Cells(i, 6).Value <> Destination.Cells(j, 6).Value) Then
Source.Cells(i, 1).Interior.ColorIndex = 3
End If
Next j
End If
Next i
End Sub
Public Function FileInUse(sFileName) As Boolean
On Error Resume Next
Open sFileName For Binary Access Read Lock Read As #1
Close #1
FileInUse = IIf(Err.Number > 0, True, False)
On Error GoTo 0
End Function
答案 0 :(得分:0)
使用Application.GetOpenFilename
此外,您需要从完整路径中提取文件名,以便可以使用已打开的工作簿。
这是你在尝试的吗?
Sub MergeInflight01()
Dim wkbSource As Workbook
Dim Filetoopen
Dim WBName As String
'~~> Let user select the file
Filetoopen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If Filetoopen <> False Then
WBName = GetFilenameFromPath(Filetoopen)
If IsWorkBookOpen(WBName) Then
Set wkbSource = Workbooks(WBName).Worksheets("Demand Request Details")
Else
Set wkbSource = Workbooks.Open(Filetoopen)
End If
'
'~~> Rest of the code
'
End If
End Sub
'~~> Check if the Workbook is open
Function IsWorkBookOpen(FileName)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
'~~> Get filename from path
Public Function GetFilenameFromPath(ByVal strPath As String) As String
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
GetFilenameFromPath = _
GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function