How to Create Folder, File, and Save File in Folder - excel

EDIT: Wasn't clear enough with my question
Sub NewWB2()
Dim wb As Workbook
Dim POname As String
Dim lrow As Long
Dim NewfolderPath As String
lrow = Cells(Rows.Count, 3).End(xlUp).Row
POname = Worksheets("Sheet1").Cells(lrow, 10).Value 'name I want for both the folder and the document
MkDir "C:\Users\First.Last\Desktop" & "\" & POname 'creates the folder in the path I want
NewfolderPath = "C:\Users\First.Last\Desktop\" & POname ' variable to define that path
Set wb = Workbooks.Add("C:\Users\First.Last\Documents\Custom Office Templates\PO Template.xltm") ' creates from template
ActiveWorkbook.SaveAs Filename:=POName 'Saves file as variable "POname"
End Sub
Everything here works. All I need to do is to add a line of code that will save the new workbook in the folder I've created. I can't find how to do this and don't know how to add this in.

Try with this, guess you are missing your Filename:
ActiveWorkbook.SaveAS Filename:=NewfolderPath & "\" & POname & "\Filename"
if you are using a Variable for your filename try:
ActiveWorkbook.SaveAS Filename:=NewfolderPath & "\" & POname & "\" & Filename

Can you provide a string example of POname that you are using?
I think you missed a '\' in NewfolderPath:
Try:
Sub NewWB2()
Dim wb As Workbook
Dim POname As String
Dim lrow As Long
Dim NewfolderPath As String
lrow = Cells(Rows.Count, 3).End(xlUp).Row 'finds the last row
POname = Worksheets("Sheet1").Cells(lrow, 10).Value 'name of Folder and File
NewfolderPath = "C:\destinationfoldername\" & POname
MkDir NewfolderPath 'creates the new folder with the name defined above
Set wb = Workbooks.Add("C:\folderwithtemplate\Template.xltm") 'creates new wb from template
ActiveWorkbook.SaveAs NewfolderPath & "\" & POname
End Sub

Related

Change(some)Link(s) Name(s) of Active Workbook VBA

