Code error - Saving CSV file asking to overwrite - vba

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.

Related

How to open a new workbook and add images with VBA?

I'm trying to get a macro for Excel 2007to open a folder with a bunch of images in them. Then Create a new workbook and embed the images into it.
Everything works if I comment out the line Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310 If I uncomment that line I get "Run-time error '434': Object required"
I've check that Sheet.Shapes is returning a Shapes object, it is but the Shapes object is empty. When I try Sheet.Shapes,AddPicture on a workbook that is opened outside of the macro, it adds the images. I've also checked that Sheet.Shapes.AddShape works with the workbook opened in the macro, it does.
At this point, I'm at a lose for what the issue might be. Does anyone have any experience with this sort of thing? Should I be using a different method? Thanks in advance for any help or guidance.
Sub Macro1()
Dim ImagePath, Flist
ImagePath = GetFolder()
If ImagePath = "" Then Exit Sub
Flist = FileList(ImagePath)
Name = "C:\target.xlsm"
Set Book = Workbooks.Add
Set Sheet = Book.Sheets(1)
For i = 1 To 5
cell = "C" + CStr(i)
F = ImagePath + "\" + Flist(i - 1)
Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310
Next
Book.SaveAs FileName:=Name, FileFormat:=52
Book.Close
End Sub
Function FileList(ByVal fldr As String) As Variant
'Lists all the files in the current directory
'Found at http://www.ozgrid.com/forum/showthread.php?t=71409
Dim sTemp As String, sHldr As String
If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
sTemp = Dir(fldr & "*.png")
If sTemp = "" Then
FileList = False
Exit Function
End If
Do
sHldr = Dir
If sHldr = "" Then Exit Do
sTemp = sTemp & "|" & sHldr
Loop
FileList = Split(sTemp, "|")
End Function
Function GetFolder() As String
Folder:
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "New Screenshot Folder"
.Show
num = .SelectedItems.Count
If .SelectedItems.Count = 0 Then
GetFolder = ""
Else: GetFolder = .SelectedItems(1)
End If
End With
End Function
You can't define a cell by creating the string "C1", that's just the address. The way you did it, cell is a string and a string doesn't have any properties. What you want is a range object so either use
Dim cell As Range
Set cell = sheet.Range("C" & i)
or
Dim cell As Range
Set cell = sheet.Cells(i, 3)
You should always Dim all variables, use Option Explicit on top of your module so you don't forget it ;)
This will often prevent mistakes. Of course you should Dim them with the correct type, i.e. Dim FilePath As String.
The correct command would be:
Sheet.Shapes.AddPicture Filename:=F, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=Range(cell).Left + 5, Top:=Range(cell).Top + 5, Width:=560, Height:=310
I strongly advise you to change your Name variable name, as it will cause errors on recent versions of excel.

VBA User Function Checking a Directory

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:

Pull latest workbook copy selected workbook and paste in master workbook

