Wednesday, February 10, 2010

Get Today Created files from specified folder and copy content into desired file

'Option Explicit

dim objFileSysob

Set objFileSysOb = CreateObject("Scripting.FileSystemObject")

Dim Month

Month=inputbox("Enter the Month Name need to get a recent file","Tasks on This Month","February")

'Month="February"

dim colFolderName

Set colFolderName = objFileSysOb.GetFolder("E:\Baba_CRN\CD3\Sent Mails\Status\"&Month)

dim vFiles

Set vFiles =colFolderName.Files

dim vfiles_cnt

vfiles_cnt=vFiles.count

dim win_ex,get_ex, FileName,dd,fil_dat,File

set win_ex=createobject("wscript.shell")

'msgbox vFiles.count

For each i in vFiles

'd=ubound(vFiles)
'msgbox d

d=Split(i,"\")

FileName=d(ubound(d))

set get_ex=objFileSysOb.getfile("E:\Baba_CRN\CD3\Sent Mails\Status\"&Month&"\"&FileName)

' win_ex.popup "FileName is :" & FileName & VBNewLine &"Date Created :"&get_ex.datecreated,1,"Name & Created Date of a File"

' msgbox get_ex.datecreated
' msgbox Date

dd=split(get_ex.datecreated," ")

fil_dat=dd(Lbound(dd))

' win_ex.popup fil_dat,1,"file date"
File=FileName
if (trim(Date)=trim(fil_dat)) then

' win_ex.popup "File is created on "&Date,1,"File creation on"

Call xl(File)

'Exit For ' If you use this... Only one file data will be retrieved

Else

' win_ex.popup "File is created earlier",1,"File creation on"

End if

Next

'msgbox "Recently Created File is: "&File






Function xl(File)

'*******************************************************************
'Updating the Status to the Completed Tasks Automatically.
'*******************************************************************

Dim ws,xl_sht,RC,CC

Set ws=createobject("wscript.shell")

Dim xl_src, xl1_des

Set xl_src=createobject("excel.application")

xl_src.Workbooks.Open("E:\Baba_CRN\CD3\Assigned Tasks\Completed Tasks_CD3\Completed_Tasks_CD3.xlsx")

xl_src.Visible=true

set xl_sht=xl_src.Sheets("Sheet1")

RC=xl_sht.usedrange.rows.count

CC=xl_sht.usedrange.columns.count

ws.Popup "Row Count: "&RC,2,"Used Rows in a Completed Tasks document"

'msgbox "Row Count: "&RC

ws.Popup "Column Count: "&CC,2,"Used Columns in a Completed Tasks document"

'msgbox "Column Count: "&CC

ReDim Val(CC)

For s=1 to CC

Redim preserve val(s)
val(s)=xl_src.Sheets("Sheet1").cells(1,s).value
field=val(s)

xl_src.Sheets("Sheet1").cells(RC+1,s)=field
xl_src.Sheets("Sheet1").Cells(RC+1,s).font.colorindex=2 ' Font Color
xl_src.Sheets("Sheet1").Cells(RC+1,s).interior.colorindex=8 ' Interior Color
xl_src.Sheets("Sheet1").Cells(RC+1,s).font.bold=true ' Font Bold
xl_src.Sheets("Sheet1").Cells(RC+1,s).Borders.LineStyle=1 ' Cell Border style
xl_src.Sheets("Sheet1").Cells(RC+1,s).Borders.weight=2 ' Border width
xl_src.Sheets("Sheet1").Cells(RC+1,s).Borders.Colorindex=1 ' Border Color

' Call copyy(field,s)

Next

'Dim xl1_des

Set xl1_des=createobject("excel.application")

xl1_des.Visible=true

xl1_des.Workbooks.Open("E:\Baba_CRN\CD3\Sent Mails\Status\"&Month&"\"&File)

set xl1_sh=xl1_des.Sheets("Sheet1")

RC_1=xl1_sh.usedrange.rows.count

CC_1=xl1_sh.usedrange.columns.count

'ws.Popup "Task_Row Count: "&RC_1,2,"Used Rows Count in Task_File"

'msgbox "Task_Row Count "&RC_1

'ws.Popup "Task_Column Count: "&CC_1,2,"Used Column Count in Task_File",3

'msgbox "Task_Column Count "&CC_1

RC_T=RC+2

For k=2 to RC_1

xl_src.Cells(RC_T,1).value=k-1

xl_src.Cells(RC_T,2).value=Date

xl_src.cells(RC_T,2).interior.colorindex=23

xl_src.cells(RC_T,2).font.bold=true

xl_src.cells(RC_T,2).font.colorindex=2

For b=1 to CC


xl_src.cells(RC_T,b).borders.linestyle=1

xl_src.cells(RC_T,b).borders.weight=2

xl_src.cells(RC_T,b).borders.colorindex=1

Next


For j=2 to 6

cp=xl1_des.Cells(k,j).value

xl_src.Cells(RC_T,j+1).value=cp

xl_src.cells(RC_T,j).Wraptext=True


' print xl_src.Cells(RC_T,j+1).value

For l=8 to 11

cp1=xl1_des.Cells(k,l).value

xl_src.cells(RC_T,l).value=cp1

xl_src.cells(RC_T,l).Wraptext=True


Next

Next

RC_T=RC_T+1

Next

xl1_des.ActiveWorkbook.save

xl1_des.ActiveWorkbook.Close

xl1_des.Quit

Set xl1_des=nothing

xl_src.ActiveWorkbook.Save

xl_src.ActiveWorkbook.Close

xl_src.Quit

Set xl_src=nothing

End Function

Thanks & Regards
Baba Fakruddin.D
baba.fakru@gmail.com

No comments:

There was an error in this gadget