Forum Discussion
Macros/VBA not working
Dharmendra_BharwadMight I suggest that you upload a text file of your macro rather than an *.xlsm file. I think people might find it a bit risky to download and open an Excel file that contains a macro.
That being said, when you reference a file from your macro, it will generally assume the file you are referencing is in the same folder as the Workbook where you launched the macro. If it is in a different folder, you will need to provide the Fully Qualified path to the file and folder.
If you want to provide a way to choose the import file, You can work with the FileDialog Object. Documentation on this object can be found at:
https://docs.microsoft.com/en-us/office/vba/api/office.filedialog?f1url=https%3A%2F%2Fmsdn.microsoft.com%2Fquery%2Fdev11.query%3FappId%3DDev11IDEF1%26l%3Den-US%26k%3Dk(vbaof11.chm256000)%3Bk(TargetFrameworkMoniker-Office.Version%3Dv16)%26rd%3Dtrue&WT.mc_id=email
Otherwise, you will need to provide some other way to get the FQ filename into your code. You could hard code it into your code, or provide a way for the user to enter the full path using an InputBox, but the recommended way would be to use the FileDialog Object.
I hope that helps.
Hi BobOxford ,
Thanks for your reply. I understand it is risky to download macro file. I have reviewed link sent by you but I am not getting what I want. I have written code below:
Option Base 1
Public Function FindColumn(ByVal Diveice As String, ByVal FN As String, ByVal ShN As String) As Variant
ra = Workbooks(FN).Worksheets(ShN).Cells(65536, 1).Row
CA = Workbooks(FN).Worksheets(ShN).Cells(1, 255).Column
''''''''''''''''''''''''''''
'Find Diveice_S in source1
''''''''''''''''''''''''''''
For i = 1 To ra
For j = 1 To CA
X = Workbooks(FN).Worksheets(ShN).Cells(i, j)
If StrComp(X, Diveice, vbTextCompare) = 0 Then
'arw_s = i
FindColumn = j
End If
If FindColumn > 0 Then
Exit For
End If
Next j
If FindColumn > 0 Then
Exit For
End If
Next i
'''''''''''''''''''''''''''''''
End Function
Public Function FindRow(ByVal Diveice As String, ByVal FN As String, ByVal ShN As String) As Variant
ra = Workbooks(FN).Worksheets(ShN).Cells(65536, 1).Row
CA = Workbooks(FN).Worksheets(ShN).Cells(1, 255).Column
''''''''''''''''''''''''''''
'Find Diveice_S in source1
''''''''''''''''''''''''''''
For i = 1 To ra
For j = 1 To CA
X = Workbooks(FN).Worksheets(ShN).Cells(i, j)
If StrComp(X, Diveice, vbTextCompare) = 0 Then
FindRow = i
'FindColumn = j
End If
If FindRow > 0 Then
Exit For
End If
Next j
If FindRow > 0 Then
Exit For
End If
Next i
'''''''''''''''''''''''''''''''
End Function
Public Function FindColumn_In_Row(ByVal val_name As String, ByVal Ob_Sheet As Worksheet, ByVal Val_Row As Variant) As Variant
Dim Final_Col As Variant
Dim Val_Col As Variant
Final_Col = Fun_FinalCol(Ob_Sheet, Val_Row)
''''''''''''''''''''''''''''
'Find Diveice_S in source1
''''''''''''''''''''''''''''
Val_Col = 0
For j = 1 To Final_Col
curr_cell = CStr(Ob_Sheet.Cells(Val_Row, j).Value)
If StrComp(curr_cell, val_name, vbTextCompare) = 0 Then
Val_Col = j
Exit For
End If
Next j
FindColumn_In_Row = Val_Col
'''''''''''''''''''''''''''''''
End Function
Public Function FindRow_In_Col(ByVal val_name As String, ByVal Ob_Sheet As Worksheet, ByVal Val_Col As Variant) As Variant
Dim Final_Row As Variant
Dim Val_Row As Variant
Final_Row = Fun_FinalRow(Ob_Sheet, Val_Col)
''''''''''''''''''''''''''''
'Find Diveice_S in source1
''''''''''''''''''''''''''''
Val_Row = 0
For i = 1 To Final_Row
curr_cell = CStr(Ob_Sheet.Cells(i, Val_Col).Value)
If StrComp(curr_cell, val_name, vbTextCompare) = 0 Then
Val_Row = i
Exit For
End If
Next i
FindRow_In_Col = Val_Row
'''''''''''''''''''''''''''''''
End Function
'find last column in a spesific row
Public Function Fun_FinalCol(ByVal Ob_Sheet As Worksheet, ByVal Val_Row As Variant) As Variant
count_Col = Ob_Sheet.Columns.Count
Fun_FinalCol = Ob_Sheet.Cells(Val_Row, count_Col).End(xlToLeft).Column
End Function
'find last row in a spesific column
Public Function Fun_FinalRow(ByVal Ob_Sheet As Worksheet, ByVal Val_Col As Variant) As Variant
Count_Row = Ob_Sheet.Rows.Count
Fun_FinalRow = Ob_Sheet.Cells(Count_Row, Val_Col).End(xlUp).Row
End Function
Public Function GetUniqueValues(ByVal values As Variant) As Variant
Dim result As Collection
Dim cellValue As Variant
Dim Arr_Val() As Variant
Set result = New Collection
Set GetUniqueValues = result
On Error Resume Next
For Each cellValue In values
If Trim(cellValue) = "" Then
Else
On Error Resume Next
result.Add Trim(cellValue), Trim(cellValue)
End If
Next cellValue
count_Col = result.Count
t = 1
For i = 1 To count_Col Step 1
ReDim Preserve Arr_Val(t)
Arr_Val(t) = result.Item(i)
t = t + 1
Next i
GetUniqueValues = Arr_Val
End Function
'Searching File
Public Function Fun_FindOpenFile(ByVal File_Name_Search As String) As Boolean
Dim Val_Count As Long
Dim Val_Current_FN As String
''''''''''
'amount of open files
Val_Count = Workbooks.Count
''''''''''
''''''''''
'Searching File
''''''''''
Fun_FindOpenFile = False
If Val_Count < 1 Then
Fun_FindOpenFile = False
Else
For i = 1 To Val_Count
Val_Current_FN = Workbooks.Item(i).Name
If StrComp(Val_Current_FN, File_Name_Search, vbTextCompare) = 0 Then
Fun_FindOpenFile = True
End If
If Fun_FindOpenFile Then
Exit For
End If
Next i
End If
End Function
Public Function Fun_FindFile_in_Folder(ByVal Path_SourceFile As String, ByVal Name_SourceFile As String) As Boolean
Dim Val_Current_FN As String
Dim ARR_Current_FN() As String
Fun_FindFile_in_Folder = False
'''''''''''''''''''''''
''''''''''''''''''''''''
'creat arrray from names of the files in folder Path_SourceFile
Val_Current_FN = Dir(Path_SourceFile) ' peremennoj ArFName1 prisvaivaetsa pervoje ima fajla
Do While Val_Current_FN <> vbNullString
If Val_Current_FN <> "." And Val_Current_FN <> ".." Then
t = t + 1
ReDim Preserve ARR_Current_FN(t)
ARR_Current_FN(t) = Val_Current_FN
End If
Val_Current_FN = Dir
Loop
'''''''''''''''''''''''''
'''''''''''''''''''''''''
' Search for Name_SourceFile in Array of Files
For i1 = 1 To t
If StrComp(ARR_Current_FN(i1), Name_SourceFile, vbTextCompare) = 0 Then
Fun_FindFile_in_Folder = True
Exit For
End If
Next i1
End Function
Public Sub start_import()
Load UserForm1
UserForm1.Show
Bool_UF = True
End Sub
Function GetFolder(strPath As String) As String
On Error Resume Next
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFilePicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Public Function Get_OpenFile(ByVal File_Path As String, ByVal File_Name As String) As Boolean
Dim Bool_Result As Boolean
Dim Bool_Check As Boolean
Dim FSO As New FileSystemObject
Dim Ob_File As Workbook
Bool_Result = False
'''''''''''''''''''
'Check path
If Len(File_Path) <= 0 Then
Get_OpenFile = Bool_Result
Exit Function
End If
last_val = Right(File_Path, 1)
If StrComp(last_val, "\", vbTextCompare) <> 0 Then
File_Path = File_Path & "\"
End If
Bool_Check = FSO.FolderExists(File_Path)
If Not Bool_Check Then
Get_OpenFile = Bool_Result
Exit Function
End If
'''''''''''''''''''
'check file name
If Len(File_Name) <= 0 Then
Get_OpenFile = Bool_Result
Exit Function
End If
'if file is open
Set Ob_File = Nothing
On Error Resume Next
Set Ob_File = Workbooks(File_Name)
If Ob_File Is Nothing Then
Else
Ob_File.Close (False)
End If
'if file is in filder
Bool_Check = FSO.FileExists(File_Path & File_Name)
If Bool_Check Then
Workbooks.Open (File_Path & File_Name)
Get_OpenFile = True
Exit Function
Else
Get_OpenFile = False
Exit Function
End If
End Function
Public Function Get_FilesFromFolder(ByVal Str_Path As String, ByVal Str_Flag As String, ByVal Str_FileType As String) As Variant
''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''
'variebles for module
Dim ArrName_Source_Files() As String
''''''''''''''''''''''''''
''''''''''''''''''''''''''
'Check path
If Len(Str_Path) = 0 Then
Exit Function
End If
last_val = Right(Str_Path, 1)
If last_val <> "\" Then
Str_Path = Str_Path & "\"
End If
''''''''''''''''''''''''''
''''''''''''''''''''''''''
'macros file name (will not include it to list of files)
If Len(Str_FileType) > 0 Then
File_Name = Dir(Str_Path & "*" & Str_FileType & "*")
Else
File_Name = Dir(Str_Path, vbNormal)
End If
CurFile = ThisWorkbook.Name
i = 1
Do While File_Name <> vbNullString
If StrComp(CurFile, File_Name, vbTextCompare) = 0 Then
Else
If Len(Str_FileType) > 0 Then
If InStr(1, File_Name, Str_Flag, vbTextCompare) > 0 Then
ReDim Preserve ArrName_Source_Files(i)
ArrName_Source_Files(i) = File_Name
i = i + 1
End If
Else
ReDim Preserve ArrName_Source_Files(i)
ArrName_Source_Files(i) = File_Name
i = i + 1
End If
End If
File_Name = Dir()
Loop
Get_FilesFromFolder = ArrName_Source_Files
End Function
Let me know if you need further clarification.