I am trying to integrate data from several csv files using Dictionary approach.
Though path and other details have been checked by me carefully, running of the program is encountering error.
Run-time error 432File name or class name not found during Automation operation.
This error come on the following code line .Item(sn(j)) = GetObject("G:\OF\" & sn(j)).Sheets(1).UsedRange.Value.
Here is my code:
Sub M_integratie_csv()
sn = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir ""G:\OF\*.csv"" /b").StdOut.ReadAll, vbCrLf)
With CreateObject("Scripting.Dictionary")
For j = 0 To UBound(sn)
.Item(sn(j)) = GetObject("G:\OF\" & sn(j)).Sheets(1).UsedRange.Value
GetObject("G:\OF\" & sn(j)).Close False
Next
Sheets.Add.Name = "total"
For Each it In .Items
Sheets("total").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(it), UBound(it, 2)) = it
Next
End With
End Sub
Links to csv files used by me are as follows.
csv file 1
csv file 2
csv file 3
Where it is going wrong?
The following code seems to work just fine on my computer:
Sub M_integratie_csv()
sn = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir ""G:\OF\*.csv"" /b").StdOut.ReadAll, vbCrLf)
Set oDic = New Dictionary
With oDic
For j = 0 To UBound(sn)
.Item(sn(j)) = GetObject("G:\OF\" & sn(j)).Sheets(1).UsedRange.Value
GetObject("G:\OF\" & sn(j)).Close False
Next
Sheets.Add.Name = "total"
For Each it In .Items
Sheets("total").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(it), UBound(it, 2)) = it
Next
End With
End Sub
Note, that the reference to Microsoft Scripting Runtime must be set in the VBE in order for the above code to work.
Related
I want to improve my Excel VBA macro that creates the file list and the macro that renames the file name on the file list.
I made two Excel VBA macros. The macro named "Sub File_list" creates a file list in a folder where the xls file is stored and, The macro named "Sub Re_name" renames files using the file list. However, these macros cannot handle files in subfolders.These macros are show below, you can download the macro from this link.
【My Questions】
I want the "Sub File_list" to have the ability to list files in subfolders.
I want these "Sub Re_name" to have the ability to rename files in subfolders.（The renamed file shall stored in the same file as the original file.)
Assume that the files and folders shown in FIG. 1 are stored in the folders.
The "File_mng.xls" is the excel file that consists these macros.
Fig.1
At this time, when the "Sub File_list" is executed, all files stored in the same level (except "File_mng.xls" itself) are displayed on the spreadsheet (See Fig.2). However, sub folders and the files stored in that sub folders are not listed.
Fig.2
Note that, the backslash is garbled into the Yen sign because My Windows10 is Japanese version.
【The macros】
You can also download the macro from this link.
'Create a list of files in a specific folder
Sub File_list()
Dim myFileName As String
Dim FSO As Object
Dim cnt
myDir = ThisWorkbook.Path
myDir = myDir & "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
cnt = FSO.GetFolder(myDir).Files.Count
Range("A1").Value = "File name (Number of files " & cnt & ")"
'Show hidden and system files
myFileName = Dir(myDir & "*", vbHidden + vbSystem)
While myFileName <> vbNullString
If myFileName <> ThisWorkbook.Name Then
Cells(Rows.Count, 1).End(xlUp).Offset(1).Value _
= myDir
Cells(Rows.Count, 2).End(xlUp).Offset(1).Value _
= myFileName
End If
myFileName = Dir()
Wend
Columns(1).AutoFit
Application.ScreenUpdating = True
End Sub
'Renames files using the file list
Sub Re_name()
myDir = ThisWorkbook.Path
Nmax = (ActiveSheet.Range("A1").End(xlDown).Row)
For n = 2 To Nmax
yenn = ""
If (Right(Cells(n, 1), 1) <> "\") Then
yenn = "\"
End If
N1 = Cells(n, 1) & yenn & Cells(n, 2)
N2 = Cells(n, 3) & Cells(n, 4) & Cells(n, 5) & Cells(n, 6)
If N2 = "" Then
N2 = N1
Else
N2 = myDir & "\" & N2
End If
Name N1 As N2
Next n
End Sub
P.S. I'm not very good at English, so I'm sorry if I have some impolite or unclear expressions. I welcome any corrections and English review. (You can edit my question and description to improve them)
You can download all related files from here.
Post hoc Note: (Added on 2019/12/15(JST))
【Comment on the trust settings for PASUMPON V N's macro 】
Thanks to the contributions of PASUMPON V N, I get a complete solution.
You can download a modified version so that it lists files based on the folder where the macro is.
(I modified HostFolder = "C:\User\" to HostFolder = ThisWorkbook.Path )
Running this macro, I came across one error, 'Error 1004: Programmatic access to Visual Basic Project is not trusted' at the line of ".VBProject.References". But It is solved by security settings of excel.
The setting method may depend on version and language
For the Japanese version, if you come across the following error, this site(but written in Japanese) might be helpful. What I actually tried was the procedure written in this site.
"プログラミングによる visual basic プロジェクトへのアクセスは信頼性に欠けます 1004"(that means "'Error 1004: Programmatic access to Visual Basic Project is not trusted")
For the English version,here or here might be helpful if you come across the Error 1004.
Hi I have modified the code for your requirement, could you please let me know if it is fine
i have used below code , for recursive type programming
Loop Through All Subfolders Using VBA
Sub sample()
Dim FileSystem As Object
Dim HostFolder As String
Dim Ref As Object, CheckRefEnabled%
CheckRefEnabled = 0
With ThisWorkbook
For Each Ref In .VBProject.References
If Ref.Name = "Scripting" Then
CheckRefEnabled = 1
Exit For
End If
Next Ref
If CheckRefEnabled = 0 Then
.VBProject.References.AddFromGUID "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0
End If
End With
HostFolder = "C:\User\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
Dim LastRow As Long
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each myFile In Folder.Files
Debug.Print myFile
Debug.Print Folder.Name
Debug.Print myFile.Name
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
i = LastRow + 1
ws.Cells(i, 1) = myFile.Path
ws.Cells(i, 2) = Folder.Name
ws.Cells(i, 3) = myFile.Name
Next
End Sub
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
I am trying to read a CSV file which is semicolon separated and writing its data to an Excel file cell by cell.
My CSV data is like below:
CATALOG;NAME ;TYPE
---;---;---
test ;Mapping ;BASE
test ;RECEPIENT ;BASE
I am trying to append this data to an Excel using below VBScript code.
Set objShell = WScript.CreateObject ("WScript.Shell")
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open(objShell.CurrentDirectory & "\" & "Data.xlsx")
'objExcel.Application.Visible = True
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
LastRow = objSheet.UsedRange.Rows.Count
WScript.Echo "LastRow "&LastRow
'objExcel.Cells(LastRow+1, 1).Value = "Test value"
Set objFileToRead = CreateObject("Scripting.FileSystemObject").OpenTextFile(objShell.CurrentDirectory & "\" & "Output.csv",1)
Dim strLine
Do While Not objFileToRead.AtEndOfStream
strResults = objFileToRead.ReadAll
Loop
objFileToRead.Close
Set objFileToRead = Nothing
If Trim(strResults) <> "" Then
' Create an Array of the Text File
arrline = Split(strResults, vbNewLine)
'WScript.Echo UBound(arrline)
End If
For i = 0 To UBound(arrline)
Do
If i = 1 Then Exit Do
If arrline(i) = "" Then
' checks for a blank line at the end of stream
Exit For
End If
ReDim Preserve arrdata(i)
arrdata(i) = Split(arrline(i), ";")
For j = 0 To UBound(arrdata(i))
WScript.Echo Trim(arrdata(i)(j))
'objExcel.Cells(LastRow+1+i,j).Value = Trim(arrdata(i)(j))
Next
Loop While False
Next
objExcel.ActiveWorkbook.Save
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit
WScript.Echo "Finished."
WScript.Quit
It is showing the csv data but throwing error
Execl.vbs(41, 6) Microsoft VBScript runtime error: Unknown runtime error
Line number 41 is
objExcel.Cells(LastRow+1+i,j).Value = Trim(arrdata(i)(j))
It works if I put some hardcoded value (5,6 ..) in place of j, but it's not taking j as variable. I can not put any value of j as the number of columns in the input CSV is unknown. Please let me know where I am making a mistake and how to resolve it.
I bet the problem lies with looping through the columns starting at an improper index, column 0. Please try adjusting this line:
For j = 0 To UBound(arrdata(i))
to be
For j = 1 To UBound(arrdata(i))
and make sure to validate that it's not overlooking real data in the far-left column!
this is my first question so I would love to improve my style and such. Just tell me if I am doing something completely wrong.
My question:
I am searching files with a specific extensions. All results get printed to excel and then create shortcuts to each file which get then stored in a folder. This works perfectly fine for now, but I need the shortcut to include the author detail to filter all entries (hundreds to thousends) for it.
The result should be a shortcut with the same properties that you get when using the 'create shortcut' from context menu vie right click.
I hope you can help my since I am trying to get this to work for a while now.
If you know a solution, that does what I need but is maybe written in a different language that is fine for me as long as the user does not have to install runtimes/libraries (sory I am a complete beginner)
My code:
'This function searches for files with endings (ppt,pptx,pptm) and pastes the found entries into the excel sheet
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(sPath)
Set Extensions = CreateObject("Scripting.Dictionary")
Extensions.CompareMode = 1 ' make lookups case-insensitive
'Extensions.Add Range("C5").Value, True
Extensions.Add "pptx", True
Extensions.Add "ppt", True
Extensions.Add "pptm", True
For Each mySubFolder In myFolder.SubFolders
For Each myFile In mySubFolder.Files
'
i = Range("D4").Value
If Extensions.Exists(FSO.GetExtensionName(myFile)) Then
Cells(8 + i, 3).Value = myFile.Name
Cells(8 + i, 4).Value = myFile.Path
i = i + 1
Range("D4").Value = i 'storing number of entrys found
'Exit For
End If
Next
Recurse = Recurse(mySubFolder.Path)
Next
End Function
'This Function creates a folder with the name "A1" if it does not exist already
Function PathExist(ByVal vPfadName As String) As Boolean
scutPath = Application.ActiveWorkbook.Path & "\" & Range("A1").Value
On Error GoTo ErrorPathExist
ChDir (vPfadName)
PathExist = True
Exit Function
ErrorPathExist:
MkDir scutPath
End Function
'Main Function that clears table and uses the found entries to get create shortcuts. Unfortunately the author is not integrated when doing it this way. The author is necessary to filter through hundreds of results.
Sub TestR()
Range("B8:C999999") = ""
Range("D4").Value = 0
Call Recurse(Application.ActiveWorkbook.Path)
i = 1
scutPath = Application.ActiveWorkbook.Path & "\" & Range("A1").Value
Call PathExist(scutPath)
For i = 1 To 200 '(last line)
Set oWSH = CreateObject("WScript.Shell")
Set oShortcut = oWSH.CreateShortCut(scutPath & "\" & Cells(7 + i, 3).Value & ".lnk")
With oShortcut
.TargetPath = Cells(7 + i, 4).Value
.Save
End With
Set oWSH = Nothing
Next i
MsgBox "Done"
End Sub
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/