ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Repeat macro for all open workbooks (https://www.excelbanter.com/excel-programming/355171-repeat-macro-all-open-workbooks.html)

No Name
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.



NickHK
Repeat macro for all open workbooks
 
Andy,
Look at the last argument for GetOpenFilename; MultiSelect.
If this is True then an array of filenames is returned, even if only one
file is selected.

So you need wrap your whole "massage" code in a loop
'Check if the array is 1 or 0 based, can't remember
Dim SourceWB As Workbook
For i =1 to UBound(MySelectedFiles)
Set SourceWB = Workbooks.OpenText (MySelectedFiles(i),,,,,,)
..........
Next

Also, there's no need to do all those .Selects. Something like:
With SourceWB.Worksheet(1).Range("A1")
.Offset(0,1).Value= "REF"
.Offset(0,2).Value= "DESC"
...................

And move all your Dims out of all loops.

NickHK


<Andy wrote in message ...
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.

Bob Phillips[_6_]
Repeat macro for all open workbooks
 
You need to wrap the code in say


Dim oWB As Workbook

For Each oWB In Workbooks

.... your code

Next oWB

then in your code when you refer to activeworkbook, such as

For Each wks In ActiveWorkbook.Worksheets

You need to refer to the workbook object

For Each wks In oWB.Worksheets

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

<Andy wrote in message ...
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.

No Name
Repeat macro for all open workbooks
 
Thanks Bob. The problem is that the macro imports a text file at the
beginning. Is it possible for me to select several files for it to import
on, rather than just the one (or for it to import all of the files in a
folder)?
I can probably suss out how to loop the macro once the files have been
opened in Excel - it's just getting to that point that is the problem!
Cheers.
Andy.

"Bob Phillips" wrote in message
...
You need to wrap the code in say


Dim oWB As Workbook

For Each oWB In Workbooks

.... your code

Next oWB

then in your code when you refer to activeworkbook, such as

For Each wks In ActiveWorkbook.Worksheets

You need to refer to the workbook object

For Each wks In oWB.Worksheets

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

<Andy wrote in message ...
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.

NickHK
Repeat macro for all open workbooks
 
Andy,
Did you see my post about the last argument to GetOpenFilename ?
Hint; MultiSelect=True.

NickHK

<Andy wrote in message ...
Thanks Bob. The problem is that the macro imports a text file at the
beginning. Is it possible for me to select several files for it to import
on, rather than just the one (or for it to import all of the files in a
folder)?
I can probably suss out how to loop the macro once the files have been
opened in Excel - it's just getting to that point that is the problem!
Cheers.
Andy.

"Bob Phillips" wrote in message
...
You need to wrap the code in say


Dim oWB As Workbook

For Each oWB In Workbooks

.... your code

Next oWB

then in your code when you refer to activeworkbook, such as

For Each wks In ActiveWorkbook.Worksheets

You need to refer to the workbook object

For Each wks In oWB.Worksheets

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

<Andy wrote in message ...
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.

No Name
Repeat macro for all open workbooks
 
Nick
Thanks for your reply. I didn't spot that last time, sorry. I'm not all that
hot on macros, so I'm struggling - a bit out of my depth. I'm just trying to
ease the job of dissecting a year's till files. Bear with me!

Cheers.
Andy.

"NickHK" wrote in message
...
Andy,
Did you see my post about the last argument to GetOpenFilename ?
Hint; MultiSelect=True.

NickHK

<Andy wrote in message ...
Thanks Bob. The problem is that the macro imports a text file at the
beginning. Is it possible for me to select several files for it to import
on, rather than just the one (or for it to import all of the files in a
folder)?
I can probably suss out how to loop the macro once the files have been
opened in Excel - it's just getting to that point that is the problem!
Cheers.
Andy.

"Bob Phillips" wrote in message
...
You need to wrap the code in say


Dim oWB As Workbook

For Each oWB In Workbooks

.... your code

Next oWB

then in your code when you refer to activeworkbook, such as

For Each wks In ActiveWorkbook.Worksheets

You need to refer to the workbook object

For Each wks In oWB.Worksheets

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

<Andy wrote in message ...
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.

No Name
Repeat macro for all open workbooks
 
Hi Nick

Here is the beginning of my macro now:
'
' 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?",
MultiSelect:=True)


If myfile = False Then
'you pressed cancel
MsgBox "Ok. Quitting"
Exit Sub
End If

Dim rng As Range
Dim bigrng As Range
Dim SourceWB As Workbook
For i = 1 To UBound(MySelectedFiles)
Set SourceWB = Workbooks.OpenText(MySelectedFiles(i), 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


I get an error when I run it on the Set SourceWB line and OpenText is
highlighted. It says 'Compile Error - Expected function or variable'
Thanks for your help.
Andy.


<Andy wrote in message ...
Nick
Thanks for your reply. I didn't spot that last time, sorry. I'm not all
that hot on macros, so I'm struggling - a bit out of my depth. I'm just
trying to ease the job of dissecting a year's till files. Bear with me!

Cheers.
Andy.

"NickHK" wrote in message
...
Andy,
Did you see my post about the last argument to GetOpenFilename ?
Hint; MultiSelect=True.

NickHK

<Andy wrote in message ...
Thanks Bob. The problem is that the macro imports a text file at the
beginning. Is it possible for me to select several files for it to
import
on, rather than just the one (or for it to import all of the files in a
folder)?
I can probably suss out how to loop the macro once the files have been
opened in Excel - it's just getting to that point that is the problem!
Cheers.
Andy.

"Bob Phillips" wrote in message
...
You need to wrap the code in say


Dim oWB As Workbook

For Each oWB In Workbooks

.... your code

Next oWB

then in your code when you refer to activeworkbook, such as

For Each wks In ActiveWorkbook.Worksheets

You need to refer to the workbook object

For Each wks In oWB.Worksheets

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

<Andy wrote in message ...
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.

Bob Phillips[_6_]
Repeat macro for all open workbooks
 
Just add a GetOpenFilename when opening the textfile within that loop rather
than open by name.

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

<Andy wrote in message ...
Thanks Bob. The problem is that the macro imports a text file at the
beginning. Is it possible for me to select several files for it to import
on, rather than just the one (or for it to import all of the files in a
folder)?
I can probably suss out how to loop the macro once the files have been
opened in Excel - it's just getting to that point that is the problem!
Cheers.
Andy.

"Bob Phillips" wrote in message
...
You need to wrap the code in say


Dim oWB As Workbook

For Each oWB In Workbooks

.... your code

Next oWB

then in your code when you refer to activeworkbook, such as

For Each wks In ActiveWorkbook.Worksheets

You need to refer to the workbook object

For Each wks In oWB.Worksheets

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

<Andy wrote in message ...
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.

No Name
Repeat macro for all open workbooks
 
Nick

I now get a Type Mismatch error.
I get the dialog box to select the files but when I click Open, I get the
error. I've tried the Cancel button from the dialog box and it exits OK so
I'm guessing it must be the section starting with:

Dim rng As Range
Dim bigrng As Range
Dim SourceWB As Workbook
For i = 1 To UBound(MySelectedFiles)
Set SourceWB = Workbook.OpenText(Filename:=MySelectedFiles(i),
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


Thanks for your help - again!
Cheers.
Andy.
<Andy wrote in message ...
Hi Nick

Here is the beginning of my macro now:
'
' 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?",
MultiSelect:=True)


If myfile = False Then
'you pressed cancel
MsgBox "Ok. Quitting"
Exit Sub
End If

Dim rng As Range
Dim bigrng As Range
Dim SourceWB As Workbook
For i = 1 To UBound(MySelectedFiles)
Set SourceWB = Workbooks.OpenText(MySelectedFiles(i), 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


I get an error when I run it on the Set SourceWB line and OpenText is
highlighted. It says 'Compile Error - Expected function or variable'
Thanks for your help.
Andy.


<Andy wrote in message ...
Nick
Thanks for your reply. I didn't spot that last time, sorry. I'm not all
that hot on macros, so I'm struggling - a bit out of my depth. I'm just
trying to ease the job of dissecting a year's till files. Bear with me!

Cheers.
Andy.

"NickHK" wrote in message
...
Andy,
Did you see my post about the last argument to GetOpenFilename ?
Hint; MultiSelect=True.

NickHK

<Andy wrote in message ...
Thanks Bob. The problem is that the macro imports a text file at the
beginning. Is it possible for me to select several files for it to
import
on, rather than just the one (or for it to import all of the files in a
folder)?
I can probably suss out how to loop the macro once the files have been
opened in Excel - it's just getting to that point that is the problem!
Cheers.
Andy.

"Bob Phillips" wrote in message
...
You need to wrap the code in say


Dim oWB As Workbook

For Each oWB In Workbooks

.... your code

Next oWB

then in your code when you refer to activeworkbook, such as

For Each wks In ActiveWorkbook.Worksheets

You need to refer to the workbook object

For Each wks In oWB.Worksheets

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

<Andy wrote in message ...
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.

Dave Peterson
Repeat macro for all open workbooks
 
Watch your variables. Sometimes you use MyFile and other times, it was
mySelectedfiles.

This might get you closer:

Option Explicit
Sub testme01()
Dim myfile As Variant
Dim rng As Range
Dim bigrng As Range
Dim SourceWB As Workbook
Dim i As Long

'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?", MultiSelect:=True)

If IsArray(myfile) = False Then
'you pressed cancel
MsgBox "Ok. Quitting"
Exit Sub
End If

For i = LBound(myfile) To UBound(myfile)
Workbooks.OpenText Filename:=myfile(i), 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))

Set SourceWB = ActiveWorkbook

With SourceWB.Worksheets(1)
.Cells.Sort Key1:=.Range("A1"), Order1:=xlAscending, _
HEADER:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
Next i

End Sub

Although, if I knew the data, I wouldn't let excel guess at whether it contained
a header (for the sort). I'd just tell excel in the code.

Andy wrote:

Nick

I now get a Type Mismatch error.
I get the dialog box to select the files but when I click Open, I get the
error. I've tried the Cancel button from the dialog box and it exits OK so
I'm guessing it must be the section starting with:

Dim rng As Range
Dim bigrng As Range
Dim SourceWB As Workbook
For i = 1 To UBound(MySelectedFiles)
Set SourceWB = Workbook.OpenText(Filename:=MySelectedFiles(i),
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

Thanks for your help - again!
Cheers.
Andy.
<Andy wrote in message ...
Hi Nick

Here is the beginning of my macro now:
'
' 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?",
MultiSelect:=True)


If myfile = False Then
'you pressed cancel
MsgBox "Ok. Quitting"
Exit Sub
End If

Dim rng As Range
Dim bigrng As Range
Dim SourceWB As Workbook
For i = 1 To UBound(MySelectedFiles)
Set SourceWB = Workbooks.OpenText(MySelectedFiles(i), 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


I get an error when I run it on the Set SourceWB line and OpenText is
highlighted. It says 'Compile Error - Expected function or variable'
Thanks for your help.
Andy.


<Andy wrote in message ...
Nick
Thanks for your reply. I didn't spot that last time, sorry. I'm not all
that hot on macros, so I'm struggling - a bit out of my depth. I'm just
trying to ease the job of dissecting a year's till files. Bear with me!

Cheers.
Andy.

"NickHK" wrote in message
...
Andy,
Did you see my post about the last argument to GetOpenFilename ?
Hint; MultiSelect=True.

NickHK

<Andy wrote in message ...
Thanks Bob. The problem is that the macro imports a text file at the
beginning. Is it possible for me to select several files for it to
import
on, rather than just the one (or for it to import all of the files in a
folder)?
I can probably suss out how to loop the macro once the files have been
opened in Excel - it's just getting to that point that is the problem!
Cheers.
Andy.

"Bob Phillips" wrote in message
...
You need to wrap the code in say


Dim oWB As Workbook

For Each oWB In Workbooks

.... your code

Next oWB

then in your code when you refer to activeworkbook, such as

For Each wks In ActiveWorkbook.Worksheets

You need to refer to the workbook object

For Each wks In oWB.Worksheets

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

<Andy wrote in message ...
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.













--

Dave Peterson


All times are GMT +1. The time now is 10:13 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com