VBA unable to read files after closing and reopen excel - excel

Assuming I have 3 files all in same folder (item.xlsx, master.xlsx, transfer.xlsm) Main purpose is to transfer data from item to master.
I do all the codes inside transfer.xlsm and allow users to input file name and column mappings. I have been doing few hours for the codes and have tested several times and is working perfectly fine. With a click of a button is able to read data from item.xlsx and copy over to master.xlsx according to the column mapping.
However problem arise when i close all 3 files and reopen again. I open up all 3 file, when i click on the button on transfer,xlsm it show file not found which is the error handling i did. I did tried creating a new folder on my desktop and create a brand new transfer.xlsm inside, i copy the item and master file over and my code into my new button. It actually able to work but when i close and reopen in that new folder is not working,
Basically is working fine when i am working on it, when i close it totally and reopen it is unable to detect the 2 files.
cell values are entered inside transfer.xlsm according to user input
source = Cells(5, 2)
sourceSheet = Cells(6, 2)
sourceSheetRow = Cells(7, 2) - 1
destination = Cells(8, 2)
destinationSheet = Cells(9, 2)
destinationSheetRow = Cells(10, 2) - 1
source = source + ".xlsx"
destination = destination + ".xlsx"
rows = Cells(11, 2)
If FileExists(source) = False Or FileExists(destination) = False Then
MsgBox "File not found, please double check file name and make sure is in the same folder"
Exit Sub
End If
For i = 1 To rows
...
Next i
Function FileExists(FilePath As String) As Boolean
Dim TestStr As String
TestStr = ""
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
If TestStr = "" Then
FileExists = False
Else
FileExists = True
End If
End Function
I created this transfer.xlsm so that i can send it to people if they want to copy chunks of data from one excel to another instead of copy paste row by row. Hope someone can give me some guidance

Based on the information you provided, I am assuming that the information provided by the users is just the file name without the extension: item or master, and not the full file path C:\SampleFolder\item.xlsx or C:\SampleFolder\master.xlsx. Additionally, I am assuming when you run this code all three files must be in the same folder.
If this is the case, try using ThisWorkbook.Path, you can apply this to your Source and Destination paths to ensure that the appropriate file path is being used.
Dim sPath as String
sPath = ThisWorkbook.Path + "\"
source = Cells(5, 2)
sourceSheet = Cells(6, 2)
sourceSheetRow = Cells(7, 2) - 1
destination = Cells(8, 2)
destinationSheet = Cells(9, 2)
destinationSheetRow = Cells(10, 2) - 1
source = source + ".xlsx"
destination = destination + ".xlsx"
If FileExists(sPath + source) = False Or FileExists(sPath + destination) = False Then
MsgBox "File not found, please double check file name and make sure is in the same folder"
Exit Sub
End If
...

Related

Excel crashing randomly when running macro

