Another post by me

SFPCFS

New Member
Joined
Feb 7, 2014
Messages
40
Firstly a massive thank you for the help from this forum,

I've been handed the following today as well, which is a little out of my zone, but I am trying to learn it.

I have the following code in a sheet

Code:
[INDENT=2]Option Explicit</SPAN>
Sub copySheet()</SPAN>
    Dim ChangeRequestBooks() As Workbook</SPAN>
           Application.ScreenUpdating = False</SPAN>
   
    ChangeRequestBooks = openFiles()    </SPAN>
    If ChangeRequestBooks(0) Is Nothing Then</SPAN>
              MsgBox "Update Cancelled"</SPAN>
    Else</SPAN>
              processFiles ChangeRequestBooks</SPAN>
        MsgBox "Update Complete"</SPAN>
    End If</SPAN>
   
        Application.ScreenUpdating = True</SPAN>
       End Sub</SPAN>
' Prompts the user for a list of files and returns a referece (in an array) to all the files.</SPAN>
' Opens all the files ready to be processed.</SPAN>
Function openFiles() As Workbook()</SPAN>
    Dim Wb() As Workbook</SPAN>
    Dim i As Long, c As Long</SPAN>
    Dim FilesToOpen As Variant</SPAN>
   
    ' tell the user what we want them to do</SPAN>
    MsgBox "Select workbook(s) to copy.", vbApplicationModal</SPAN>
   
    ' note that if you want to have the open dialogue start in a specific folder then</SPAN>
    ' use ChDrive and ChDir (uncoment following section and update it to the correct path)</SPAN>
    'ChDrive "H:"    ' note that if used on multiple systems the drive letter isn't always the same</SPAN>
    'ChDir "H:\1. Finance Shared Services\FINANCE DATA & MI CHANGE\Financial Risk MI Change\Change Request Forms Recived"    ' is the folder spelt wrong? Recived or Received?</SPAN>
    ' prompt the user with an open dialog</SPAN>
    FilesToOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel (*.xl*),*.xl*", Title:="Please select all change request files required", MultiSelect:=True)</SPAN>
   
       If Not IsArray(FilesToOpen) Then</SPAN>
        ReDim openFiles(0)  </SPAN>
        Exit Function  </SPAN>
    End If</SPAN>
   
           For i = LBound(FilesToOpen) To UBound(FilesToOpen)</SPAN>
        ReDim Preserve Wb(c) ' need to create a space in the array for the file we're about to open</SPAN>
        Set Wb(c) = Workbooks.Open(FileName:=FilesToOpen(i), UpdateLinks:=False, ReadOnly:=True)</SPAN>
            c = c + 1</SPAN>
    Next i
[INDENT=2]openFiles = Wb</SPAN>
End Function</SPAN>
Private Sub processFiles(Wb() As Workbook)</SPAN>
    Dim i As Long</SPAN>
    Dim ws As Worksheet</SPAN>
    Dim SourceRange As range, TargetRange As range</SPAN>
   
        Set ws = ThisWorkbook.Worksheets("SummarySheet")</SPAN>
           Set TargetRange = ws.Cells(ws.Cells.Rows.Count, 2)</SPAN>
           Set TargetRange = TargetRange.End(xlUp)</SPAN>
           Set TargetRange = TargetRange.Cells(2, 1)       </SPAN>
   
    For i = LBound(Wb) To UBound(Wb)</SPAN>
        With Wb(i) </SPAN>
            If .Worksheets.Count >= 2 Then</SPAN>
               Set ws = .Worksheets(2)  </SPAN>
                Set SourceRange = ws.Cells(2, 2) </SPAN>
                Set SourceRange = ws.range(SourceRange, SourceRange.End(xlToRight))</SPAN>
                    SourceRange.Copy</SPAN>
                TargetRange.PasteSpecial xlPasteValues</SPAN>
                Application.CutCopyMode = False</SPAN>
                Set TargetRange = TargetRange.Cells(2, 1)</SPAN>
            Else</SPAN>
                MsgBox "Filename: '" & .Name & "', is missing the sheet we need. Skipping it."</SPAN>
            End If</SPAN>
           
            ' close the file we've finished with it now</SPAN>
            .Close SaveChanges:=False    ' false to not attempt to save changes (and not prompt the user for it)</SPAN>
        End With</SPAN>
    Next i</SPAN>
   
    ' by this point all the files that were opened should be closed and we should be looking at the completed SummarySheet table</SPAN>
