Solved

VB Find EXcel File and move to new file

Posted on 2008-10-16
9
499 Views
Last Modified: 2012-05-05
I need to add a file move fuction to this vb code basically I need this vb to look in the

MyNewFile = "\\Tvhviruser.v09.med.va.gov\tvhpublic\MCCR\596-Station Weekly Report\A-D\"

and move any excel files in this folder to another file ???
 
I also need to insert a formula into the exports on:
Set rs = db.OpenRecordset("A-E 1st Follow Up")
Set rs = db.OpenRecordset("A-E 2nd Follow Up")
Set rs = db.OpenRecordset("A-E 3rd Follow Up")

I need Column H to =IF(L2="","",0-(TODAY()-L2)) of the excel sheet I am exporting recordsets??

If anyone has any ideas please let me know, thanks
Public Function AE()
 
 
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheets
Dim MyMonth As String
Dim MyDay As String
Dim MyYear As String
Dim MyTime As String
Dim path As String
Dim MyExtension As String
Dim MyFileName As String
Dim FileFormat As String
Dim Password As String
Dim WriteResPassword As String
Dim ReadOnlyRecommended As String
Dim CreateBackup As String
 
Dim rs As Recordset
Dim db As Database
 
Set db = CurrentDb
 
Mydirectory = "\\Tvhviruser.v09.med.va.gov\tvhpublic\MCCR\AR Weekly Report Database\596-Station Weekly Report Database\Weekly Report.xls"
MyNewFile = "\\Tvhviruser.v09.med.va.gov\tvhpublic\MCCR\596-Station Weekly Report\A-D\"
NewFilename = "Weekly Report "
MyMonth = Format(Now, "mm")
MyDay = Format(Now, "dd")
MyYear = Format(Now, "yyyy")
MyTime = Format(Time, "hh.mm.ss")
FileFormat = ".xls"
Password = ""
WriteResPassword = ""
ReadOnlyRecommended = False
CreateBackup = False
MyFileName = MyNewFile + NewFilename + MyMonth + MyDay + MyYear + MyTime + FileFormat
 
Set xlApp = CreateObject("Excel.Application")
Set wb = xlApp.Workbooks.Open(Mydirectory)
 
 
   Do Until wb.Worksheets.Count = 13
   wb.Worksheets.Add
Loop
 
Set rs = db.OpenRecordset("A-E 0-30 Days")
 
wb.Worksheets(1).Range("A2").CopyFromRecordset rs
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E 31-60 Days")
 
wb.Worksheets(2).Range("A2").CopyFromRecordset rs
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E 61-90 Days")
 
wb.Worksheets(3).Range("A2").CopyFromRecordset rs
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E 91-120 Days")
 
wb.Worksheets(4).Range("A2").CopyFromRecordset rs
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E 121-180 Days")
 
wb.Worksheets(5).Range("A2").CopyFromRecordset rs
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E 181-365 Days")
 
wb.Worksheets(6).Range("A2").CopyFromRecordset rs
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E Over 365 Days")
 
wb.Worksheets(7).Range("A2").CopyFromRecordset rs
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E Payment&Resid Balance")
 
wb.Worksheets(9).Range("A2").CopyFromRecordset rs
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E Master")
 
wb.Worksheets(10).Range("A2").CopyFromRecordset rs
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E 1st Follow Up")
 
wb.Worksheets(11).Range("A2").CopyFromRecordset rs
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E 2nd Follow Up")
 
wb.Worksheets(12).Range("A2").CopyFromRecordset rs
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E 3rd Follow Up")
 
wb.Worksheets(13).Range("A2").CopyFromRecordset rs
 
wb.Worksheets(8).Columns("E").Style = "Percent"
 
wb.Worksheets(8).Columns("G").NumberFormat = "@"
 
Set rs = Nothing
 
Set rs = db.OpenRecordset("A-E EEOB COUNT")
 
wb.Worksheets(8).Range("H3").CopyFromRecordset rs
 
Set rs = Nothing
 
wb.SaveAs MyFileName
  
'Close Excel
wb.Close savechanges:=False
xlApp.Quit
Set xlApp = Nothing
Set wb = Nothing
Set ws = Nothing
 
End Function

Open in new window

0
Comment
Question by:nelsonje
  • 4
  • 4
9 Comments
 
LVL 28

Expert Comment

by:omgang
ID: 22741656
Here's a function you can call from your existing function to move all the Excel files.  Call it like this

Public Function AE()
 
 
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheets
Dim MyMonth As String
Dim MyDay As String
Dim MyYear As String
Dim MyTime As String
Dim path As String
Dim MyExtension As String
Dim MyFileName As String
Dim FileFormat As String
Dim Password As String
Dim WriteResPassword As String
Dim ReadOnlyRecommended As String
Dim CreateBackup As String
 
Dim rs As Recordset
Dim db As Database
Dim blResult As Boolean

