Home |
Search |
Today's Posts |
#1
![]()
Posted to microsoft.public.excel.programming
|
|||
|
|||
![]()
Hi
Thanks for reading this! I've been purloining bits of code from various posts - and also used the macro recorder to come up with this: Sub TillFileImport() ' ' Macro1 Macro ' Macro recorded 20/02/2006 by Andy ' ' Dim myfile As Variant 'if you know the drive and folder: 'otherwise, just let the user point and click ChDrive "C" ChDir "C:\Documents and Settings\Andy\Desktop" myfile = Application.GetOpenFilename(filefilter:="*.txt, (*.txt)", _ Title:="What File?") If myfile = False Then 'you pressed cancel MsgBox "Ok. Quitting" Exit Sub End If Workbooks.OpenText Filename:=myfile, Origin:=xlWindows, _ StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(8, _ 1), Array(9, 1), Array(42, 1), Array(49, 1), Array(59, 1), Array(67, 1), Array(78, 1), Array _ (82, 1), Array(87, 1), Array(91, 1), Array(96, 1), Array(102, 1)) Cells.Select Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, HEADER:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'remove rows with text values in column A Application.ScreenUpdating = False On Error Resume Next Columns("A:A").SpecialCells(xlCellTypeConstants, 2) _ .EntireRow.Delete On Error GoTo 0 Application.ScreenUpdating = True Rows("1:1").Select Selection.Insert Shift:=xlDown Selection.Font.Bold = True ActiveCell.FormulaR1C1 = "SKU" Rows("1:1").Select Range("B1").Activate ActiveCell.FormulaR1C1 = "REF" Range("C1").Select ActiveCell.FormulaR1C1 = "DESC" Range("D1").Select ActiveCell.FormulaR1C1 = "QTY" Range("E1").Select ActiveCell.FormulaR1C1 = "PRICE" Range("F1").Select ActiveCell.FormulaR1C1 = "DISC" Range("G1").Select ActiveCell.FormulaR1C1 = "TOTAL" Range("H1").Select ActiveCell.FormulaR1C1 = "TRANS" Range("I1").Select ActiveCell.FormulaR1C1 = "ASS" Range("J1").Select ActiveCell.FormulaR1C1 = "TILL" Range("K1").Select ActiveCell.FormulaR1C1 = "TIME" Range("L1").Select ActiveCell.FormulaR1C1 = "GP%" Range("M1").Select ActiveCell.FormulaR1C1 = "REF2" Range("L1").Select On Error Resume Next ' In case there are no blanks Columns("A:A").SpecialCells(xlCellTypeBlanks).Enti reRow.Delete ActiveSheet.UsedRange 'Resets UsedRange for Excel 97 On Error Resume Next ' In case there are no blanks Columns("C:C").SpecialCells(xlCellTypeBlanks).Enti reRow.Delete ActiveSheet.UsedRange 'Resets UsedRange for Excel 97 ' = = = = = = = = = = = = = = = = ' Use of CDbl suggested by Peter Surcouf ' Program by Dana DeLouis, ' = = = = = = = = = = = = = = = = Dim rng As Range Dim bigrng As Range On Error Resume Next Set bigrng = Cells.SpecialCells(xlConstants, xlTextValues).Cells If bigrng Is Nothing Then Exit Sub For Each rng In bigrng.Cells rng = CDbl(rng) Next 'Reset used range Dim myLastRow As Long Dim myLastCol As Long Dim wks As Worksheet Dim dummyRng As Range For Each wks In ActiveWorkbook.Worksheets With wks myLastRow = 0 myLastCol = 0 Set dummyRng = .UsedRange On Error Resume Next myLastRow = _ .Cells.Find("*", after:=.Cells(1), _ LookIn:=xlFormulas, lookat:=xlWhole, _ searchdirection:=xlPrevious, _ searchorder:=xlByRows).Row myLastCol = _ .Cells.Find("*", after:=.Cells(1), _ LookIn:=xlFormulas, lookat:=xlWhole, _ searchdirection:=xlPrevious, _ searchorder:=xlByColumns).Column On Error GoTo 0 If myLastRow * myLastCol = 0 Then .Columns.Delete Else .Range(.Cells(myLastRow + 1, 1), _ .Cells(.Rows.Count, 1)).EntireRow.Delete .Range(.Cells(1, myLastCol + 1), _ .Cells(1, .Columns.Count)).EntireColumn.Delete End If End With Next wks End Sub Basically, it asks for a text file and mashes it about so it is useable. If possible I would like this to run on every open workbook, rather than ask for a specific file. I would like to be able to open a dozen text files and hit the button for this to run on all of them. Thanks for your help - whoever you may be! Cheers. Andy. |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
Run Macro In All Open Workbooks | Excel Discussion (Misc queries) | |||
Macro to merge open workbooks | Excel Discussion (Misc queries) | |||
Macro to open all linked workbooks | Excel Programming | |||
Open two new workbooks with macro | Excel Programming | |||
help with macro to open and close workbooks | Excel Programming |