End Sub</SPAN>
[/INDENT]
</SPAN>[/INDENT]
Into this I need to add that the sheets the user selects are saved as a PDF to a folder that is named after the cell in column a that is the row it is appended to, in the same location as this log is kept

I've recorded this -


Code:
[INDENT=2]Option Explicit</SPAN>
Sub Macro1()</SPAN>
'</SPAN>
' Macro1 Macro</SPAN>
'</SPAN>
'</SPAN>
    ChDir _</SPAN>
        "H:\1. Finance Shared Services\FINANCE DATA & MI CHANGE\Financial Risk MI Change\Change Request Forms Recived"</SPAN>
    Workbooks.Open Filename:= _</SPAN>
        "Same as above with filename"</SPAN>
    Range("H10:J10").Select</SPAN>
    ChDir _</SPAN>
        "Same as above but with the filename on were its being saved"</SPAN>
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _</SPAN>
        "H:\1. Finance Shared Services\FINANCE DATA & MI CHANGE\Financial Risk MI Change\Change Request Forms Recived\FS & MI 2\Change Request Form.pdf" _</SPAN>
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _</SPAN>
        :=False, OpenAfterPublish:=True</SPAN>
    Range("Q26").Select</SPAN>
    ActiveWindow.Close</SPAN>
End Sub</SPAN>
[/INDENT]

I can recognize the save as section

I'll be putting the publish to false as there could be multiple uploads at the same time so it would slow the process down a little I think.

Could you help me in terms of how I would go about this?

Fully appreciate this is big ask or at least feels like for me I’m afraid

Thank you for any help</SPAN>


And apologies for missing one of the most important rules
</SPAN>​
</SPAN>
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
It looks like (fingers crossed) this is the adjustment needed in Sub ProcessFiles()


Code:
Private Sub processFiles(Wb() As Workbook) 
    Dim i As Long 
    Dim ws As Worksheet 
    Dim SourceRange As range, 
    TargetRange As range 

    Set ws = ThisWorkbook.Worksheets("SummarySheet") 
    Set TargetRange = ws.Cells(ws.Cells.Rows.Count, 2) 
    Set TargetRange = TargetRange.End(xlUp) 
    Set TargetRange = TargetRange.Cells(2, 1) 
    For i = LBound(Wb) To UBound(Wb) 
        With Wb(i) 
            If .Worksheets.Count >= 2 Then 
                Set ws = .Worksheets(2) 
                Set SourceRange = ws.Cells(2, 2) 
                Set SourceRange = ws.range(SourceRange, SourceRange.End(xlToRight)) 
                SourceRange.Copy 
                TargetRange.PasteSpecial xlPasteValues Application.CutCopyMode = False 
                Set TargetRange = TargetRange.Cells(2, 1)


[COLOR="#FF0000"]                ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TargetRange.Cells(1,1), Quality:=xlQualityStandard, _
                                        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False[/COLOR]
 
            Else 
                MsgBox "Filename: '" & .Name & "', is missing the sheet we need. Skipping it." 
            End If ' close the file we've finished with it now 
            .Close SaveChanges:=False  ' false to not attempt to save changes (and not prompt the user for it) 
        End With 
    Next i ' by this point all the files that were opened should be closed and we should be looking at the completed SummarySheet table 
End Sub
 
Upvote 0
Quick update - it worked, but now it errors out

Run-time error '5':

Invalid procedure cell or argument

Not sure why its doing this?
 
Upvote 0
Further testing of this shows the code works but its the part were it creates the folder and saves the file that is failling.

Anyone have any ideas on how to get this to work?

It worked once when I added this code in but its now not doing?
 
Upvote 0
Where in the code are you creating folders?

By the way, why are you opening all the workbooks at the same time?

Wouldn't it make more sense to open each workbook on its isn't, process it, close it and then move onto the next workbook?
 
Upvote 0
I'm not sure as I inherited this vba from a previsou more experinced user, I'm still getting to grips with it, but it seems to be from a user speed and efficency point of view to allow multiple uploads at once.

I've doen some digging and found this thread (http://www.mrexcel.com/forum/excel-...df-macro-using-custom-file-folder-name-3.html) that seems to get close to what I'm looking for as well - though it locks it to a single drive and over anetwork not every user has the same drive letter mapped to each drive.

The code previosuly advised by xenou did work but for whatever reason on reponing on another machine it fails - something it now does on mine.

I have added the code in at the same point as dipicted to do so, so I'm not sure why its no longer working.

How would I adapt this code and fit into the code at the top

