Code:
'this works
Sub RUN_THIS_COPY_AND_MOVE_FILES()
'copy all Excel files from FromPath to ToPath.
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
FromPath = "E:\cheyney\latest\UNEDITED DATA\" '<< Change
ToPath = "E:\cheyney\latest\EDITED DATA\" '<< Change
FileExt = "*.txt*" '<< Change
'You can use *.* for all files or *.doc for Word files
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
If FSO.FolderExists(ToPath) = False Then
MsgBox ToPath & " doesn't exist"
Exit Sub
End If
FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
Call Removes_TXT_header
End Sub
'this works
Sub Removes_TXT_header()
Dim strPath As String
Dim strFile As String
Dim FF As Long
Dim i As Long
Dim strText As String
Dim vLines As Variant
Dim Counter As Long
'set path acordingly
strPath = "E:\cheyney\latest\EDITED DATA\"
strFile = Dir(strPath & "*.txt")
FF = FreeFile
Do Until strFile = ""
'Read text file
Open strPath & strFile For Input As #FF
strText = Input$(LOF(FF), FF)
Close #FF
'Parse text (exclude first 6 lines)
vLines = Split(strText, vbLf)
If UBound(vLines) > 6 Then
strText = vLines(7)
For i = 8 To UBound(vLines)
strText = strText & vbLf & vLines(i)
Next
'Write parsed text to file
Open strPath & strFile For Output As #FF
Print #FF, strText
Close #FF
Counter = Counter + 1
End If
strFile = Dir
Loop
Call Create_31_Sheets
End Sub
'create 31 sheets
'this works
Sub Create_31_Sheets()
Application.ScreenUpdating = False
'Add and Name sheets 4 - 31
For sht = 4 To 31
Sheets.Add After:=Sheets(Sheets.Count)
Next
Call freze_panes
End Sub
'this works
'FREEZE PANES ALL SHEETS and format cells
Sub freze_panes()
Application.ScreenUpdating = False
Dim newsheet
Dim strDate As String
Dim NumDays As Long
Dim i As Long
Dim Sh As Object
Dim wsBase As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Activate
With ActiveWindow
.SplitColumn = 0: .SplitRow = 4
.FreezePanes = True
End With
Next
Call Load_data
End Sub
Sub Load_data()
Dim idx As Integer
Dim fpath As String
Dim fname As String
Application.ScreenUpdating = False
idx = 0
fpath = "E:\cheyney\latest\EDITED DATA\"
fname = Dir(fpath & "*.txt")
While (Len(fname) > 0)
idx = idx + 1
Sheets("Sheet" & idx).Select
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" _
& fpath & fname, Destination:=Range("A5"))
.Name = "a" & idx
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
fname = Dir
Columns("A:G").Select
Selection.ColumnWidth = 16.01
End With
Wend
Call RemoveEmptySheets
End Sub
Sub RemoveEmptySheets()
Dim shtTemp As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each shtTemp In ActiveWorkbook.Worksheets
If shtTemp.Range("A5") = "" Then
shtTemp.Delete
End If
Next
Call Delete_CALIB_AND_BLOWBACK_Data
End Sub
Sub Delete_CALIB_AND_BLOWBACK_Data()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim l As Long
Dim lR As Long
Dim i As Long
MsgBox ("YOU ARE ABOUT TO REMOVE BLOWBACK AND CALIBRATION ROWS!!!!! THIS WILL TAKE A COUPLE MINUTES.")
For Each ws In Worksheets
ws.Select
lR = ws.Range("E" & Rows.Count).End(xlUp).Row
For i = lR To 1 Step -1
If ws.Range("E" & i) > 0 Then
ws.Range("E" & i).EntireRow.Delete
End If
Next i
l = ws.Range("F" & Rows.Count).End(xlUp).Row
For i = l To 1 Step -1
If ws.Range("F" & i) > 0 Then
ws.Range("F" & i).EntireRow.Delete
End If
Next i
Next ws
Sheets(1).Activate
Range("A2").Select
Application.ScreenUpdating = True
Application.CutCopyMode = False
Call SelectSheets1
End Sub
'this works select all sheets
Sub SelectSheets1()
Dim mySheet As Object
For Each mySheet In Sheets
With mySheet
If .Visible = True Then .Select Replace:=False
End With
Next mySheet
Call format_cells
End Sub
'this works
Sub format_cells()
Application.DisplayAlerts = False
Columns("D:D").Select
Selection.NumberFormat = "0.00"
Range("C:C,G:G").Select
Range("G1").Activate
Selection.NumberFormat = "0"
Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
Range("A2").Select
ActiveCell.FormulaR1C1 = "=AVERAGE(C[2])"
Range("A1:A2").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
Range("A1").Select
ActiveCell.FormulaR1C1 = "AVERAGE"
Range("C4").Select
ActiveCell.FormulaR1C1 = "CO"
Range("D4").Select
ActiveCell.FormulaR1C1 = "O2"
Range("E4").Select
ActiveCell.FormulaR1C1 = "BLOWBACK"
Range("F4").Select
ActiveCell.FormulaR1C1 = "CALIB"
Range("G4").Select
ActiveCell.FormulaR1C1 = "FLOW"
Range("B1").Select
Selection.NumberFormat = "ddd mmm dd"
ActiveWorkbook.Worksheets(1).Activate
Range("A5").Select
Sheets("Sheet1").Select
Application.DisplayAlerts = True
End With
End With
Call RenameSheets
End Sub
Sub RenameSheets()
For i = 1 To Sheets.Count
If Worksheets(i).Range("B1").Value <> "" Then
Sheets(i).Name = Worksheets(i).Range("B1").Value
End If
Next
End SubHaving issues with renaming all sheets with cell value in this code, Any ideas? I am new at this, so that is why I am sure it looks sloppy to most.