So, I renamed and moved some workbooks that are linked together and I need to update their xlExcelLinks on VBA, the thing is, I have a list of the references to update, but I can't figure out how to update only the ones I need and not every reference on the book.
The initial idea was to search for matching strings between a file name and the stored reference's path. Example data:
A2 Cell on Data.xlsx
Change to
I have this guide example code:
Sub Relink()
Dim previousFile, newFile, oldPath, newPath, Macro, altTab As String
'Macro stores the name of the file running the macro and altTab the name of the file to update
Dim ref as xlExcelLink 'Clearly not a type of data but I need something similar
Windows(Macro).activate
For I = 2 To 4
oldPath = Range("L"& I).Value
newPath = Range("M" & I).Value
previousFile = Range("N" & I).Value
newFile = Range("O" & I).Value
Windows(alTab).activate
'Somehow check for every reference avoiding itself
If ref.Address = oldPath & "\" & previousFile Then
ActiveWorkbook.ChangeLink Name:=oldPath & "\" & previousFile, _
NewName:=newPath & "\" & newFile, Type:=xlExcelLinks
End If
Next
End Sub
Note that on some files there could be only 1 update needed from 50ish references.
Try this code:
Sub UpdateLinks()
'Reference to your change list.
'ThisWorkbook is the file containing this code.
Dim ChangeList As Range
Set ChangeList = ThisWorkbook.Worksheets("Sheet2").Range("A2:D4")
'The workbook containing the links to change.
Dim wrkBk As Workbook
Set wrkBk = Workbooks("Test Timesheet.xlsx")
'If workbook isn't open use:
'Set wrkbk = workbooks.Open(<path to workbook>)
'Look at each link in the workbook.
'lnk must be Variant so it can be used in the For Each loop.
Dim lnk As Variant
For Each lnk In wrkBk.LinkSources
Dim OldPath As String
OldPath = Left(lnk, InStrRev(lnk, "\") - 1)
Dim OldFileName As String
OldFileName = Mid(lnk, InStrRev(lnk, "\") + 1, Len(lnk))
'Search for the existing path in first column of ChangeList.
Dim FoundLink As Range
Set FoundLink = ChangeList.Columns(1).Find(OldPath, , xlValues, xlWhole, xlByRows, xlNext)
'If it's not found, then continue to the next link.
'If it is found check that OldName also exists on that line, if it doesn't then continue searching.
If Not FoundLink Is Nothing Then
Dim firstAdd As String
firstAdd = FoundLink.Address
Do
If FoundLink.Offset(, 2) = OldFileName Then
'Found the link we're after so exit the loop.
Dim NewPath As String
NewPath = FoundLink.Offset(, 1)
Dim NewFileName As String
NewFileName = FoundLink.Offset(, 3)
Exit Do
Else
'Continue searching.
Set FoundLink = ChangeList.Columns(1).FindNext(FoundLink)
End If
Loop While firstAdd <> FoundLink.Address
'Make the change.
wrkBk.ChangeLink Name:=OldPath & Application.PathSeparator & OldFileName, _
NewName:=NewPath & Application.PathSeparator & NewFileName
End If
Next lnk
End Sub

ExcelVBA: SaveCopyAs won't allow edits to new Workbook

I'm attempting to create code that allows me to edit a workbook, create multiple copies, then edit those copies and save them. I'm hoping someone can talk me through the logic here because I've tried everything I can think of more than once.
Sub RemoveViolations()
Dim fBook As Workbook
Dim fBook2 As Workbook
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
fName = ActiveWorkbook.Name
fSheet = ActiveSheet.Name
fPath = ActiveWorkbook.Path
Set fBook = ActiveWorkbook
For Each c In ActiveSheet.Range("B4:B" & LastRow)
c = UCase(Trim(c.Value))
fName2 = Replace(fName, "swpaSumRPT-", "swpaSumRPT-" & c & "-")
fBook.ActiveSheet.Range("A3:L3").AutoFilter , field:=2, Criteria1:="<>" & c, Operator:=xlFilterValues
If fBook2 Is Nothing Then fBook.SaveCopyAs fPath & "\" & fName2
Set fBook2 = Application.Workbooks.Open(fPath & "\" & fName2)
MsgBox (ActiveWorkbook.Name)
Next c
End Sub
I'm not sure why I can't keep running the code from the original document after the new copy workbook is opened and activated. I've seen examples of others doing this and I THOUGHT I had properly followed the instructions. It appears that once the new workbook is open, the code stops running. I'm hoping you can help me understand.
I'm not toatlly sure what you want to do, but you can try the code below.
If you have more than one workbook open and you want to save all the workbooks, if you want to save all open workbooks, you can use the code below:
Sub SaveAllWorkbooks()
Dim wb As Workbook
For Each wb In Workbooks
wb.Save
Next wb
End Sub
Notice the Dim wb As Workbook. You should specifically reference all objects. Also, make sure everything is managed in the same instance of Excel that you are working with. As I know, a new instance of Excel can't 'see' a current instance of Excel. Check out the ink below when you have some free time.
https://trumpexcel.com/vba-workbook/
Try this adapted code, please:
Sub RemoveViolations()
Dim fBook As Workbook, fBook2 As Workbook, lastRow As Long, fName As String, strC As String
Dim c As Range, fSheet As String, fPath As String, fName2 As String, justName As String
lastRow = ActiveSheet.cells(ActiveSheet.Rows.count, "A").End(xlUp).row
fName = ActiveWorkbook.name
fSheet = ActiveSheet.name
fPath = ActiveWorkbook.Path
Set fBook = ActiveWorkbook
For Each c In ActiveSheet.Range("B4:B" & lastRow)
strC = UCase(Trim(c.Value))
'________________________________________________________________________
justName = Split(fName, ".")(0)
fName2 = Replace(justName, "swpaSumRPT-", "swpaSumRPT-" & strC & "-")
fName2 = fName2 & "." & Split(fName, ".")(1)
'________________________________________________________________________
fBook.ActiveSheet.Range("A3:L3").AutoFilter , field:=2, Criteria1:="<>" & c.value, Operator:=xlFilterValues
If fBook2 Is Nothing Then fBook.SaveCopyAs fPath & "\" & fName2
Set fBook2 = Application.Workbooks.Open(fPath & "\" & fName2)
MsgBox (ActiveWorkbook.name)
Set fBook2 = Nothing
Next c
End Sub
Take 2 steps, copy the files and then open them. This avoids changing the active workbook inside your loop.
Option Explicit
Sub RemoveViolations()
Dim fbook As Workbook, fbook2 As Workbook, ws As Worksheet
Dim c As Range, lastRow As Long
Dim fname As String, fname2 As String
Dim fpath As String, s As String
Dim copies As New Collection
Set fbook = ActiveWorkbook
Set ws = fbook.ActiveSheet
fname = fbook.Name
fpath = fbook.Path
lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row
' make copies and store name in a collection
For Each c In ws.Range("B4:B" & lastRow)
s = UCase(Trim(c.Value))
fname2 = Replace(fname, "swpaSumRPT-", "swpaSumRPT-" & s & "-")
'Debug.Print s, fname2
ws.Range("A3:L3").AutoFilter , field:=2, Criteria1:="<>" & c, Operator:=xlFilterValues
fbook.SaveCopyAs fpath & "\" & fname2
copies.Add fname2
Next c
ws.Range("A3:L3").AutoFilter ' remove
' open workbooks and delete visible rows
If MsgBox(copies.Count & " copies made. Do you want to open/edit them all ?", vbYesNo, "Confirm Open") = vbYes Then
Dim obj, rng As Range
For Each obj In copies
Set fbook2 = Application.Workbooks.Open(fpath & "\" & obj)
' avoid header 3 rows
Set rng = fbook2.ActiveSheet.UsedRange.Offset(3)
' delete visible rows
rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
fbook2.ActiveSheet.Range("A3:L3").AutoFilter ' remove filter
Next
End If
End Sub

Excel VBA Do While loop in a directory folder and rows count

I have 2 questions with my coding. Please bear with me since I'm not an expert on this.
Ws2.range("B6:Y" & lrow1).copy - doesn't seem to work the way I wanted it to be. It copies cells only from B1:Y6 but the intention is to copy cells starting ffrom B6:Y until the last row.
Dir Do while loops only on one file even though I have multiple files on the specified folder path. Thus, creating an infinite loop.
Any idea on what am I doing wrong?
Private Sub conso()
Dim folder As String, consofolder As String
Dim files As String, consofile As String
Dim dateyear As String, team As String
Dim strfile As String, newdate As String
Dim wb1 As Workbook, wb2 As Workbook
Dim lrow1 As Long, lrow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
dateyear = Range("A2").Value
newdate = Format(dateyear, "mmmm yyyy")
team = Range("B2").Value
folder = Range("C2").Value
consofolder = folder & newdate & "\" & team
consofile = "conso "
files = Dir(consofolder & "\*.xlsm")
strfile = consofolder & "\" & consofile & team & " - " & newdate & ".xlsm"
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.AutomationSecurity = msoAutomationSecurityLow
Workbooks.Open Filename:=folder & "\" & "conso conso" & ".xlsm"
Set wb1 = Workbooks("conso conso.xlsm")
wb1.Activate
Set ws1 = wb1.Worksheets("Input")
If Len(Dir(strfile)) = 0 Then
GoTo conso
Else
MsgBox "Conso already in place"
Exit Sub
End If
conso:
Do While files <> ""
Debug.Print files
Workbooks.Open Filename:=consofolder & "\" & files
Set wb2 = Workbooks(files)
Set ws2 = wb2.Worksheets("Input")
With wb2
With Worksheets("Input")
lrow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
End With
ws2.Range("B6:Y" & lrow1).Copy
wb1.Activate
With wb1
With Worksheets("Input")
lrow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
End With
ws1.Range("B" & lrow2).PasteSpecial
wb2.Close
files = Dir(consofolder & "\*.xlsm")
Set wb2 = Nothing
Loop
End Sub

Hyperlink a newly added cell value from a closed workbook

I can't seem to relate the discussion of this topic on this forum.
I have code here that uses hyperlink function but doesn't work.
I have a workbook opened at runtime docname that serves as a database.
And wbSource as current open workbook.
wbSource will send a cell value to docname and has to be converted into hyperlink.
path is the directory
Dest destination folder inside path
wb.Cells(BB + 2, 2) is the receiver. The file the hyperlink has to open is created almost the same time the link was created ( the line with the saveas command).
Set wb = Workbooks(DocName).Sheets("Sheet1")
Set wbs = Workbooks(wbSource).Sheets("MACRO")
Dim BB As Integer
wb.Cells(1, 1) = "=counta(B:B)"
BB = wb.Cells(1, 1)
wbNew = InputBox("Enter the 'Mold Number' or 'Part Name' here", "FileName")
ActiveWorkbook.SaveAs FileName:=Path & "\" & DesT & "\" & "RFQ Details_" & wbNew
Open wbNew For Output As #1
Close #1
wb.Cells(BB + 2, 2) = Hyperlink(Path & "\" & DesT & "\" & "RFQ Details_" & wbNew) 'THIS PART DOES NOT WORK!
Everything is working pretty fine except the last line.
I feel somethings really missing on that last part.
Tip: Whenever you are in doubt, if MS Excel lets you, record a macro and simply edit it.
I am assuming that you have valid values for BB, Path, Dest and DocName
Is this what you are trying?
Dim completePath As String
completePath = Path & "\" & DesT & "\" & "RFQ Details_" & wbNew
Set ws = Workbooks(DocName).Sheets("Sheet1")
Set rng = ws.Cells(BB + 2, 2)
rng.Hyperlinks.Add Anchor:=ws.Range(rng.Address), _
Address:=completePath, _
TextToDisplay:=completePath
Tested it with the below sample values and it works :)
Sub Sample()
Dim wb As Workbook
Dim ws As Worksheet
Dim BB As Long: BB = 1
Dim rng As Range
Dim Path As String, DesT As String, wbNew As String
Dim completePath As String
'~~> Sample Values
Path = "C:\Users\routs\Desktop"
DesT = "test"
wbNew = "Sample.xlsx"
DocName = ThisWorkbook.Name
Set wb = Workbooks(DocName)
Set ws = Workbooks(DocName).Sheets("Sheet1")
Set rng = ws.Cells(BB + 2, 2)
completePath = Path & "\" & DesT & "\" & "RFQ Details_" & wbNew
rng.Hyperlinks.Add Anchor:=ws.Range(rng.Address), _
Address:=completePath, _
TextToDisplay:=completePath
End Sub
I don't know why that did not work, but mine works, could you try this:
worksheets("Sheet1").hyperlinks.add _
anchor:=range("A1"), _
address:="https://9gag.com", _
texttodisplay :="9Gag"
Edited Code:
wb.Hyperlinks.Add _
anchor:=Cells(BB + 2, 2), _
Address:=(Path & "\" & DesT & "\" & "RFQ Details_" & wbNew), _
TextToDisplay:=Cells(BB + 2, 2)

How do I transfer .pdf files from one folder to another based of a condition in an excel file using a macro?

To go into more detail:
I have an excel file containing a bunch of part numbers. I'd like to make a macro so that if a column is equal to "YES" then search the "Specs" folder for the specifications . pdf which matches the part number in the excel sheet and then copy the .pdf in that folder to the destination folder or "Dest" folder.
UPDATED CODE Trying to understand the Loop logic what I'm looking to go through
Sub Rectangle1_Click()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim OldPath As String, NewPath As String
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
'~~> File location
OldPath = "C:\Users\bucklej\Desktop\Spec\"
NewPath = "C:\Users\bucklej\Desktop\Dest\"
'~~> This is the workbook from where the code is running
Set ws = ThisWorkbook.Sheets("Specification Listing")
'~~> Loop through Col A
For i = 1 To 1000
Cells(i, 2).Value = Yes
Next i
fso.CopyFile(OldPath, Newpath)
End Sub
No Need to use DIR and then splitting the file name. Here is a much faster way.
Try this (Tried And Tested)
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim OldPath As String, NewPath As String
OldPath = "C:\Users\bucklej\Desktop\Test1\"
NewPath = "C:\Users\bucklej\Desktop\Test2\"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
'~~> If file doesn't exists then that line will be ignored
On Error Resume Next
LoopFile = .Range("A" & i).Value & ".txt"
Name OldPath & LoopFile As NewPath & LoopFile
LoopFile = .Range("A" & i).Value & ".docx"
Name OldPath & LoopFile As NewPath & LoopFile
LoopFile = .Range("A" & i).Value & ".xlsx"
Name OldPath & LoopFile As NewPath & LoopFile
LoopFile = .Range("A" & i).Value & ".xls"
Name OldPath & LoopFile As NewPath & LoopFile
LoopFile = .Range("A" & i).Value & ".bmp"
Name OldPath & LoopFile As NewPath & LoopFile
On Error GoTo 0
DoEvents
Next i
End With
End Sub

Resources