Sub Make_PDF()' Create and save .pdfDim pdfName As String, FolderName As String, FullName As StringSheets("Sheet2").Shapes("TextBox 2").TextFrame.Characters.Text = Sheets("Sheet1").Shapes("TextBox 1").TextFrame.Characters.TextpdfName = Range("B7").TextFolderName = Range("H17").TextIf Not DirExists("D:\Invoices\" & FolderName) Then MkDir "D:\Invoices\" & FolderNameFullName = "D:\Invoices\" & FolderName & "\" & pdfName & ".pdf"If MsgBox("Please confirm that name and location is correct: " & FullName & ". - " & " Is it correct?", vbYesNo + vbQuestion, "Confirm File Name and Location") = vbNo Then Exit SubActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FullName _, Quality:=xlQualityMedium, IncludeDocProperties:=False, _IgnorePrintAreas:=False, OpenAfterPublish:=TrueYesNo = MsgBox("Would you like to open the folder where the invoice was saved?" _, vbYesNo + vbQuestion, "Open Folder?")Select Case YesNoCase vbYesmyval = Shell("explorer D:\Invoices\" & FolderName, 1)Case vbNoEnd SelectEnd SubFunction DirExists(sSDirectory As String) As BooleanIf Dir(sSDirectory, vbDirectory) <> "" Then DirExists = TrueEnd Function
</PRE>
to deal with a none fixed drive letter - I'd like it to just work in the folder where the sheet is - irrespective of drive location
 
Last edited:
Upvote 0
I believe this is your code. Let's make it readable.
Code:
Sub Make_PDF()
' Create and save .pdf
Dim pdfName As String, FolderName As String, FullName As String

Sheets("Sheet2").Shapes("TextBox 2").TextFrame.Characters.Text = _
    Sheets("Sheet1").Shapes("TextBox 1").TextFrame.Characters.Text

pdfName = Range("B7").Text
FolderName = Range("H17").Text

If Not DirExists("D:\Invoices\" & FolderName) Then 
    
    MkDir "D:\Invoices\" & FolderNameFullName = "D:\Invoices\" & FolderName & "\" & pdfName & ".pdf"
    If MsgBox("Please confirm that name and location is correct: " & FullName & ". - " & " Is it correct?", _
            vbYesNo + vbQuestion, "Confirm File Name and Location") = vbNo Then
        Exit Sub
    End if
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FullName, _
        Quality:=xlQualityMedium, IncludeDocProperties:=False, _
        IgnorePrintAreas:=False, OpenAfterPublish:=True
    
    YesNo = MsgBox("Would you like to open the folder where the invoice was saved?" _
                    , vbYesNo + vbQuestion, "Open Folder?")
    Select Case YesNo
         Case vbYes
            myval = Shell("explorer D:\Invoices\" & FolderName, 1)
         Case vbNo
    End Select
End Sub


Function DirExists(sSDirectory As String) As Boolean
    If Dir(sSDirectory, vbDirectory) <> "" Then DirExists = True
End Function


This line looks extremely fishy:
Code:
   MkDir "D:\Invoices\" & FolderNameFullName = "D:\Invoices\" & FolderName & "\" & pdfName & ".pdf"

Probably should be:
Code:
     MKDir D:\Invoices\" & FolderName


Note: I was assuming it was your code but if it's code you just found on the internet it's probably not going to work for you (though as written I doubt it works at all).
 
Upvote 0
It's difficult to debug code that saves files and uses data from worksheet cells. We would need to know what is in the cells. My first concern would be about the file names you are creating with the code: are they valid? do the folders exist? Are there drive letters and if so are they mapped?
 
Upvote 0
Hi

Its not my code, I found it in the thread I mentioned - I currently have the peice in that was written by yourself.

The folder doesn't exsist I need the vba to make the folder - yours did on the first run, but for what ever reason its not now.

The cell it needs to take its value from for the folder name has the following formula in - =CONCATENATE("FS & MI ",IF(B6=COUNTA(B6)*1,"",ROW()-5)," ",N6) - this is to make a unique referance for the work being logged

Not sure why it worked first time and doesn't now?

Hope this is do able?

In answer to your questions at the end there

1 - The folders don't exsist, as I want the vba to create them in the same folder were this sheet is using a value in the master log in colum A (starting at A6) that is the same one as were the data is uploaded to for example the data is in row 7, use cell a7 for folder title

2 - There are drive letters and they are mapped, however it is not the same for all users on the network, mine is h, but this is not the case for the other users

Thank you for the help so far
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,567
Messages
6,114,342
Members
448,570
Latest member
rik81h

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top