dantheman9
Board Regular
- Joined
- Feb 5, 2011
- Messages
- 175
Hi All,
below is some code I'm running to import some text file data into excel via two folder locations, and different data types.
usually this has to be done over a network, which sometimes crashes it.
...I know that the layout of the coding is not great...that is something I have yet to be better at doing.
Anyhow...I would love some feedback from anyone that might think of some improvements to it?
below is some code I'm running to import some text file data into excel via two folder locations, and different data types.
usually this has to be done over a network, which sometimes crashes it.
...I know that the layout of the coding is not great...that is something I have yet to be better at doing.
Anyhow...I would love some feedback from anyone that might think of some improvements to it?
Code:
Public Sub DetectNewSplitFile()
Const sFileSpec As String = "*" & "Splits Data" & "*" & ".txt" ' type of file to watch
Const sAgeSelect As String = "00:00:30" ' ignore files newer than this
Dim sFileName As String
Dim dFileStamp As Date
Dim iFiles As Integer
Dim iNewFiles As Integer
Dim dLastFileProcessed As Date
Dim dLatestFileDetected As Date
Dim first As Integer
Dim nextno As Integer
Dim sh As Worksheet, sPath As String, sName As String
Dim r As Range, Fname As String
Dim ShtName1 As String
Dim ShtName As String
Dim NewSht As Worksheet
Dim str As String
Userform1.Fname1.Caption = LText
Userform1.NFiles.Caption = "Looking in Folder Please wait...."
Application.ScreenUpdating = False
myWorkbook.Activate
ShtName = "TEMPS"
On Error Resume Next
Set NewSht = Sheets(ShtName)
On Error GoTo 0
If NewSht Is Nothing Then
Set NewSht = Worksheets.Add
NewSht.name = ShtName
End If
Dim d As Integer
Dim rFilename As String
Dim replacename As String
Dim striped As String
'd = numbers + 10
Dim rFname As String
Dim ShtNamet As String
Dim NewShtt As Worksheet
Dim stripedt As String
Dim resultclass As String
Dim wy As String
Dim ResultStr As String
Dim FileNames As String
Dim FileNum As Integer
Dim CountLines As Double
Const rs As String = "Detailed Results"
dLastFileProcessed = lastDate
'ThisWorkbook.Sheets("Sheet1").Range ("A1")
sFileName = Dir(rFolder & sFileSpec)
Do While sFileName <> ""
dFileStamp = FileDateTime(rFolder & sFileName)
If dFileStamp > dLastFileProcessed And dFileStamp < Now() - TimeValue(sAgeSelect) Then
iNewFiles = iNewFiles + 1
'
' this is the point at which a new file has been detected: insert
' some coding here to process it as required
Dim flname As String
Dim ShtNamea As String, NewShta As Worksheet
ShtNamea = "SPLIT"
On Error Resume Next
Set NewShta = Sheets(ShtNamea)
On Error GoTo 0
If NewShta Is Nothing Then
Set NewShta = Worksheets.Add
NewShta.name = ShtNamea
End If
'Sheets("SPLIT").Move After:=Sheets(4)
ActiveWorkbook.Sheets("SPLIT").Activate
Cells.Select
Selection.ClearContents
Range("A1").Select
Dim FileName As Variant
Dim Sep As String
' only opens text files
Sep = ","
Fname = sFileName
Dim RowNdx As Long
Dim ColNdx As Integer
Dim TempVal As Variant
Dim WholeLine As String
Dim Pos As Integer
Dim NextPos As Integer
Dim SaveColNdx As Integer
Dim i As Long, _
LR As Long
Application.ScreenUpdating = False
SaveColNdx = ActiveCell.Column
RowNdx = ActiveCell.Row
Open Fname For Input Access Read As #1
While Not EOF(1)
Line Input #1, WholeLine
If Right(WholeLine, 1) <> Sep Then
WholeLine = WholeLine & Sep
End If
ColNdx = SaveColNdx
Pos = 1
NextPos = InStr(Pos, WholeLine, Sep)
While NextPos >= 1
TempVal = Mid(WholeLine, Pos, NextPos - Pos)
Cells(RowNdx, ColNdx).Value = TempVal
Pos = NextPos + 1
ColNdx = ColNdx + 1
NextPos = InStr(Pos, WholeLine, Sep)
Wend
RowNdx = RowNdx + 1
Wend
'Close #1
EndMacro:
On Error GoTo 0
' convert time from seconds to mm:ss.0 and remove blank data
Range("G2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-4]<>"""",RC[-4]/86400,"""")"
Selection.AutoFill Destination:=Range("G2:G10000"), Type:=xlFillDefault
Range("G2:G10000").Select
Selection.NumberFormat = "mm:ss.0"
Selection.Copy
Range("C2").PasteSpecial xlPasteValuesAndNumberFormats
Range("G1:G10000").ClearContents
Columns("5,7").Select
Selection.Delete
Range("G2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]<>"""",RC[-2]/86400,"""")"
Selection.AutoFill Destination:=Range("G2:G10000"), Type:=xlFillDefault
Range("G2:G10000").Select
Selection.NumberFormat = "mm:ss.0"
Selection.Copy
Range("E2").PasteSpecial xlPasteValuesAndNumberFormats
Range("G2:G10000").ClearContents
Range("A1").Select
flname = sFileName
srFolder = GetFileName(flname)
Application.ScreenUpdating = False
Dim Rrange As Range
Dim Trange As Range
Dim NRange As Range
Dim x As Integer
Dim b As Integer
Dim a As Integer
Dim ShtName3 As String
Dim NewSht3 As Worksheet
Dim ShtName4 As String
Dim NewSht4 As Worksheet
Dim ShtName5 As String
Dim NewSht5 As Worksheet
ShtName3 = "TEMPS"
On Error Resume Next
Set NewSht3 = Sheets(ShtName3)
On Error GoTo 0
If NewSht3 Is Nothing Then
Set NewSht3 = Worksheets.Add
NewSht3.name = ShtName3
End If
ShtName4 = "TEMPS1"
On Error Resume Next
Set NewSht4 = Sheets(ShtName4)
On Error GoTo 0
If NewSht4 Is Nothing Then
Set NewSht4 = Worksheets.Add
NewSht4.name = ShtName4
End If
ShtName5 = "SPLIT RESULTS"
On Error Resume Next
Set NewSht5 = Sheets(ShtName5)
On Error GoTo 0
If NewSht5 Is Nothing Then
Set NewSht5 = Worksheets.Add
NewSht5.name = ShtName5
End If
Sheets("Split").Activate
Range("SPLIT!B2").End(xlDown).Select
k = ActiveCell.Row
k = k - 2
' How many compeitors
Range("D6523").End(xlUp).Select
j = ActiveCell.Row
numbers = j / k
'Work out which data is split times
If (Range("C2").Value * 2) = Range("C3").Value Then
'Split is Time
ActiveSheet.Columns("E:F").Delete
ActiveSheet.Columns("A:A").Delete
Cells(j + 1, 1).Select
ActiveCell = "End"
Cells(j + 2, 1).Select
ActiveCell = "End of Line"
ActiveSheet.Range(Cells(2, 3), Cells(j, 3)).NumberFormat = "General"
Range("A1:C" & j + k).Copy
Range("TEMPS!A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Sheets("TEMPS").Activate
Range(Cells(1, 1), Cells(1, j)).Copy
Range("TEMPS1!A2").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Sheets("TEMPS").Activate
Range("B4").FormulaR1C1 = "=Text(R[-2]C[0],""mm:ss.0"")"
Range("B4").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range(Cells(4, 2), Cells(4, j + k)), Type:=xlFillDefault
Range(Cells(4, 2), Cells(4, k + 1)).Copy
Range("TEMPS1!B2").PasteSpecial xlPasteValues
x = 2
Sheets("Split").Activate ' new bit
Cells(2, 1).End(xlDown).Select ' new bit
first = ActiveCell.Row ' new bit
Sheets("TEMPS").Activate
Set Rrange = Range(Cells(3, x), Cells(3, x + (k - 1)))
b = numbers
Do Until b = 0
Rrange.Copy
Sheets("TEMPS1").Activate
Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
x = x + k
Sheets("SPLIT").Activate 'new bit
Cells(first, 1).End(xlDown).Select 'new bit
nextno = ActiveCell.Row 'new bit
Sheets("TEMPS").Activate
Set Rrange = Range(Cells(3, first), Cells(3, nextno - 1)) 'new bit
first = nextno
b = b - 1
Loop
Sheets("TEMPS1").Activate
Range("A2:A" & j).Activate
Selection.SpecialCells(xlCellTypeBlanks).Delete (xlShiftUp)
Range("A2").End(xlToRight).Offset(0, 1).Select
ActiveCell = "Finish"
Close #1
ShtNamet = "resultr"
On Error Resume Next
Set NewShtt = Sheets(ShtNamet)
On Error GoTo 0
If NewShtt Is Nothing Then
Set NewShtt = Worksheets.Add
NewShtt.name = ShtNamet
End If
' will run with sfolder - need to add rFolder to Dir string
stripedt = Replace(sFileName, "Splits Data", "Results")
rFname = Userform1.Fwatch & stripedt
'rFname = Dir(sFolder & resultclass)
' count lines testing
'Ask User for File's Name
FileNames = rFname
'Check for no entry
If FileNames = "" Then End
'Get Next Available File Handle Number
FileNum = FreeFile()
'Open Text File For Input
Open FileNames For Input As #FileNum
'Set The CountLines to 1
CountLines = 1
'Loop Until the End Of File Is Reached
Do While Seek(FileNum) <= LOF(FileNum)
Line Input #FileNum, ResultStr
If ResultStr = rs Then
Exit Do
End If
'Increment the CountLines By 1
CountLines = CountLines + 1
'Start Again At Top Of 'Do While' Statement
Loop
'Close The Open Text File
Close
' end of count lines testing
d = (CountLines - 1) + 5
NewShtt.Activate
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & rFname _
, Destination:=Range("$A$1"))
.FieldNames = True
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = d
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileCommaDelimiter = True
.TextFileColumnDataTypes = Array(9, 1, 1, 9, 1, 1, 9, 9, 9)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'delete not starting rowers
LR = Range("D" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
If Range("D" & i).Value = 0 Then
Rows(i).Delete
End If
Next i
Range(Cells(1, 1), Cells(numbers, 4)).Select
ActiveWorkbook.Worksheets("resultr").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("resultr").Sort.SortFields.Add Key:=Range(Cells(1, 1), Cells(numbers, 1)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("resultr").Sort
.SetRange Range(Cells(1, 1), Cells(numbers, 4))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range(Cells(1, 4), Cells(numbers, 4)).Copy
Sheets("TEMPS1").Activate
Range("X2").End(xlToLeft).Offset(1, 0).Select
ActiveCell.PasteSpecial xlPasteValuesAndNumberFormats
Range(Cells(2, 1), Cells(numbers + 2, k + 2)).Select
ActiveWorkbook.Worksheets("TEMPS1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("TEMPS1").Sort.SortFields.Add Key:=Range(Cells(3, k + 2), Cells(numbers + 2, k + 2)) _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("TEMPS1").Sort
.SetRange Range(Cells(3, 1), Cells(numbers + 2, k + 2))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' ----------- Time results -----------
Else
ActiveSheet.Columns("E:F").Delete
ActiveSheet.Columns("A:A").Delete
Cells(j + 1, 1).Select
ActiveCell = "End"
Cells(j + 2, 1).Select
ActiveCell = "End of Line"
ActiveSheet.Range(Cells(2, 3), Cells(j, 3)).NumberFormat = "General"
Range("A1:C" & j + k).Copy
Range("TEMPS!A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Sheets("TEMPS").Activate
Range(Cells(1, 1), Cells(1, j)).Copy
Range("TEMPS1!A2").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Sheets("TEMPS").Activate
Range("B4").FormulaR1C1 = "=Text(R[-2]C[0],""mm:ss.0"")"
Range("B4").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range(Cells(4, 2), Cells(4, j + k)), Type:=xlFillDefault
Range(Cells(3, 2), Cells(3, k + 1)).Copy
Range("TEMPS1!B2").PasteSpecial xlPasteAll
x = 2
Sheets("Split").Activate ' new bit
Cells(2, 1).End(xlDown).Select ' new bit
first = ActiveCell.Row ' new bit
Sheets("TEMPS").Activate
Set Rrange = Range(Cells(4, x), Cells(4, x + (k - 1)))
'ActiveCells.Copy
b = numbers
Do Until b = 0
Rrange.Copy
Sheets("TEMPS1").Activate
Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
x = x + k
Sheets("SPLIT").Activate 'new bit
Cells(first, 1).End(xlDown).Select 'new bit
nextno = ActiveCell.Row 'new bit
Sheets("TEMPS").Activate
Set Rrange = Range(Cells(4, first), Cells(4, nextno - 1)) 'new bit
first = nextno
b = b - 1
Loop
Sheets("TEMPS1").Activate
Range("A2:A" & j).Activate
Selection.SpecialCells(xlCellTypeBlanks).Delete (xlShiftUp)
Range("A2").End(xlToRight).Offset(0, 1).Select
ActiveCell = "Finish"
Close #1
ShtNamet = "resultr"
On Error Resume Next
Set NewShtt = Sheets(ShtNamet)
On Error GoTo 0
If NewShtt Is Nothing Then
Set NewShtt = Worksheets.Add
NewShtt.name = ShtNamet
End If
stripedt = Replace(sFileName, "Splits Data", "Results")
rFname = Userform1.Fwatch & stripedt
' count lines testing
'Ask User for File's Name
FileNames = rFname
'Check for no entry
If FileNames = "" Then End
'Get Next Available File Handle Number
FileNum = FreeFile()
'Open Text File For Input
Open FileNames For Input As #FileNum
'Set The CountLines to 1
CountLines = 1
'Loop Until the End Of File Is Reached
Do While Seek(FileNum) <= LOF(FileNum)
Line Input #FileNum, ResultStr
If ResultStr = rs Then
Exit Do
End If
'Increment the CountLines By 1
CountLines = CountLines + 1
'Start Again At Top Of 'Do While' Statement
Loop
'Close The Open Text File
Close
' end of count lines testing
d = (CountLines - 1) + 5
NewShtt.Activate
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & rFname _
, Destination:=Range("$A$1"))
.FieldNames = True
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = d
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileCommaDelimiter = True
.TextFileColumnDataTypes = Array(9, 1, 1, 9, 1, 1, 9, 9, 9)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'Delete non Starting rowers
LR = Range("C" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
If Range("C" & i).Value = 0 Then
Rows(i).Delete
End If
Next i
Range(Cells(1, 1), Cells(numbers, 4)).Select
ActiveWorkbook.Worksheets("resultr").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("resultr").Sort.SortFields.Add Key:=Range(Cells(1, 1), Cells(numbers, 1)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("resultr").Sort
.SetRange Range(Cells(1, 1), Cells(numbers, 4))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range(Cells(1, 3), Cells(numbers, 3)).Copy
Sheets("TEMPS1").Activate
Range("X2").End(xlToLeft).Offset(1, 1).Select
ActiveCell.PasteSpecial xlPasteValuesAndNumberFormats
Range(Cells(2, 1), Cells(numbers + 2, k + 3)).Select
ActiveWorkbook.Worksheets("TEMPS1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("TEMPS1").Sort.SortFields.Add Key:=Range(Cells(3, k + 3), Cells(numbers + 2, k + 3)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("TEMPS1").Sort
.SetRange Range(Cells(3, 1), Cells(numbers + 2, k + 3))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("X3").End(xlToLeft).Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-1],""mm:ss.0"")"
Selection.AutoFill Destination:=Range(Cells(3, k + 4), Cells(numbers + 2, k + 4)), Type:=xlFillDefault
Range(Cells(3, k + 4), Cells(numbers + 2, k + 4)).Copy
Range(Cells(3, k + 2), Cells(numbers + 2, k + 2)).PasteSpecial xlPasteValues
Range(Cells(3, k + 3), Cells(numbers + 2, k + 4)).Delete
End If
End If
' *************************************************************************
Range("TEMPS1!B1").Select
Range(Cells(1, 2), Cells(1, k + 2)).Merge
ActiveCell = srFolder & " (Rounded Up)"
Range(Cells(1, 1), Cells(2, k + 2)).Font.Bold = True
Range(Cells(1, 1), Cells(numbers + 2, k + 2)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range(Cells(1, 1), Cells(numbers + 2, k + 2)).Select
Range(Cells(1, 1), Cells(numbers + 2, k + 2)).Copy
Sheets("SPLIT RESULTS").Activate
Range("A65536").End(xlUp).Offset(3, 0).PasteSpecial xlPasteAll
With Selection
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
Application.DisplayAlerts = False
Sheets("TEMPS").Select
Selection.Clear
Sheets("resultr").Select
Selection.Clear
Sheets("TEMPS1").Select
Selection.Clear
Sheets("SPLIT").Select
Selection.Clear
Application.DisplayAlerts = True
' sFileName = Dir(sFolder & sFileSpec)
If dFileStamp > dLatestFileDetected Then dLatestFileDetected = dFileStamp
' End If
iFiles = iFiles + 1
sFileName = Dir()
' testing
' Close #1
Loop
' if we found any new files, store the latest date/time stamp back in the hidden worksheet
If iNewFiles > 0 Then lastDate = dLatestFileDetected
' reset display after copy and pasting all data
Application.DisplayAlerts = False
NewSht.Delete
'Worksheets("filepath").Delete
Application.DisplayAlerts = True
ActiveCell.Show
cellhtml = Range("A65536").End(xlUp).Row
'If iNewFiles > 0 Then
Userform1.NFiles.Caption = ">Done: " & CStr(iNewFiles) & " new file" & IIf(iNewFiles = 1, "", "s") & " found" & Space(10) & "Updated @: (" + Format(Now(), "hh:mm") & ")"
LText = Userform1.NFiles
Application.DisplayAlerts = False
On Error Resume Next
Sheets("TEMPS1").Delete
Sheets("SPLIT").Delete
Sheets("resultr").Delete
Sheets("SPLIT RESULTS").Activate
On Error GoTo 0
Application.DisplayAlerts = True
cellhtml = Range("A65536").End(xlUp).Row
If Userform1.htmloption = True Then
Call MakeHTM
End If
Application.ScreenUpdating = True
Timerun = Now() + TimeValue("00:07:00")
Application.OnTime Timerun, "DetectNewSplitFile"
End Sub
