The code I wrote can display filenames into a sheet, but I want to remove the extension when displayed. I know that should be a little correction, but I burned out trying options. Can Somebody tell me where exaclty I must add a piece of code that I miss please? My attempt of code below. Many similar issues on the net, but I can not manage to find it.Thanks in advance....
Option Explicit
Sub fileNames_in_folder()
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Dim fldpath
Dim fld As Object, fil As Object, fso As Object, j As Long
fldpath = "C:\"
On Error Resume Next
Thisworkbook.Sheets("1").Activate
'start count row
j = 11
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(fldpath)
For Each fil In fld.Files
'here I have to add something due to expell the ".extension"
Cells(j, 34).Value = fso.GetBaseName(fil.path)
'count behaviour
j = j + 1
Next
Columns("AH").AutoFit
End Sub
A file name without extension you can get with GetBaseName Method:
Cells(j, 34).Value = fso.GetBaseName(fil.path)
If InStrRev(fil.Path, ".") <> 0 Then
Cells(j, 34).Value = Left(fil.Path, InStrRev(fil.Path, ".") - 1)
End If
Assuming the presence "." in the file name.
i.e. C:\Test.txt will be shown as C:\Test
Related
My code gives me error from
If Dir(Pth, vbArchive) <> vbNullString Then
I havent been able to find the error - Can someone help me what is wrong with the code? Is it supposed to say USERPROFILE, or am i supposed to write something else?
Sub Opgave8()
Dim sh As Worksheet
Dim Pth As String
Application.ScreenUpdating = False
' Create default desktop path using windows user id
user_id = Environ$("USERPROFILE")
' Create full path
file_name$ = "\AdminExport.csv"
Pth = Environ$("USERPROFILE") & "\Desktop\" & FileName
Set sh = Sheets.Add
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
sh.Cells(i, 2) = Worksheets("Base").Cells(i, 4)
End If
Next i
sh.Move
If Dir(Pth, vbArchive) <> vbNullString Then
overwrite_question = MsgBox("File already exist, do you want to overwrite it?", vbYesNo)
End If
If overwrite_question = vbYes Then
With ActiveWorkbook
.SaveAs FileName:=Pth, FileFormat:=xlCSV
.Close False
End With
End If
Application.ScreenUpdating = True
End Sub
Function UniqueRandDigits(x As Long) As String
Dim i As Long
Dim n As Integer
Dim s As String
Do
n = Int(Rnd() * 10)
If InStr(s, n) = 0 Then
s = s & n
i = i + 1
End If
Loop Until i = x + 1
UniqueRandDigits = s
End Function
There are a few issues in your code. I don't understand why you are getting an error message, but if you fix your issues, you are in a better position of finding the main problem.
Put Option Explicit at the top. If you do that, you will not do mistakes like setting the variable file_name$ but reading from the variable FileName.
You are building a path with double backslashes. Perhaps not a big thing and it'll probably work. Add a Debug.Print Pth just before your troublesome If. Press Ctrl-G to show the debug pane and study the output. Does the printed file path exist?
Don't use vbNullString. Test with abc <> "" instead.
I have 100+ files in one folder. Each file has 3 lists, but only 1 list with data. I need to take that data from each file and combine it in a single file on 1 list. I wrote a sub for it, but I'm not sure how to go around selecting only the range needed (it varies from file to file) - in the same way you do it on keyboard with Ctrl + Shift + left arrow + down arrow. And how should I go around pasting it in the result workbook at exactly the first free line after the data that was pasted before?
Sub combine()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim ExcelApp As Object
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False
ExcelApp.ScreenUpdating = False
ExcelApp.DisplayAlerts = False
ExcelApp.EnableEvents = False
'**VARIABLES**
Dim folderPath As String
folderPath = "Y:\plan_graphs\final\mich_alco_test\files\"
'COUNT THE FILES
Dim totalFiles As Long
totalFiles = 0
Dim fileTitle As String
fileTitle = Dir(folderPath & "*.xl??")
Do While fileTitle <> ""
totalFiles = totalFiles + 1
fileTitle = Dir()
Loop
'OPENING FILES
Dim resultWorkbook As Workbook
Dim dataWorkbook As Workbook
Set resultWorkbook = ExcelApp.Application.Workbooks.Open("Y:\plan_graphs\final\mich_alco_test\result.xlsx")
fileTitle = Dir(folderPath & "*.xl??")
'FOR EACH FILE
Do While fileTitle <> ""
Set dataWorkbook = ExcelApp.Application.Workbooks.Open(folderPath & fileTitle)
dataWorkbook.Worksheets("List1").Range("A1").Select
dataWorkbook.Worksheets("List1").Selection.CurrentRegion.Select
`resultWorkbook.Range
fileTitle = Dir()
Loop
ExcelApp.Quit
Set ExcelApp = Nothing
End Sub
I may have misunderstood the question and unfortunately I cannot make a comment. If I've grasped this question wrong, i'll delete.
but I'm not sure how to go around selecting only the range needed
This suggests that you have a dynamic amount of data and want to use Range to grab the selections.
Supposing you know the column location of where said data is located (in this case my list starts at B2 and we don't know where it ends. You can use Range to dynamically select all data:
Dim rcell As Range
Dim rng As Range
Set rng = ActiveSheet.Range("B2", Range("B2").End(xlDown))
For Each rcell In rng.Cells
Debug.Print rcell.Value
Next rcell
End Sub
First we define a Range variable and assign it to the range starting at B2 and using .End(xlDown) we can select a range ending at the final entry.
For further reading on .End() see here.
Hope this helps.
You can do this without VBA. Use Get & Transform instead.
Here are a few steps to get you started:
Go to the Data Tab
Under Get & Transform, pick New Query - From File - From Folder
Select the folder containing all your 100+ files
Select the tab that contains your data
You are almost there. Do your final fixes (if needed)
Once you're done, click Close & Load
This should do what you want.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
i have this Code VBA, its works, i can combine some files on one sheet.
check it!
Sub Open_Files()
Dim Hoja As Object
Application.ScreenUpdating = False
'Definir la variable como tipo Variante
Dim X As Variant
'Abrir cuadro de dialogo
X = Application.GetOpenFilename _
("Excel Files (*.xlsx), *.xlsx", 2, "Abrir archivos", , True)
'Validar si se seleccionaron archivos
If IsArray(X) Then ' Si se seleccionan
'Crea Libro nuevo
Workbooks.Add
'Captura nombre de archivo destino donde se grabaran los archivos seleccionados
A = ActiveWorkbook.Name
'*/********************
For y = LBound(X) To UBound(X)
Application.StatusBar = "Importando Archivos: " & X(y)
Workbooks.Open X(y)
b = ActiveWorkbook.Name
For Each Hoja In ActiveWorkbook.Sheets
Hoja.Copy after:=Workbooks(A).Sheets(Workbooks(A).Sheets.Count)
Next
Workbooks(b).Close False
Next
Application.StatusBar = "Listo"
Call Unir_Hojas
End If
Application.ScreenUpdating = False
End Sub
I am trying to loop through all subfolders within a folder, compiling all the names of the files. I'm having a bit of trouble though as I have adapted this code from a macro that only loops through one folder and compiles file names. Thank you greatly for your time!
Sub FindFiles()
Cells(1, 1).Select
Dim F As String
Dim G As String
F = Dir("C:\Users\z003nttv\Desktop\Folder\" & "*")
Do While Len(F) > 0
Do While Len(G) > 0
G = Dir(F & "*.*")
ActiveCell.Formula = G
ActiveCell.Offset(1, 0).Select
G = Dir()
Loop
F = Dir()
Loop
End Sub
Found the answer at the following site:
https://www.extendoffice.com/documents/excel/2994-excel-list-all-files-in-folder-and-subfolders.html
Hope it may lend some help..very user friendly!
I was working on this code before you posted the link and had second thoughts posting my work. So I checked out the link you posted. I believe that the code I wanted to post is succinct & addresses the point far better. Hence here you go
Step 1. The Reference
Step2. The Code.
Sub FindFiles()
Dim fso As FileSystemObject
Dim Folder As Folder
Dim Files As Files
Dim path, s As String
'' Input Path : Please change as needed
path = Sheets("Sheet1").Cells(1, 2).Value
Set fso = New FileSystemObject
Set Basefolder = fso.GetFolder(path)
Set SubFolders = Basefolder.SubFolders
Dim i As Integer
i = 1
For Each Folder In SubFolders
Set Files = Folder.Files
For Each File In Files
With Sheets("Sheet1")
.Cells(i, 1).Value = Folder
.Cells(i, 2).Value = File
i = i + 1
Next File
Next Folder
End Sub
As we know, we use Find() method to find whether a string or any Microsoft Excel data type exists in an excel.
(Usually we do it on set of data)
I want to know if any such method available when we loop through folder(of files) using Dir function.
Situation:
I have an excel - 'FileNames.xlsx' in which 'Sheet1' has names of files having extensions .pdf/.jpg/.jpeg/.xls/.xlsx/.png./.txt/.docx/ .rtf in column A.
I have a folder named 'Folder' which has most(or all) of the files from 'FileNames.xlsx'.
I have to check whether all the file-names mentioned in the 'FileNames.xlsx' exist in 'Folder'.
For this I have written the below VBScript(.vbs):
strMessage =Inputbox("Enter No. of Files in Folder","Input Required")
set xlinput = createobject("excel.application")
set wb123 =xlinput.workbooks.Open("E:\FileNames.xlsx")
set sh1 =wb123.worksheets("Sheet1")
For i = 2 to strMessage +1
namei = sh1.cells(i,1).value
yesi = "E:\Folder"+ namei +
If namei <> yesi Then
sh1.cells(i,1).Interior.Color = vbRed
Else
End If
Next
msgbox "Success"
xlinput.quit
As I wasn't able to get the required Output I tried it recording a small Excel VBA Macro. (Changed FileNames.xlsx to FileNames.xlsm)
Sub LoopThroughFiles()
Dim lastRow As Long
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
Dim MyFolder As String
Dim filename As Range
Dim MyFile As String
MyFolder = "E:\Folder"
For Each filename In Worksheets("Sheet1").Range("A2A:" & lastRow)
MyFile = Dir(MyFolder & "\*.xlsx")
'Here I actually need to pass all file extensions to Dir
Do While MyFile <> ""
If filename = MyFile Then
'Do Nothing
Else
filename.Interior.Color = vbRed
MyFile = Dir
Next
End Sub
The above is a failed attempt.
I thought of trying it with method similar to Find()
Sub LoopThroughFiles()
Dim lastRow As Long
'Dim LastFile As Long
'Is there need of it (LastFile variable)? I kept this variable
'to save (prior known) count of files in folder.
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
'LastFile = 'Pass count of Files in folder to this variable.
Dim fileName As Range
For Each fileName In Worksheets("Sheet1").Range("A2:A" & lastRow)
Dim rngFnder As Range
On Error Resume Next
'Error at below line.
Set rngFnder = Dir("E:\Folder\").Find(filename)
'This line gives me error 'Invalid Qualifier'
'I am trying to use method similar to Find()
If rngFnder Is Nothing Then
filename.Interior.Color = vbRed
End If
Next
End Sub
But, I couldn't achieve the result. Can anyone tell me is there any such function available to 'Find' whether all filenames in an excel exist in a folder after looping through folder using Dir?
As per my knowledge, Dir function works with only one file extension at a time.
Is it possible to use Dir function for multiple file extensions at a time?
Expected Output:
Assume I have 8 filenames in 'FileNames(.xlsx/.xlsm)'. Out of which Arabella.pdf and Clover.png are not found in 'Folder', Then I want to color cells for these filenames in red background in excel as in below image.
Sub LoopThroughFiles()
Dim lastRow As Long
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
Dim MyFolder As String
Dim filename As Range
Dim MyFile As String
MyFolder = "E:\Folder"
For Each filename In Worksheets("Sheet1").Range("A2:A" & lastRow)
MyFile = MyFolder & "\" & filename
If Not FileExists(MyFile) Then
filename.Interior.Color = vbRed
End If
Next
End Sub
Public Function FileExists(strFullpathName As String) As Boolean
If Dir(strFullpathName) <> "" Then
FileExists = True
Else
FileExists = False
End If
End Function
You can output a list of the files that are contained in the folder. I found a really helpful tutorial on that here: http://software-solutions-online.com/2014/03/05/list-files-and-folders-in-a-directory/#Jump1
If you then loop through both the original and the output lists and look for a match. Easiest is to first colour them all red, and un-colour the matches. Else you would need an additional if-statement that states: When you reach the last element in the original list, and no match has been found, then colour red.
Edit: For continuity's sake I copied the code bits of the link I mentioned above:
Getting all file names form within 1 folder:
Sub Example1()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("D:StuffFreelancesWebsiteBlogArraysPics")
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 1) = objFile.Name
'print file path
Cells(i + 1, 2) = objFile.Path
i = i + 1
Next objFile
End Sub
I am new to excel. I need to create a new excel from the macro written and need to add some data and save it as a csv file. I am getting Application defined or Object defined error. Her is the code
Sub splitIntoCsv()
Dim wbIn
Dim wbIn1 As Workbook
Dim header As Variant
Set wbIn = CreateObject("Excel.Application")
wbIn.Workbooks.Add
'wbIn.Worksheets(1).Name = "TestData"
'Set wbIn1 = Workbooks.Open(Sheet1.Range("b25").Value, True, False)
header = Split(ThisWorkbook.Sheets(1).Range("B2").Value, ",")
For k = 1 To 10
DoEvents
Next k
For i = LBound(header) To UBound(header)
'MsgBox header(i)
**wbIn.Worksheets(1).Range("a" & i).Value = header(i)**
Next i
wbIn.Worksheets(1).SaveAs Filename:="D:\file.csv" & Filename, FileFormat:=xlCSV, CreateBackup:=False
End Sub
I got the error at the Starred lines.Help needed,
Thanks in advance,
Raghu.
The following code now work, Please have a look
Sub splitIntoCsv()
Dim wbIn As Excel.Application
Dim wbIn1 As Workbook
Dim header As Variant
Set wbIn = CreateObject("Excel.Application")
Set wbIn1 = wbIn.Workbooks.Add
header = Split(ThisWorkbook.Sheets(1).Range("B2").Value, ",")
For k = 1 To 10
DoEvents
Next k
For i = LBound(header) To UBound(header)
'**wbIn1.Worksheets(1).Range("a" & i).Value = header(i)**
Next i
wbIn1.SaveAs Filename:="D:\file.csv" & Filename, FileFormat:=xlCSV, CreateBackup:=False
wbIn1.Close
Set wbIn1 = Nothing
wbIn.Application.Quit
Set wbIn = Nothing
End Sub
The first problem in the code was that you were trying to save using the worksheets. Worksheets do not have a save method, Workbooks do.
While fixing the code, I had a large number of excel objects in memory. Please have a look at how to close and exit a excel application.
For the starred line you asked about, note that the Split function returns a zero-based array, so in your first time through the loop you are trying to refer to cell A0. So, change the line to:
wbIn.Worksheets(1).Range("a" & i+1).Value = header(i)