I have the following excel vba code to get the txt files from a folder and put them into excel.
Sub testfilelistfromfolder()
Dim varDirectory As Variant
Dim flag As Boolean
Dim i As Integer
Dim strDirectory As String
strDirectory = Application.ActiveWorkbook.Path & "\"
i = 1
flag = True
varDirectory = Dir(strDirectory & "*.txt", vbNormal)
Range("B3:B82").Select
Selection.ClearContents
While flag = True
If varDirectory = "" Then
flag = False
Else
Cells(i + 2, 2) = varDirectory
varDirectory = Dir
i = i + 1
End If
Wend
End Sub
so my question is:
Is there a way to list the txt filenames without the .txt extension?
or should I add a line to trim the names?
something like this:
variable = Left(Sheet1.[A1],InStr(Sheet1.[A1],".")-1)
and if so, how should i adapt this to my original code, where should i put it? is it also possible to replace Sheet1 with the active sheet parameter?How?
thank you very much.
I'd tackle is thusly
Else
sStr = InStr(varDirectory, ".txt")
Cells(i + 2, 2) = Left(varDirectory, sStr - 1)
flNAME = Left(Cells(1, 1).Value,Len(Cells(1, 1).Value)-4)
This grabs the Value of the cell indicated and trims the last for characters off. Obviously if it is not a dot with a three letter extension you will have extra characters. For example, .XLSX would leave the dot.
The code is going to assume that you means the cells of the active sheet. If you want to get data from a different sheet then you need to add code to select the new sheet.
I am not sure what you are trying to use if for so it is hard to say where you will need it in your code at.
Related
I am trying to insert a picture into excel based off a cell value. The Cell value is in the image path. I am new, what I have is partially based on recording the macro and part from looking stuff up. This is what I tried...
I keep getting an error on the ActiveSheet.Pictures.Insert line
Sub Part_Picture()
'
' Part_Picture Macro
'
Dim imageName As String
Dim imageFolder As String
Dim imagePath As String
For Each Cell In Range("B7")
imageName = Cell.Value
imageFolder = "Q:\New Project Part Folders\Elizabeth Delgado\Database pictures\Part\" & imageName
imagePath = imageFolder & ".jpg"
Range("B11").Select
'
ActiveSheet.Pictures.Insert(imagePath).Select
Next Cell
End Sub
"Unable to get the insert property of the Pictures class" is a generic error message which you may as well just translate as "Something went wrong with what you're trying to do and I can't give you more information". It's likely though that the path to the image file has not been build correctly.
1) Remove the .Select from your insert statement. Syntactically it makes no sense. Just use ActiveSheet.Pictures.Insert(imagePath)
2) Check the value in cell B7 is the file name only, not including the extension. Since your code adds ".jpg" you dont need that in B7.
3) Check the file is actually a jpg, not for instance a png
4) Check the file / folder actually exists
FYI For Each Cell In Range("B7") is only going to iterate one cell - B7 - and is unnecessary. If you only intended for one cell to be read you should use imageName = Range("B7").Value, or better yet since you need a string use imageName = Range("B7").Text
Consider this option.
Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range
Application.ScreenUpdating = False
fPath = "C:\your_path_here\"
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
i = 1
For Each r In rng
fName = Dir(fPath)
Do While fName <> ""
If fName = r.Value Then
With ActiveSheet.Pictures.Insert(fPath & fName)
.ShapeRange.LockAspectRatio = msoTrue
Set px = .ShapeRange
If .ShapeRange.Width > Rows(i).Columns(2).Width Then .ShapeRange.Width = Columns(2).Width
With Cells(i, 2)
px.Top = .Top
px.Left = .Left
.RowHeight = px.Height
End With
End With
End If
fName = Dir
Loop
i = i + 1
Next r
Application.ScreenUpdating = True
End Sub
' Note: you need the file extension, such as ',jpg', or whatever you are using, so you can match on that.
Whatever picture name you put in Column A, will be imported into the adjacent cell in, Column B
The .Pictures.Insert("c:\fixedfile.png") asked a fix file name as its parameter. However you may use FileCopy "desiredfile.png", "fixedfile.png" to replace the content of fixedfile.png which then meet your needs.
Below is the code so far
I often times have to check if a Purchase Order has been saved in a directory, there could be hundreds of purchase orders listed in Excel.
As the Workbook changes, so often does the filepath.
As such, I would like to make a function that asks for a cell value that contains a string for the filepath, and then a a cell for the PO #.
I'm a little stumped on how best to past information from the Excel sheet. I need a cell reference for the filepath to the directory, and a cell reference for the PO #.
I've been able to make this work with a subroutine, that is what is posted below. This is the third VBA Program I've worked on, please let me know if there is more legwork I should do before posting this:
Dim directory As String
Dim TempfileName As String
Dim i As Long
Dim x As Long
Sub Check_PO()
x = 2
Application.ScreenUpdating = False
For x = 2 To 673
While Cells(x, 14) = 0
x = x + 1
Wend
i = Cells(x, 14)
TempfileName = "\\network\file\name\here\" & "*" & i & "*.pdf"
directory = Dir(TempfileName, vbNormal)
While directory <> ""
Cells(x, 18) = "Matched"
directory = Dir
Wend
Next x
End Sub
Here's a simple UDF:
Public Function HaveReport(fPath As String, fileName As String)
HaveReport = IIf(Dir(fPath & fileName, vbNormal) <> "", _
"Matched", "Not Matched")
End Function
Usage:
I've looked and found a little help so far but I'm stuggling with the for each logic for this Excel Macro I'm trying to make.
Basically I have 4 columns of data. Column A has the name of something and column D has either TRUE or FALSE.
I would like a macro wired to a button that creates a new text file in a given directory named after the content of Col A but only if Col D in that row is labled as "TRUE".
For example if I have the following.
ColA = Test ColD = TRUE
ColA = Test2 ColD = FALSE
ColA = Test3 ColD = TRUE
I will get 2 text files anmed Test.txt and Test3.txt.
I know I need a for each loop to look through the range of a1-d(whatever number) and then when D = True do a SaveAs I guess??
This is the code I have so far (yes I know it's very incomplete but this is as far as my logic got before hitting a wall).
Dim fileName As String
Dim filePath As String
Dim curCell As Object
Dim hideRange As Range
filePath = "C:\ExcelTest\"
hideRange = Range("D1:D1048576")
fileName = *Content of Cell A from this Row*
For Each Row In Range("A1:D1048576")
IF curCell.value In Range hideRange = "TRUE"
Then curCell.SaveAs fileName & ".txt, xlTextWindows
Any help or even pointing me in the right direction would be great. I searched around a bit for some examples and couldn't find anything that really matched what I wanted to do.
You are pretty close, but you are looping one hell of a lot of cells there.
Here is the code to loop the rows, this stops at the last populated cell in the column.
Sub LoopRows()
dim sht as worksheet
set sht = Thisworkbook.Sheets("Name of Worksheet")
'loop from row 1 to the last row containing data
For i = 1 To sht.Range("A:A").End(xlDown).Row
'check the value in column 4 for this row (i)
If sht.Cells(i, 4).Text = "TRUE" Then
CreateFile sht.Cells(i, 1).Value
End If
Next i
End Sub
For writing the file, to keep it simple it would reference Microsoft scripting runtime and do it as follows:
Sub CreateFile(FileName As String)
Dim fso As New FileSystemObject
fso.CreateTextFile "c:\temp\" & FileName & ".txt", True
End Sub
EDIT
I can't see why you aren't getting a file created, my tests work fine for me on a windows machine.
Can you please try the following code alone in a button and see if it opens a text file?
Dim fso As New FileSystemObject
fso.CreateTextFile "c:\temp\testfso.txt"
Shell "C:\WINDOWS\notepad.exe c:\temp\testfso.txt", vbMaximizedFocus
EDIT 2
Try this, and see if it opens the text file..
Sub CreateFile(FileName As String)
Dim fso As New FileSystemObject
Dim fName as String
fName = "c:\temp\" & FileName & ".txt"
fso.CreateTextFile fName, True
Shell "C:\WINDOWS\notepad.exe " & fName, vbMaximizedFocus
End Sub
What you are looking for is something like this:
Sub test()
Dim filePath As String
filePath = "C:\ExcelTest\"
Dim xRow As Variant
For Each xRow In Range("A1:D100").Rows
If xRow(1, 4).Value = "TRUE" Then
Open filePath & xRow(1, 1) & ".txt" For Output As #1
Write #1, xRow(1, 2), xRow(1, 3)
Close #1
End If
Next
End Sub
While it works without errors, I would not use it as it is right now.
If you have any questions, just ask.
EDIT
I've run some tests and noticed windows prevents me to create files inside specific folders... pls try this as a new sub and run it:
Sub testForText()
Open Environ("AppData") & "\Testing.txt" For Output As #1
Write #1, "dada"
Close #1
Shell "notepad.exe " & Environ("AppData") & "\Testing.txt", vbNormalFocus
End Sub
Then tell me if notepad opens up with "Testing.txt"
Here you have some information regarding my Excel file so you know better my worksheet layout:
it is a normal excel sheet (.xlsx) which starts at row 5 and has many different entries for a table.
Some of this entries are automatically calculated from a function which uses values from cells from the same row.
The document goal is to be a template, so the number of rows containing information may vary depending who is using the template.
Even though the number of rows containing information may vary the functions have to be present at all cells in a column, so whenever someone places a new entry to the table it is automatically calculated.
The formulas are all of them like this: " = if ( #cellvalue <> ""# ; #dosomething# ; #""#) ", which mainly places an empty string if no value is present in a cell, and does someting else if a value is entered.
The template will be cell protected, so only some cells would be able to be modified.
During the last days I've been trying to implement a Button for excel which does the following things on click:
Detect which rows contain table entries, but discarting the rows which contain no manually entered values and may only contain the function stated on the previous paragraph. The table always start at raw 5 but might end at row 50 or 60 or whenever the person who uses it stops to manually enter new entries to the table. It is possible that only the row 5 contains information, but it can never happen that any entry is present in the table.
Create a new ".csv" file, containing only the previously selected rows, on the same folder as the ".xlsx" file which is being used as a template. The ".csv" file name must be the same as the ".xlsx" file, but appending some information present in some specific cells (for example information present in cell A1, B1, A3, C3). The information to be appended will always be string text which will never come from a function output but from manually entered by the keypad. It could be that some of this cells contain no information (empty strings such as: "").
The button action should directly save the file in the same directory where the template is without opening a dialog to save the file. The button should also prompt a dialog in case the name being used for the ".csv" file already exists as a "filename.csv" file in the same folder. This prompted dialog should ask if you would like to overwrite the existing file with the same name with the new one.
Written without Excel on my current PC so you'll need to tinker a bit but something like this:
' Rows that contain entries:
' assuming data is in column A (i.e. col 1)
Dim rowHolderArray() as long
Dim lastRow as long
lastRow = range("A65000").End(xlUp).Row
Redim rowHolderArray(lastRow)
For x = 1 to lastRow
If cells(x,1) <> "" then rowHolderArray(x) = x
next x
2) to populate the csv, create it using the AddWorkbook method then do something like:
Dim rowCounter as long
rowCounter = 1
For x = 0 to UBound(rowHolderArray) - 1
If rowHolderArray(x) <> "" then
cells(rowCounter, 1) = rowHolderArray(x)
rowCounter = rowCounter + 1
End if
Next x
3) To save the book use Application.ActiveWorkbook.Path & "/" & yourWorkBook.name & ".xlsx"
Thanks to everyone, finally I could implement what I wanted. Here you have my example code so you can check it:
Private Sub CommandButton1_Click()
Dim i As Boolean
Dim j As Integer
Dim currentworkbook As String
Dim currentpath As String
Dim csvfilename As String
Dim contentrange As Range
Dim researchername As String
Dim projectname As String
Dim aditional_info As String
Dim year As String
Dim month As String
Dim day As String
Dim hour As String
Dim minute As String
Dim WB As Workbook
Application.DisplayAlerts = False
' Calculate which was the last row with information
i = True
j = 12
While i
j = j + 1
If (Application.Cells(j, 2) = "") Then
i = False
j = j - 1
End If
Wend
' Copy the information I wanted to save in a .csv file
Application.Range(Application.Cells(12, 1), Application.Cells(j, 16)).Copy
' Create some variables to manage the path ant some filenames
currentworkbook = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
currentpath = Application.ActiveWorkbook.Path
csvfilename = currentworkbook & "_"
researchername = Application.Cells(1, 2)
projectname = Application.Cells(3, 2)
aditional_info = Application.Cells(5, 2)
year = Format(Now(), "yy")
month = Format(Now(), "MM")
day = Format(Now(), "dd")
hour = Format(Now(), "Hh")
minute = Format(Now(), "Nn")
' Create a new workbook which will be filled with the information copied and then saved as a .csv file.
Set WB = Workbooks.Add
With WB
.Title = "mytitle"
.Subject = "Mysubject"
.Sheets(1).Select
ActiveSheet.Paste
.SaveAs currentpath & "\" & csvfilename & "_" & year & "-" & month & "-" & day & "_" & hour & "h" & minute & "m_" & projectname & "_" & researchername & "_" & aditional_info, xlCSV
.Close
End With
Application.DisplayAlerts = True
End Sub
In the code below I could wrote a code to display filenames from a folder. The problem is now that I should display them in the correct Row. For now they are displayed in random sequence and that is not the purpose.
In column "A" the filenames to search for are called with similar name format PBM12.T5.103.
The actual filename to find is called with similar name format 1_29_PBM_12_T5__103.
I have to find a solution to compare "only" the Fat marked letters and numbers like displayed here above, without . or _
As you will see PBM12T5103 is returning in both namestructures.
Please don't try fixed length counts because the filenames are dynamic and the amount of letters are variable. The comparison of the SUBSTITUTED length of column "A" ( PBM12T5103) is the key to comparison but I can not handle to establish this comparison.
When the filename in column "A" has been found, in column "C" the full filename of found file has to be displayed as the original format 1_29_PBM_12_T5__103
Maybe a solution can be found when extra columns can be made to establish the comparison?
In Excel I could approach a solution, but this will not work automized like it should do.
I made the LEN(count dynamic), but this is still no solution to display the full filenames in the required row...
Hopefully somebody can help me out ..
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 an IF statement in order to compare the filenames written in column "A" with files from folderPath C:\"
'When the correct files is found it should be displayed in column "C"
If
then
Cells(j, 34).Value = fso.GetBaseName(fil.path)
End If
'count behaviour
j = j + 1
Next
Columns("AH").AutoFit
End Sub
I will suggest you different way of getting file names. Instead of FileSystemObject let's use simple Dir function which allows to check the pattern of file name.
1) Files in my testing folder are as follows
2) I assumed that file pattern is as follows:
XXXY.Z.W
where:
XXX > 3 letters text
Y > any length number/text
Z > any length number/text
W > any length number/text
3) The code of subroutine is placed in 2013-06-01...xlsm file which you could see in the pic above (the same folder where your files are). Code is as follows (change where appropriate):
Sub solution()
Dim j As Long, LastRow As Long
Dim fldPath
'your path below
fldPath = ThisWorkbook.Path
ChDir fldPath
Dim arrPattern As Variant
Dim filName As String
For j = 1 To Range("A1").End(xlDown).Row
arrPattern = Split(Cells(j, "A"), ".")
'I suggest to use different way of checking _
pattern of file name. Pattern rules:
'*YYY*XX*Z*W*
filName = Dir("*" & Left(arrPattern(0), 3) & "*" & _
Mid(arrPattern(0), 4) & "*" & _
arrPattern(1) & "*" & _
arrPattern(2) & "*")
If Len(filName) > 0 Then
Cells(j, "B") = filName
Else
Cells(j, "B") = "not found"
End If
Next j
End Sub
4) results are presented in the picture below: