View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
No Name
 
Posts: n/a
Default Repeat macro for all open workbooks

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.