Although this is common error and I tried to find relevant topics but failed to learn to fix my code. I'm trying to copy certain cells of Excel sheet for a particular vendor when we receive updates from them, to avoid manual copy. I see this error at
Set Source = Workbooks(strFileName).Worksheets("Demand Request Details")
step. Please help.
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
Also instead of using an input box for the user to enter the file name and path, use Application.GetOpenFilename
Also you need to extract the file name from the full path so you can work with an already open workbook.
Is this what you are trying?
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.