I am trying to look in a folder to pull the latest workbook by date, open the workbook up as my src data, copy the selected worksheet and data from src and then paste to my master workbook. Finally closing the src workbook without saving any change. I'm having issues on where I should place my file paths and filenames.
Function NewestFileName(ByVal path As String, ByVal FileTemplate As String) As String
Dim FileDateCrnt As Date
Dim FileDateNewest As Date
Dim FileNameCrnt As String
Dim FileNameNewest As String
If Right("G:\AOC\GROUPS1\SAC\TEST", 1) <> "\" Then
path = "G:\AOC\GROUPS1\SAC\TEST" & "\"
End If
FileNameCrnt = Dir$("G:\AOC\GROUPS1\SAC\TEST" & Book1.xlsx)
If FileNameCrnt = "Book1.xlsx" Then
NewestFileName = "Book2.xlsx"
Exit Function
End If
FileNameNewest = FileNameCrnt
FileDateNewest = FileDateTime("G:\AOC\GROUPS1\SAC\TEST" & FileNameCrnt)
Do While True
FileNameCrnt = Dir$
If FileNameCrnt = "" Then Exit Do
FileDateCrnt = FileDateTime(path & FileNameCrnt)
If FileDateCrnt > FileDateNewest Then
FileNameNewest = FileNameCrnt
FileDateNewest = FileDateCrnt
End If
Loop
NewestFileName = FileNameNewest
Call ReadDataFromCloseFile
End Function
Sub ReadDataFromCloseFile()
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim src As Workbook
Set src = Workbook.Open("G:\AOC\GROUPS1\SAC\TEST.xlsx", True, True)
Dim iTotalRows As Integer
iTotalRows = src.Worksheets("sheet1").Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
Dim iCnt As Integer
For iCnt = 1 To iTotalRows
Worksheets("sheet1").Range("B" & iCnt).Formula = src.Worksheets("sheet1").Range("B" & iCnt).Formula
Next iCnt
src.Close False
Set scr = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
First things first:
If you have a question or encounter an error, then spell it out. It's hard to find out where your error is, without knowing on which line it occurs.
Your function in a whole doesn't make that much sense. For taking a good look at it, commenting would've been very helpful.
Let's go through your code step by step:
If Right("G:\AOC\GROUPS1\SAC\TEST", 1) <> "\" Then
path = "G:\AOC\GROUPS1\SAC\TEST" & "\"
End If
This if-condition will always trigger, because the String you put in there, is always the same and it'll always miss the "\".
So if your path doesn't change then you can change that to path = "G:\AOC\GROUPS1\SAC\TEST\"
FileNameCrnt = Dir$("G:\AOC\GROUPS1\SAC\TEST" & Book1.xlsx)
If FileNameCrnt = "Book1.xlsx" Then
NewestFileName = "Book2.xlsx"
Exit Function
End If
I'm not sure what you are trying to do here. You are setting FileNameCrnt to a string in the first line (you are missing the "\" btw). I guess "Book1.xlsx" is the real name of your workbook, so your String should look either like this: "G:\AOC\GROUPS1\SAC\TEST\Book1.xlsx" or you could do something like this
fileName = "Book1.xlsx"
FileNameCrnt = Dir$("G:\AOC\GROUPS1\SAC\TEST" & fileName )
Next: You would(!) always exit the function there, if the line above would work. You set FilenameCrnt to Book1.xlsx, then check it via an if-clause, the check will always return true, afterwards you'd always exit.
I get the idea of your loop, but it too is broken. Start by changing this: If FileNameCrnt = "" Then Exit Do to something else. Your variable will never be empty so your loop will always cause a runtime error. Start changing the first parts of your function and get to that later. I think you will have a better idea how all this should work. And it's always better to try solving some things by yourself. ;)
EDIT:
It's always helpful to make a flow chart on how your program should run.
Something like:
Get my current filename
Get date of my current file
Check if there is a newer file (a file with a higher date than my old
date)
Get dates of all files (loop through all files)
GET highest date
Compare highest date to date of my current file
if there is a file with a higher date, update current filename to filename with higher date
HTH

VBA issue with operators

I am facin strange problem looks like = is not working as it should be. I got code below:
Dim lineText As String
For Each p In WordDoc.Paragraphs
lineText = p.Range.Text
If lineText = "" Then GoTo Dalej
.....
even if i do:
lineText = ""
If lineText = "" Then GoTo Dalej
its not going to Dalej but going next. Looks like its not problem with code but with operators i got similar problem with <>. I tried to workaround tht with InStr or StrComp but its doing completly not as it should be like something inside excel has been changed with application itself. Do you have any idea what this could be?
This is full code:
Sub Sprawdz_Pola_Korespondencji_Click()
Application.ScreenUpdating = True
Dim RowNr As Integer
Dim EWS As Worksheet
RowNr = 30
Set EWS = Sheets("Arkusz do wypełnienia")
Dim FileName As Variant, wb As Workbook
FileName = Application.GetOpenFilename(FileFilter:="Word File (*.docx),*.docx", Title:="Select File To Be Opened")
If FileName = False Then Exit Sub
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Set WordDoc = WordApp.Documents.Open(FileName)
Dim p As Paragraph
If lineText = "" Then GoTo Dalej
If InStr(lineText, PoleExcel) Then
EWS.Cells(5, X).Interior.ColorIndex = 18
Else
EWS.Cells(5, X).Interior.ColorIndex = 3
End If
Dalej:
Next p
Nastepna:
Loop Until EWS.Cells(RowNr, X) = "KONIEC"
'EWS.Activate 'WordDoc.Activate '<============================================================
WordDoc.Close savechanges:=False 'or false
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
Public Function ReplaceSpaces(strInput As String) As String
' Replaces spaces in a string of text with underscores
Dim Result As String
Result = strInput
If InStr(strInput, " ") > 0 Then
Result = Replace(strInput, " ", "_")
End If
ReplaceSpaces = Result
End Function
You need to write:
Next p
Dalej:
instead. (i.e. switch round the Next p and Dalej:). Currently the label is inside the for loop.
But, it would be far better to use Exit For instead of the GoTo. Doing this means you don't need to maintain a label.
GoTo statements are notoriously brittle.
To strip out the CR do this:
lineText = replace(lineText, chr(13), "")

how to remove the extension of a found file FSO?

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