I'm having an issue with the following code, that is supposed to sequentially open 〜100 csv files, check for a value in a cell (validation, if it is file with correct structure), copy single line of data and paste it into ThisWorkbook.Worksheets("2 CSV").Range("B" & row_number).
This solution worked for two years until this month. Now the whole Excel crashes randomly on any file without any error message. Sometimes it manages to loop through 20 files, sometimes 5.
The weirdest thing is, that I can loop manually using F8 through the whole thing without any problem.
The macro:
Sub b_load_csv()
Dim appStatus As Variant
Dim folder_path As String 'folder path to where CSVs are stored
Dim file_name As String 'file name of current CSV file
Dim row_number As Integer 'row number in target sheet
Dim source_sheet_name As String 'name of the source sheet of the CSV = CSV file name
Dim wb_src As Workbook 'variable for opened CSV source workbook
Dim sht_src As Worksheet 'variable for opened CSV source sheet
Dim sht_csv As Worksheet 'variable for target sheet in ThisWorkbook
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
If .StatusBar = False Then appStatus = False Else appStatus = .StatusBar 'show currently processing file in status bar
End With
folder_path = "C:\Folder\SubFolder\" 'here are the files stored
file_name = Dir(folder_path & "*.csv") 'using dir to get file names
row_number = 3 'row number for pasting values
Set sht_csv = ThisWorkbook.Worksheets("2 CSV") 'target sheet for data aggregation
Do While file_name <> ""
Workbooks.Open (folder_path & file_name), UpdateLinks:=False, Local:=True 'open csv file
Set wb_src = Workbooks(file_name) 'assign opened csv file to variable
source_sheet_name = Left(file_name, InStr(file_name, ".") - 1) 'sheet name in csv is the same as the file name
Set sht_src = wb_src.Worksheets(source_sheet_name) 'assign source sheet to variable
If sht_src.Range("C1").Value2 = "OJ_POPIS" Then 'checks if the csv has the correct structure
sht_src.Range("A2:FZ2").Copy 'if so copies desired range
sht_csv.Range("B" & row_number).PasteSpecial 'and pastes it into target worksheet column B
End If
sht_csv.Range("A" & row_number).Value2 = file_name 'writes file name into column A
Application.CutCopyMode = False
wb_src.Close SaveChanges:=False
file_name = Dir() 'fetch next file name
row_number = row_number + 1
'the following lines is what I tried to fix the problem of random excel crashing
Set wb_src = Nothing
Set sht_src = Nothing
Application.StatusBar = "Processing file " & file_name
DoEvents
Application.Wait (Now + TimeValue("0:00:02"))
ThisWorkbook.Save 'save after every loaded file to see which files are causing the problem
Loop
MsgBox "Data from CSV files copied", vbOKOnly
Set sht_csv = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Source CSV files are encoded both in UTF-8 and ANSI (my ACP is ANSI, 1250) and ; delimited.
Group policy restricting macros doesn't apply to me. I can sign my own macros.
What I tried:
Lines of code at the end of the loop
Identifying and deleting files triggering the crash (they have nothing in common, seemingly random, by the time a remove half of them... what is the point)
Simplifying the macro
New workbook
Different machine
VPN On/Off
Thank you for your help!
First thing I'd try is include a proper error handler (not resume next), particularly with x64, and ensure 'Break on all unhandled errors' is selected in Tools / Options / General.
Second thing I'd try is avoid using the clipboard -
With sht_src.Range("A2:FZ2")
sht_cvs.Range("B" & row_number).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
(no need then to clear CutCopyMode)
Third thing I'd try is don't filter with Dir but something like this -
sFilter = "*.cvs"
file_name = Dir$(, 15) ' without vbDirectory if not getting subfolders
Do While Len(file_name)
If file_name Like sFilter Then
' process file
End If
file_name = Dir$(, 15)
Loop
Fourth thing I'd try is a good cup of coffee!

Using function to open and update values in external workbooks, but returning source errors

I've been using a function from another StackOverflow question (I'm SO sorry I can't find the original answer!) to help go through a number of cells in Column L that contains a formula that spits our a hyperlinked filepath. It is meant to open each one (workbook), update the values, then save and close the workbook before opening the next one. See below.
Sub List_UpdateAndSave()
Dim lr As Long
Dim i As Integer
Dim WBSsource As Workbook
Dim FileNames As Variant
Dim msg As String
' Update the individual credit models
With ThisWorkbook.Sheets("List")
lr = .Cells(.Rows.Count, "L").End(xlUp).Row
FileNames = .Range("L2:L" & lr).Value
End With
For i = LBound(FileNames, 1) To UBound(FileNames, 1)
On Error Resume Next
If FileNames(i, 1) Like "*.xls*" Then
Set WBSsource = Workbooks.Open(FileNames(i, 1), _
ReadOnly:=False, _
Password:="", _
UpdateLinks:=3)
If Err = 0 Then
With WBSsource
'do stuff here
.Save
.Close True
End With
Else
msg = msg & FileNames(i, 1) & Chr(10)
On Error GoTo 0
End If
End If
Set WBSsource = Nothing
Next i
If Len(msg) > 0 Then
MsgBox "The Following Files Could Not Be Opened" & _
Chr(10) & msg, 48, "Error"
End If
End Sub
The problem now is I am using this to work on a Network drive, and as a result it cause pathing issues with the Connections/Edit Links part. Each of the files are stored on S:\... which as a result of using the Hyperlink formula, won't be able to find the source data. See below the example image of a file that as been opened through a hyperlink cell from my original workbook. When I go to update the Edit Links section of it, it shows these errors.
If I open that lettered drive in Windows Explorer and find the file, it works with no problems. Open, Update Values > Save > Close, it says unknown...
(but if I click Update values here they update correctly.)
If opened using a Hyperlink formula in a cell (Also directing to S:\..) it says it contains links that cannot be updated. I choose to edit links and they're all "Error: Source not found". The location on them also starts off with \\\corp\... and not S:\.
Anyway to fix this? Apologies for the long winded question.
I'm adding this as an answer as it contains code and is a bit long for a comment.
I'm not sure if it's what you're after though.
The code will take the mapped drive and return the network drive, or visa-versa for Excel files. DriveMap is the variable containing the final string - you may want to adapt into a function.
Sub UpdatePath()
Dim oFSO As Object
Dim oDrv As Object
Dim FileName As String
Dim DriveMap As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileName = Range("A1")
If InStr(oFSO.GetExtensionName(FileName), "xls") > 0 Then
For Each oDrv In oFSO.drives
If oDrv.sharename <> "" Then
'Changes \\corp\.... to S:\
If InStr(FileName, oDrv.sharename) = 1 Then
DriveMap = Replace(FileName, oDrv.sharename, oDrv.Path)
End If
'Changes S:\ to \\corp\....
' If InStr(FileName, oDrv.Path) = 1 Then
' DriveMap = Replace(FileName, oDrv.Path, oDrv.sharename)
' End If
End If
Next oDrv
End If
End Sub

