Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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. |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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. |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
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. |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
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. |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
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. |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
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. |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
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. |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
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. |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
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. |
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
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 |