PDA

View Full Version : Move Text File After Importing to Excel



rajkumar
06-25-2009, 01:05 AM
Hi Experts,

I need a help in moving the text file after once it is imported and saved in to the smae folder as .xls.

I have A Parant Folder named Data_Analysis in c drive and it contains lot of sub folders. Under each sub folder i have a text file.

Now what i wanto automate is Once the macro finished importing and saving as excel file. The text file has to be moved to a folder called Completed Reports within the Data_Analysis folder.

My text file is named as MRC-BLR.txt.etc...

If more than one text file is present in the folder then the macro has loop from to first text file to last text file in that foldr.

Advance thanks
Raj

GTO
06-26-2009, 11:35 PM
Now what i wanto automate is Once the macro finished importing and saving as excel file....

...If more than one text file is present in the folder then the macro has loop from to first text file to last text file in that foldr.

Hi Raj,

Could you post a sample (no private/complany info) workbook with your code thus far?

Reference your last sentence, I leastwise am not quite clear...

Mark

rajkumar
06-27-2009, 05:33 AM
Hi GTO,

Please find a sample code herewith which imports the text file and saves the same after deleting junk characters and saves as .xls in the same folder.

Now i want to move the text file to some other folder once the importing and saving is done.

This code loops for any number files present in the same folder.
strpath is C:\Data_Analysis\



Sub BrokenCallsReport()
Dim t As Date
'set a variable equal to the starting time
t = Now()
fName = Dir(strpath & "BROKEN CALLS\BROKEN CALLS-*.txt")
If Not FileFolderExists(strpath & "BROKEN CALLS\BROKEN CALLS-*.txt") Then
MsgBox "Text file for this report is not present. Hence Ending Report"
Exit Sub
Else
If fName <> "" Then
Do
Application.ScreenUpdating = False
Call PGMTR
Workbooks.OpenText FileName:= _
strpath & "Broken Calls\" & fName _
, Origin:=437, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array( _
Array(0, 1), Array(15, 1), Array(29, 1), Array(49, 1), Array(71, 1), Array(91, 1), Array( _
108, 1), Array(129, 1), Array(151, 1), Array(167, 1), Array(226, 1), Array(237, 1)), _
TrailingMinusNumbers:=True
Call DELbc1(fName)
fName = Dir()
Loop Until fName = ""
End If
End If
Application.ScreenUpdating = True
MsgBox ("BROKEN CALLS Report is Completed in ") & Format(Now() - t, "hh:mm:ss") & (" (HH:MM:SS)")
End
End Sub

Sub DELbc1(ByVal fName As String)
Dim DelRange As Range
Dim C As Range
For Each C In ActiveSheet.Range("A:A").Cells
If C.Value = "" Then
If DelRange Is Nothing Then
Set DelRange = C.EntireRow
Else
Set DelRange = Union(DelRange, C.EntireRow)
End If
End If
Next C
'turn on error handling in case no range is assigned
On Error Resume Next
DelRange.Delete
On Error GoTo 0
Call DELbc2(fName)
End Sub

Sub DELbc2(ByVal fName As String)
Dim DelRange As Range
Dim C As Range
For Each C In ActiveSheet.Range("A:A").Cells
If C.Value = "Xerox India L" Then
If DelRange Is Nothing Then
Set DelRange = C.EntireRow
Else
Set DelRange = Union(DelRange, C.EntireRow)
End If
End If
Next C
'turn on error handling in case no range is assigned
On Error Resume Next
DelRange.Delete
On Error GoTo 0
Call delbc3(fName)
End Sub

Sub delbc3(ByVal fName As String)
On Error Resume Next
Range("A:A").AutoFilter Field:=1, Criteria1:="*--*"
If err = 0 Then _
Range("A:A").SpecialCells(xlCellTypeVisible) _
.EntireRow.Delete
ActiveSheet.AutoFilterMode = False
ActiveSheet.UsedRange
'turn off error handling
On Error GoTo 0
Call DELbc4(fName)
End Sub

Sub DELbc4(ByVal fName As String)
Dim DelRange As Range
Dim C As Range
For Each C In ActiveSheet.Range("A:A").Cells
If C.Value = "MCLN" Then
If DelRange Is Nothing Then
Set DelRange = C.EntireRow
Else
Set DelRange = Union(DelRange, C.EntireRow)
End If
End If
Next C
'turn on error handling in case no range is assigned
On Error Resume Next
DelRange.Delete
On Error GoTo 0
Call HEADINGBC(fName)
End Sub

Sub HEADINGBC(ByVal fName As String)
Dim vHdr As Variant
vHdr = Array("MCLN", "BRANCH", "INCIDENT NO", "ENGR NO", "INCIDENT DATE", _
"MC SL NO", "REASON BRK CALLS", "MODEL", "DOWN TIME", "CUSTOMER NAME", "PARTS USED")
Rows(1).Insert
Range("A1").Resize(, UBound(vHdr) + 1).Value = vHdr
Call WEEKMTHBRKCALLS(fName)
End Sub

Sub WEEKMTHBRKCALLS(ByVal fName As String)
Columns("K:K").Select
Selection.Copy
Columns("L:O").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim vHdr As Variant
vHdr = Array("WEEK NO", "MONTH", "QTR", "HALF YEAR")
Range("L1").Resize(, UBound(vHdr) + 1).Value = vHdr
ChDir strpath
Workbooks.Open FileName:=strpath & strName, Origin:= _
xlWindows
Windows(fName).Activate
Dim myRng As Range
Dim lastRw As Long
sSheetName = Left(fName, Len(fName) - 4)
'1ST FORMULA
lastRw = Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets(sSheetName).Range("L2")
.Formula = "=VLOOKUP(RC[-7],'Reference Table.xls'!WEEKNO,3,0)"
.AutoFill Destination:=Worksheets(sSheetName).Range("L2:L" & lastRw&)
End With
'2ND FORMULA
lastRw = Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets(sSheetName).Range("M2")
.Formula = "=TEXT(RC[-8],""MMM"")"
.AutoFill Destination:=Worksheets(sSheetName).Range("M2:M" & lastRw&)
End With
'3RD FORMULA
lastRw = Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets(sSheetName).Range("N2")
.Formula = "=""Q""&ROUNDUP(MONTH(RC[-9])/3,0)"
.AutoFill Destination:=Worksheets(sSheetName).Range("N2:N" & lastRw&)
End With
'4TH FORMULA
lastRw = Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets(sSheetName).Range("O2")
.Formula = "=""H""&ROUNDUP(MONTH(RC[-10])/6,0)"
.AutoFill Destination:=Worksheets(sSheetName).Range("O2:O" & lastRw&)
End With
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Reference Table.xls").Close
Call FORMATTABLE
Range("A1").Select
Call svBRK(fName)
End Sub

Sub svBRK(ByVal fName As String)
Application.DisplayAlerts = False
sSavename = strpath & "BROKEN CALLS\" & Left(fName, Len(fName) - 4) & ".xls"
ActiveWorkbook.SaveAs FileName:=sSavename, FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Application.DisplayAlerts = True
Windows(Replace(UCase(fName), ".TXT", ".xls")).Close
End Sub