Move Text File After Importing to Excel

[rajkumar]

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]

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]

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