blResult = MoveFiles()
If blResult = False Then
        'problem with moving the Excel files
        'decide how you want to proceed
End If

Set db = CurrentDb




OM Gang

Public Function MoveFiles() As Boolean
On Error GoTo Err_MoveFiles
 
    Dim objFSO As New FileSystemObject
    Dim objFolder As Folder
    Dim objFile As File
    Dim strSrcFileDir As String
    Dim strDestFileDir As String
    
        'source directory we are going to look in to check for Excel files
    strSrcFileDir = "\\Tvhviruser.v09.med.va.gov\tvhpublic\MCCR\596-Station Weekly Report\A-D\"
        'set your destination directory here
    strDestFileDir = "c:\temp2\"
    
    Set objFolder = objFSO.GetFolder(strSrcFileDir)
    For Each objFile In objFolder.Files
        If Right(objFile.name, 4) = ".xls" Then
            objFSO.MoveFile objFile.PATH, strDestFileDir & objFile.name
        End If
    Next
        'set function return successful
    MoveFiles = True    
 
Exit_MoveFiles:
    Set objFile = Nothing
    Set objFolder = Nothing
    Set objFSO = Nothing
    Exit Function
    
Err_MoveFiles:
    MsgBox Err.Number & ", " & Err.Description, , "Error"
        'set function return unsuccessful
    MoveFiles = False
    Resume Exit_MoveFiles
    
End Function

Open in new window

0
 
LVL 28

Expert Comment

by:omgang
ID: 22741750
<<I need Column H to =IF(L2="","",0-(TODAY()-L2)) of the excel sheet I am exporting recordsets??>>

Are you wanting to set the value of cell H2 to
=IF(L2="","",0-(TODAY()-L2))

or do you need to set the value for each cell in column H to
H2 =IF(L2="","",0-(TODAY()-L2))
H3 =IF(L3="","",0-(TODAY()-L3))
H4 =IF(L4="","",0-(TODAY()-L4))

etc.
????

OM Gang  
0
 

Author Comment

by:nelsonje
ID: 22741780
I need to set the Value of each cell in column H
0
Ransomware: The New Cyber Threat & How to Stop It

This infographic explains ransomware, type of malware that blocks access to your files or your systems and holds them hostage until a ransom is paid. It also examines the different types of ransomware and explains what you can do to thwart this sinister online threat.  

 
LVL 28

Expert Comment

by:omgang
ID: 22742185
Here's a way to populate column H with the desired formula.  Set the max value for intRowCounter high enough for your needs.
OM Gang
'add to your declarations section
Dim intRowCounter As Integer
Dim strFormula As String, strCell As String
 
 
 
 
Set rs = db.OpenRecordset("A-E 1st Follow Up")
 
wb.Worksheets(11).Range("A2").CopyFromRecordset rs
 
    'add formula to column H
    'adjust the row count as necessary
For intRowCounter = 2 To 100
    strCell = "H" & intRowCounter
    strFormula = "=IF(L" & intRowCounter & "=" & Chr(34) & Chr(34) & "," _
            & Chr(34) & Chr(34) & ",0-(TODAY()-L" & intRowCounter & "))"
    wb.Worksheets(4).Range(strCell) = strFormula
Next intRowCounter
 
Set rs = Nothing

Open in new window

0
 

Author Comment

by:nelsonje
ID: 22796190
I tried to do this VB code but it does not work the why I would like, I would like this foluma to be activly counting in the form so everyday when I go into this excel workbook it updated with the date count, does that make sense?
0
 

Expert Comment

by:birbilis
ID: 22796277
You can tell excel to recalculate the formulas, there's command for it. In Excel right click on an empty area of the toolbars and select to show the VBA toolbar, then open up VBA editor (or maybe could also use the VSA editor that's also there, but haven't tried it) and press F2 to see the Object Browser at the VBA window. There you can select to search the Excel library for "calculate" or "recalculate", "refresh" etc. to find the method you want
0
 

Author Comment

by:nelsonje
ID: 22796364
OMGANG, I get an error on the move file VB code

"ERROR"
USER-DEFINED TYPE NOT DEFINED??

Do you know why?
0
 
LVL 28

Accepted Solution

by:
omgang earned 500 total points
ID: 22796749
Try setting a reference to
Microsoft Scripting Runtime

OM Gang
0
 

Author Closing Comment

by:nelsonje
ID: 31506767
thanks
0

Featured Post

Ransomware: The New Cyber Threat & How to Stop It

This infographic explains ransomware, type of malware that blocks access to your files or your systems and holds them hostage until a ransom is paid. It also examines the different types of ransomware and explains what you can do to thwart this sinister online threat.  

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…
With Secure Portal Encryption, the recipient is sent a link to their email address directing them to the email laundry delivery page. From there, the recipient will be required to enter a user name and password to enter the page. Once the recipient …

860 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question