Extracting a row from a CSV file quickly in Excel VBA

I have about 5000 .csv files and I want to search for one row in each file and extract it. I have pasted the key part of code below, which works, but as I have to open and close each .csv file, the process is slow for 5000 files. Is there any way to read a csv file without opening it? I had considered writing a small script to convert each csv file to Excel first? Thx.
SP_File_Name = Dir(DN_Path & "*.*")
Count = 1
Set START_CELL_RANGE = TARGET_SP_SHEET.Range("B3")
Set TICKER_CODE_RANGE = TARGET_SP_SHEET.Range("B1")
While (SP_File_Name <> "")
SP_Full_Path = DN_Path & SP_File_Name
Workbooks.OpenText Filename:=SP_Full_Path, DataType:=xlDelimited, comma:=True, Local:=True
Set INPUT_WORKBOOK = ActiveWorkbook
Set INPUT_SHEET = INPUT_WORKBOOK.Worksheets(1)
INPUT_SHEET.Range("$A$1").Select
Set INPUT_RANGE = ActiveCell.CurrentRegion
Set INPUT_FIRST_MATCH_RANGE = INPUT_RANGE.Find(TICKER_CODE_RANGE)
If INPUT_FIRST_MATCH_RANGE Is Nothing Then
GoTo NOT_FOUND
End If
START_CELL = START_CELL_RANGE.Address
TARGET_SP_SHEET.Range(START_CELL_RANGE.Address, START_CELL_RANGE.Offset(0, 6).Address).Value = INPUT_SHEET.Range(INPUT_FIRST_MATCH_RANGE.Address, INPUT_FIRST_MATCH_RANGE.Offset(0, 7).Address).Value
' write diagnostics
Sheet5.Range("K" & Count + 4).Value = START_CELL
Sheet5.Range("L" & Count + 4).Value = "$A$1"
Sheet5.Range("M" & Count + 4).Value = INPUT_FIRST_MATCH_RANGE.Address
Sheet5.Range("N" & Count + 4).Value = INPUT_FIRST_MATCH_RANGE.Offset(0, 7).Address
NOT_FOUND:
Set START_CELL_RANGE = START_CELL_RANGE.Offset(1, 0)
Workbooks(SP_File_Name).Close SaveChanges:=False
SP_File_Name = Dir
Count = Count + 1
Wend
To call a cmd command from VBA, I have used WshShell. For early binding I set a reference to the Windows Script Host Object Model
One problem with the Shell function is that it runs asynchronously. By using the WshShell Run method, you can have it wait until finished before executing subsequent commands.
Sample code might look as follows:
Option Explicit
Sub foo()
Dim WSH As WshShell
Dim lErrCode As Long
Set WSH = New WshShell
lErrCode = WSH.Run("cmd /c findstr /C:""Power"" ""C:\Users\Ron\filelist.txt"" > ""C:\Users\Ron\Results2.txt""", 1, True)
If lErrCode <> 0 Then
MsgBox "Error Code: " & lErrCode
Stop
End If
Set WSH = Nothing
Call Shell
End Sub
With regard to your command that you showed in your comment, I would ensure that VBA is interpreting the string correctly for the cmd prompt. Looking at your code line, I would wonder whether you are missing a space between the search string and the file path.
I don't think you can read the contents of a file without opening it. Why not just merge all 5000 files into 1 single file and read that into Excel. Certainly that will be much faster. Use the Command Window, point it to the folder that contains all 5000 files, and enter this:
copy *.csv merge.csv
See the link below for an example.
http://analystcave.com/merge-csv-files-or-txt-files-in-a-folder/

workbook.open Problems Macro Excel

I got problems in making the files search using workbooks.open. When the macro is executed, it shows runtime error "1004". Actually, I learn this from YouTube.
Can anyone know what's the problems?
This code actually find multiple excel files in one folder that we path.
Sub checkcopy()
Dim cf As String
Dim erow
cf = Dir("C:\Supplier\")
Do While Len(cf) > 0
MsgBox ("Check")
If cf = "SummaryCheckFile.xlsm" Then
Exit Sub
End If
MsgBox ("Check 1")
Workbooks.Open (cf)
Range("A1:E1").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
checkFile = Dir
Loop
End Sub
Sorry,
its show
'go.xls' not found be found. Check The spelling of the file name and verify the file location is correct.
If you are trying to open the file from your list of mostly recently used files, make sure.....
Dir() only returns the filename - it does not include the path, so you need to specify both of those when you call Workbooks.Open()
Also your loop will never exit (unless the first file is "SummaryCheckFile.xlsm") because all other calls to Dir() assign the return value to checkFile, so cf will never be cleared.
Sub checkcopy()
Const FLDR As String = "C:\Supplier\"
Const EXCLUDE_FILE As String = "SummaryCheckFile.xlsm"
Dim cf As String, c As Range, wb As Workbook
'set the first copy destination
Set c = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
cf = Dir(FLDR & "*.xls*", vbNormal) 'only Excel files
Do While Len(cf) > 0
Debug.Print cf
'opening this file ?
If UCase(cf) <> UCase(EXCLUDE_FILE) Then
Set wb = Workbooks.Open(FLDR & cf, ReadOnly:=True)
wb.Sheets(1).Range("A1:E1").Copy c 'assumes copying from the first sheet
Set c = c.Offset(1, 0) 'next destination row
wb.Close False
End If
cf = Dir 'next file
Loop
End Sub
Try to give the path of cf, for example cf = "c:\XXX\filename.xlsm", rather than cf = "filename.xlsm".
Try to work with the parameter CorruptLoad when opening the xlsm which contains macros and causing runtime errors and no response.
Application.DisplayAlerts = False
Workbooks.Open ("enter your file path here"), CorruptLoad:=xlExtractData
Application.DisplayAlerts = True

Excel VBA For Loop and Nested IF statements for Counter

I have a value in a cell that should match the filename of a document in a directory.
Sheet3 Column A1 = C:\Users\Admin\Desktop\Folder1
Sheet3 Column A2 = test.xls
‘Location of directory
sCurrentXLDirectory = Worksheets("Sheet3").Cells(1, 1).Value
Set CurrentXLFSO = CreateObject("Scripting.FileSystemObject")
ProceedNow = True
Set CurrentXLFolder = CurrentXLFSO.GetFolder(sCurrentXLDirectory)
Set CurrentXLFiles = CurrentXLFolder.Files
‘Always 10 files in this folder
If CurrentXLFiles.Count <> 10 Then
MsgBox "Wrong Directory or Folder Mismatch"
ProceedNow = False
Else
'Return one for indentical filename
Dim NameCount As Integer
NameCount = 0
For Each folderIDX In CurrentXLFiles
‘Compare file names specified cell value
If folderIDX.Name = Worksheets("Sheet3").Cells(1, 2).Value Then
NameCount = NameCount + 1
If NameCount <> 1 Then
MsgBox "Unable to find file”
ProceedNow = False
End If
End If
Next
End If
For some reason, even if I change test.xls to test1.xls, it will still do Proceed = True
If a nested IF statement is not the preferable way to do this, please guide me in the right direction.
If the purpose of the procedure is verify if a file exists or does not exist, using the Dir() function would be much simpler.
If this is the goal, try the following code:
Sub test()
Dim sDirectory As String
Dim sFile As String
sDirectory = Worksheets("Sheet3").Cells(1, 1).Value
sFile = Worksheets("Sheet3").Cells(1, 2).Value
sFile = Dir(sDirectory & "\" & sFile, vbDirectory)
If Len(sFile) = 0 Then
MsgBox "Unable to find file"
End If
End Sub
The code you provided will not change a file name, so maybe this is just the beginnings of your attempt. What I found, though, is that Range("A2") is "Cells(2, 1)", not "Cells(1, 2)", as you currently have it. You are referencing cell B1, which probably does not contain a file name.
To alleviate such confusion in the future, always refer to one or the other, then such problems are avoided or easily diagnosed.
Such as:
If folderIDX.Name = Worksheets("Sheet3").Range("A2").Value Then
This should trip that "ProceedNow = False" flag that you are looking for.

Resources